summaryrefslogtreecommitdiff
path: root/gcc/ada
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/ada')
-rw-r--r--gcc/ada/ChangeLog3099
-rw-r--r--gcc/ada/ChangeLog-20165918
-rw-r--r--gcc/ada/Makefile.rtl3
-rw-r--r--gcc/ada/a-calend.adb6
-rw-r--r--gcc/ada/a-calend.ads19
-rw-r--r--gcc/ada/a-cbhama.adb6
-rw-r--r--gcc/ada/a-cfdlli.adb4
-rw-r--r--gcc/ada/a-cfdlli.ads4
-rw-r--r--gcc/ada/a-chtgbo.adb4
-rw-r--r--gcc/ada/a-chtgbo.ads2
-rw-r--r--gcc/ada/a-chtgop.adb10
-rw-r--r--gcc/ada/a-chtgop.ads2
-rw-r--r--gcc/ada/a-cihama.adb14
-rw-r--r--gcc/ada/a-cihase.adb14
-rw-r--r--gcc/ada/a-cofove.adb4
-rw-r--r--gcc/ada/a-coinho-shared.adb94
-rw-r--r--gcc/ada/a-coinve.adb19
-rw-r--r--gcc/ada/a-comutr.adb8
-rw-r--r--gcc/ada/a-conhel.adb9
-rw-r--r--gcc/ada/a-conhel.ads2
-rw-r--r--gcc/ada/a-convec.adb5
-rw-r--r--gcc/ada/a-crbtgo.adb4
-rw-r--r--gcc/ada/a-crdlli.adb4
-rw-r--r--gcc/ada/a-cuprqu.adb199
-rw-r--r--gcc/ada/a-cuprqu.ads78
-rw-r--r--gcc/ada/a-direct.adb26
-rw-r--r--gcc/ada/a-direio.adb11
-rw-r--r--gcc/ada/a-direio.ads4
-rw-r--r--gcc/ada/a-dispat.ads3
-rw-r--r--gcc/ada/a-exetim-darwin.adb210
-rw-r--r--gcc/ada/a-exetim-mingw.ads1
-rw-r--r--gcc/ada/a-exexpr-gcc.adb5
-rw-r--r--gcc/ada/a-locale.adb9
-rw-r--r--gcc/ada/a-locale.ads11
-rw-r--r--gcc/ada/a-ngcefu.adb12
-rw-r--r--gcc/ada/a-ngcoar.adb11
-rw-r--r--gcc/ada/a-ngrear.adb9
-rw-r--r--gcc/ada/a-nudira.adb4
-rw-r--r--gcc/ada/a-nudira.ads4
-rw-r--r--gcc/ada/a-nuflra.adb6
-rw-r--r--gcc/ada/a-nuflra.ads6
-rw-r--r--gcc/ada/a-numaux-x86.adb8
-rw-r--r--gcc/ada/a-rbtgbo.adb4
-rw-r--r--gcc/ada/a-reatim.ads3
-rw-r--r--gcc/ada/a-sequio.adb11
-rw-r--r--gcc/ada/a-sequio.ads4
-rw-r--r--gcc/ada/a-strfix.adb4
-rw-r--r--gcc/ada/a-strunb-shared.adb31
-rw-r--r--gcc/ada/a-strunb-shared.ads9
-rw-r--r--gcc/ada/a-stwibo.ads4
-rw-r--r--gcc/ada/a-stwifi.adb4
-rw-r--r--gcc/ada/a-stzbou.ads4
-rw-r--r--gcc/ada/a-stzfix.adb3
-rw-r--r--gcc/ada/a-stzsup.adb3
-rw-r--r--gcc/ada/a-sytaco.ads5
-rw-r--r--gcc/ada/a-tags.adb94
-rw-r--r--gcc/ada/a-tasatt.adb14
-rw-r--r--gcc/ada/a-tasatt.ads7
-rw-r--r--gcc/ada/a-taside.ads3
-rw-r--r--gcc/ada/a-teioed.adb76
-rw-r--r--gcc/ada/a-textio.adb36
-rw-r--r--gcc/ada/a-tigeli.adb30
-rw-r--r--gcc/ada/a-unccon.ads1
-rw-r--r--gcc/ada/a-wtedit.adb79
-rw-r--r--gcc/ada/a-wtenau.adb4
-rw-r--r--gcc/ada/a-ztedit.adb83
-rw-r--r--gcc/ada/aa_util.adb458
-rw-r--r--gcc/ada/aa_util.ads145
-rw-r--r--gcc/ada/ada.ads1
-rw-r--r--gcc/ada/adabkend.adb46
-rw-r--r--gcc/ada/adaint.c143
-rw-r--r--gcc/ada/adaint.h32
-rw-r--r--gcc/ada/affinity.c12
-rw-r--r--gcc/ada/ali-util.ads4
-rw-r--r--gcc/ada/ali.adb36
-rw-r--r--gcc/ada/ali.ads27
-rw-r--r--gcc/ada/alloc.ads12
-rw-r--r--gcc/ada/aspects.adb4
-rw-r--r--gcc/ada/aspects.ads16
-rw-r--r--gcc/ada/atree.adb699
-rw-r--r--gcc/ada/atree.ads47
-rw-r--r--gcc/ada/atree.h3
-rw-r--r--gcc/ada/bcheck.adb4
-rw-r--r--gcc/ada/binde.adb2445
-rw-r--r--gcc/ada/binde.ads44
-rw-r--r--gcc/ada/binderr.ads6
-rw-r--r--gcc/ada/bindgen.adb412
-rw-r--r--gcc/ada/bindgen.ads8
-rw-r--r--gcc/ada/bindusg.adb6
-rw-r--r--gcc/ada/casing.adb36
-rw-r--r--gcc/ada/casing.ads23
-rw-r--r--gcc/ada/checks.adb459
-rw-r--r--gcc/ada/checks.ads15
-rw-r--r--gcc/ada/clean.adb61
-rw-r--r--gcc/ada/comperr.adb9
-rw-r--r--gcc/ada/contracts.adb969
-rw-r--r--gcc/ada/contracts.ads5
-rw-r--r--gcc/ada/cstreams.c20
-rw-r--r--gcc/ada/ctrl_c.c4
-rw-r--r--gcc/ada/debug.adb91
-rw-r--r--gcc/ada/doc/Makefile22
-rw-r--r--gcc/ada/doc/gnat_rm.rst12
-rw-r--r--gcc/ada/doc/gnat_rm/about_this_guide.rst6
-rw-r--r--gcc/ada/doc/gnat_rm/compatibility_and_porting_guide.rst25
-rw-r--r--gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst126
-rw-r--r--gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst31
-rw-r--r--gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst220
-rw-r--r--gcc/ada/doc/gnat_rm/implementation_of_ada_2012_features.rst54
-rw-r--r--gcc/ada/doc/gnat_rm/interfacing_to_other_languages.rst17
-rw-r--r--gcc/ada/doc/gnat_rm/obsolescent_features.rst2
-rw-r--r--gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst68
-rw-r--r--gcc/ada/doc/gnat_rm/standard_and_implementation_defined_restrictions.rst59
-rw-r--r--gcc/ada/doc/gnat_rm/standard_library_routines.rst3
-rw-r--r--gcc/ada/doc/gnat_rm/the_gnat_library.rst30
-rw-r--r--gcc/ada/doc/gnat_rm/the_implementation_of_standard_i_o.rst111
-rw-r--r--gcc/ada/doc/gnat_ugn.rst2
-rw-r--r--gcc/ada/doc/gnat_ugn/about_this_guide.rst17
-rw-r--r--gcc/ada/doc/gnat_ugn/building_executable_programs_with_gnat.rst138
-rw-r--r--gcc/ada/doc/gnat_ugn/elaboration_order_handling_in_gnat.rst97
-rw-r--r--gcc/ada/doc/gnat_ugn/example_of_binder_output.rst5
-rw-r--r--gcc/ada/doc/gnat_ugn/getting_started_with_gnat.rst3
-rw-r--r--gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst23
-rw-r--r--gcc/ada/doc/gnat_ugn/gnat_project_manager.rst4887
-rw-r--r--gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst337
-rw-r--r--gcc/ada/doc/gnat_ugn/inline_assembler.rst48
-rw-r--r--gcc/ada/doc/gnat_ugn/platform_specific_information.rst85
-rw-r--r--gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst272
-rw-r--r--gcc/ada/doc/gnat_ugn/tools_supporting_project_files.rst745
-rw-r--r--gcc/ada/einfo.adb2114
-rw-r--r--gcc/ada/einfo.ads683
-rw-r--r--gcc/ada/env.c2
-rw-r--r--gcc/ada/errout.adb104
-rw-r--r--gcc/ada/errout.ads36
-rw-r--r--gcc/ada/erroutc.adb10
-rw-r--r--gcc/ada/errutil.adb22
-rw-r--r--gcc/ada/eval_fat.adb10
-rw-r--r--gcc/ada/exp_aggr.adb2881
-rw-r--r--gcc/ada/exp_aggr.ads4
-rw-r--r--gcc/ada/exp_attr.adb1752
-rw-r--r--gcc/ada/exp_ch11.adb80
-rw-r--r--gcc/ada/exp_ch13.adb49
-rw-r--r--gcc/ada/exp_ch2.adb2
-rw-r--r--gcc/ada/exp_ch3.adb1342
-rw-r--r--gcc/ada/exp_ch3.ads4
-rw-r--r--gcc/ada/exp_ch4.adb1439
-rw-r--r--gcc/ada/exp_ch5.adb597
-rw-r--r--gcc/ada/exp_ch6.adb740
-rw-r--r--gcc/ada/exp_ch6.ads14
-rw-r--r--gcc/ada/exp_ch7.adb3383
-rw-r--r--gcc/ada/exp_ch7.ads69
-rw-r--r--gcc/ada/exp_ch8.adb57
-rw-r--r--gcc/ada/exp_ch9.adb1162
-rw-r--r--gcc/ada/exp_ch9.ads14
-rw-r--r--gcc/ada/exp_code.adb4
-rw-r--r--gcc/ada/exp_dbug.adb61
-rw-r--r--gcc/ada/exp_dbug.ads17
-rw-r--r--gcc/ada/exp_disp.adb130
-rw-r--r--gcc/ada/exp_dist.adb18
-rw-r--r--gcc/ada/exp_fixd.adb36
-rw-r--r--gcc/ada/exp_imgv.adb10
-rw-r--r--gcc/ada/exp_intr.adb368
-rw-r--r--gcc/ada/exp_intr.ads20
-rw-r--r--gcc/ada/exp_pakd.adb130
-rw-r--r--gcc/ada/exp_prag.adb161
-rw-r--r--gcc/ada/exp_sel.ads4
-rw-r--r--gcc/ada/exp_spark.adb190
-rw-r--r--gcc/ada/exp_spark.ads6
-rw-r--r--gcc/ada/exp_strm.adb19
-rw-r--r--gcc/ada/exp_strm.ads21
-rw-r--r--gcc/ada/exp_unst.adb182
-rw-r--r--gcc/ada/exp_unst.ads21
-rw-r--r--gcc/ada/exp_util.adb2992
-rw-r--r--gcc/ada/exp_util.ads129
-rw-r--r--gcc/ada/expander.adb43
-rw-r--r--gcc/ada/expect.c8
-rw-r--r--gcc/ada/fe.h4
-rw-r--r--gcc/ada/fname.adb14
-rw-r--r--gcc/ada/freeze.adb1384
-rw-r--r--gcc/ada/freeze.ads32
-rw-r--r--gcc/ada/frontend.adb21
-rw-r--r--gcc/ada/g-arrspl.adb4
-rw-r--r--gcc/ada/g-awk.adb4
-rw-r--r--gcc/ada/g-byorma.ads4
-rw-r--r--gcc/ada/g-calend.ads10
-rw-r--r--gcc/ada/g-catiio.adb3
-rw-r--r--gcc/ada/g-comlin.adb30
-rw-r--r--gcc/ada/g-comlin.ads4
-rw-r--r--gcc/ada/g-debpoo.adb97
-rw-r--r--gcc/ada/g-diopit.adb8
-rw-r--r--gcc/ada/g-dynhta.adb8
-rw-r--r--gcc/ada/g-dyntab.adb372
-rw-r--r--gcc/ada/g-dyntab.ads172
-rw-r--r--gcc/ada/g-expect.adb29
-rw-r--r--gcc/ada/g-forstr.adb23
-rw-r--r--gcc/ada/g-forstr.ads25
-rw-r--r--gcc/ada/g-locfil.ads4
-rw-r--r--gcc/ada/g-mbdira.adb4
-rw-r--r--gcc/ada/g-memdum.adb3
-rw-r--r--gcc/ada/g-pehage.adb8
-rw-r--r--gcc/ada/g-sechas.adb31
-rw-r--r--gcc/ada/g-sechas.ads22
-rw-r--r--gcc/ada/g-sercom-linux.adb8
-rw-r--r--gcc/ada/g-sercom-mingw.adb18
-rw-r--r--gcc/ada/g-socket.adb232
-rw-r--r--gcc/ada/g-socket.ads41
-rw-r--r--gcc/ada/g-socthi-mingw.adb95
-rw-r--r--gcc/ada/g-sothco.ads5
-rw-r--r--gcc/ada/g-souinf.ads6
-rw-r--r--gcc/ada/g-spipat.adb378
-rw-r--r--gcc/ada/g-spitbo.adb6
-rw-r--r--gcc/ada/g-spitbo.ads6
-rw-r--r--gcc/ada/g-traceb.ads10
-rw-r--r--gcc/ada/gcc-interface/Make-lang.in20
-rw-r--r--gcc/ada/gcc-interface/Makefile.in746
-rw-r--r--gcc/ada/gcc-interface/ada-tree.h14
-rw-r--r--gcc/ada/gcc-interface/decl.c2280
-rw-r--r--gcc/ada/gcc-interface/gigi.h98
-rw-r--r--gcc/ada/gcc-interface/lang.opt6
-rw-r--r--gcc/ada/gcc-interface/misc.c96
-rw-r--r--gcc/ada/gcc-interface/trans.c777
-rw-r--r--gcc/ada/gcc-interface/utils.c586
-rw-r--r--gcc/ada/gcc-interface/utils2.c107
-rw-r--r--gcc/ada/get_scos.adb3
-rw-r--r--gcc/ada/get_spark_xrefs.adb13
-rw-r--r--gcc/ada/ghost.adb1273
-rw-r--r--gcc/ada/ghost.ads226
-rw-r--r--gcc/ada/gnat1drv.adb365
-rw-r--r--gcc/ada/gnat_rm.texi2030
-rw-r--r--gcc/ada/gnat_ugn.texi7937
-rw-r--r--gcc/ada/gnatbind.adb262
-rw-r--r--gcc/ada/gnatcmd.adb792
-rw-r--r--gcc/ada/gnatdll.adb12
-rw-r--r--gcc/ada/gnatlink.adb52
-rw-r--r--gcc/ada/gnatname.adb4
-rw-r--r--gcc/ada/gnatvsn.ads6
-rw-r--r--gcc/ada/gprep.adb13
-rw-r--r--gcc/ada/gsocket.h5
-rw-r--r--gcc/ada/i-cobol.adb3
-rw-r--r--gcc/ada/i-cobol.ads6
-rw-r--r--gcc/ada/i-vxinco.adb (renamed from gcc/ada/a-intsig.adb)26
-rw-r--r--gcc/ada/i-vxinco.ads (renamed from gcc/ada/a-intsig.ads)34
-rw-r--r--gcc/ada/impunit.adb3
-rw-r--r--gcc/ada/init-vxsim.c62
-rw-r--r--gcc/ada/init.c191
-rw-r--r--gcc/ada/inline.adb618
-rw-r--r--gcc/ada/inline.ads15
-rw-r--r--gcc/ada/interfac.ads3
-rw-r--r--gcc/ada/krunch.adb21
-rw-r--r--gcc/ada/layout.adb235
-rw-r--r--gcc/ada/lib-load.adb8
-rw-r--r--gcc/ada/lib-writ.adb86
-rw-r--r--gcc/ada/lib-writ.ads42
-rw-r--r--gcc/ada/lib-xref-spark_specific.adb1154
-rw-r--r--gcc/ada/lib-xref.adb110
-rw-r--r--gcc/ada/lib-xref.ads36
-rw-r--r--gcc/ada/lib.adb107
-rw-r--r--gcc/ada/lib.ads64
-rw-r--r--gcc/ada/live.adb48
-rw-r--r--gcc/ada/live.ads12
-rw-r--r--gcc/ada/make.adb214
-rw-r--r--gcc/ada/makeutl.adb37
-rw-r--r--gcc/ada/mingw32.h13
-rw-r--r--gcc/ada/mkdir.c16
-rw-r--r--gcc/ada/mlib-prj.adb6
-rw-r--r--gcc/ada/namet-sp.ads4
-rw-r--r--gcc/ada/namet.adb1047
-rw-r--r--gcc/ada/namet.ads412
-rw-r--r--gcc/ada/namet.h50
-rw-r--r--gcc/ada/nlists.adb79
-rw-r--r--gcc/ada/nlists.ads43
-rw-r--r--gcc/ada/opt.ads43
-rw-r--r--gcc/ada/osint-b.adb4
-rw-r--r--gcc/ada/osint-c.adb32
-rw-r--r--gcc/ada/osint-c.ads12
-rw-r--r--gcc/ada/osint-l.adb4
-rw-r--r--gcc/ada/osint.adb38
-rw-r--r--gcc/ada/osint.ads2
-rw-r--r--gcc/ada/par-ch10.adb10
-rw-r--r--gcc/ada/par-ch11.adb6
-rw-r--r--gcc/ada/par-ch12.adb11
-rw-r--r--gcc/ada/par-ch2.adb139
-rw-r--r--gcc/ada/par-ch3.adb53
-rw-r--r--gcc/ada/par-ch4.adb200
-rw-r--r--gcc/ada/par-ch5.adb19
-rw-r--r--gcc/ada/par-ch6.adb5
-rw-r--r--gcc/ada/par-ch9.adb63
-rw-r--r--gcc/ada/par-endh.adb3
-rw-r--r--gcc/ada/par-prag.adb473
-rw-r--r--gcc/ada/par.adb20
-rw-r--r--gcc/ada/par_sco.adb994
-rw-r--r--gcc/ada/pprint.adb119
-rw-r--r--gcc/ada/prep.adb31
-rw-r--r--gcc/ada/prepcomp.adb2
-rw-r--r--gcc/ada/prj-dect.adb73
-rw-r--r--gcc/ada/prj-env.adb7
-rw-r--r--gcc/ada/prj-ext.adb4
-rw-r--r--gcc/ada/prj-nmsc.adb53
-rw-r--r--gcc/ada/prj-pp.adb13
-rw-r--r--gcc/ada/prj-proc.adb31
-rw-r--r--gcc/ada/prj-strt.adb6
-rw-r--r--gcc/ada/prj-tree.adb6
-rw-r--r--gcc/ada/prj-tree.ads2
-rw-r--r--gcc/ada/prj.adb21
-rw-r--r--gcc/ada/prj.ads2
-rw-r--r--gcc/ada/put_spark_xrefs.adb207
-rw-r--r--gcc/ada/put_spark_xrefs.ads5
-rw-r--r--gcc/ada/raise-gcc.c26
-rw-r--r--gcc/ada/raise.c2
-rw-r--r--gcc/ada/repinfo.adb71
-rw-r--r--gcc/ada/restrict.adb324
-rw-r--r--gcc/ada/restrict.ads23
-rw-r--r--gcc/ada/rtinit.c26
-rw-r--r--gcc/ada/rtsfind.adb29
-rw-r--r--gcc/ada/rtsfind.ads22
-rw-r--r--gcc/ada/s-bignum.adb10
-rw-r--r--gcc/ada/s-boustr.adb104
-rw-r--r--gcc/ada/s-boustr.ads62
-rw-r--r--gcc/ada/s-exctra.adb4
-rw-r--r--gcc/ada/s-exnllf.adb89
-rw-r--r--gcc/ada/s-fatgen.adb10
-rw-r--r--gcc/ada/s-fileio.adb52
-rw-r--r--gcc/ada/s-gearop.adb14
-rw-r--r--gcc/ada/s-gearop.ads4
-rw-r--r--gcc/ada/s-htable.adb4
-rw-r--r--gcc/ada/s-imgint.adb57
-rw-r--r--gcc/ada/s-imglli.adb62
-rw-r--r--gcc/ada/s-imgllu.adb34
-rw-r--r--gcc/ada/s-imgrea.adb2
-rw-r--r--gcc/ada/s-imguns.adb34
-rw-r--r--gcc/ada/s-interr-vxworks.adb (renamed from gcc/ada/s-interr-hwint.adb)23
-rw-r--r--gcc/ada/s-interr.adb10
-rw-r--r--gcc/ada/s-intman-android.adb20
-rw-r--r--gcc/ada/s-intman-posix.adb19
-rw-r--r--gcc/ada/s-intman-solaris.adb21
-rw-r--r--gcc/ada/s-io.adb14
-rw-r--r--gcc/ada/s-linux-mips.ads (renamed from gcc/ada/s-linux-mipsel.ads)64
-rw-r--r--gcc/ada/s-maccod.ads3
-rw-r--r--gcc/ada/s-memory.adb67
-rw-r--r--gcc/ada/s-memory.ads8
-rw-r--r--gcc/ada/s-mmap.adb576
-rw-r--r--gcc/ada/s-mmap.ads281
-rw-r--r--gcc/ada/s-mmauni-long.ads69
-rw-r--r--gcc/ada/s-mmosin-mingw.adb345
-rw-r--r--gcc/ada/s-mmosin-mingw.ads235
-rw-r--r--gcc/ada/s-mmosin-unix.adb229
-rw-r--r--gcc/ada/s-mmosin-unix.ads105
-rw-r--r--gcc/ada/s-os_lib.adb105
-rw-r--r--gcc/ada/s-os_lib.ads38
-rw-r--r--gcc/ada/s-oscons-tmplt.c7
-rw-r--r--gcc/ada/s-osinte-darwin.adb13
-rw-r--r--gcc/ada/s-osinte-darwin.ads1
-rw-r--r--gcc/ada/s-osinte-linux.ads8
-rw-r--r--gcc/ada/s-osinte-vxworks.ads6
-rw-r--r--gcc/ada/s-osprim-mingw.adb9
-rw-r--r--gcc/ada/s-parame-ae653.ads4
-rw-r--r--gcc/ada/s-poosiz.adb6
-rw-r--r--gcc/ada/s-rannum.adb2
-rw-r--r--gcc/ada/s-regexp.adb12
-rw-r--r--gcc/ada/s-regpat.adb31
-rw-r--r--gcc/ada/s-rident.ads52
-rw-r--r--gcc/ada/s-secsta.adb51
-rw-r--r--gcc/ada/s-secsta.ads6
-rw-r--r--gcc/ada/s-soflin.adb4
-rw-r--r--gcc/ada/s-stposu.adb134
-rw-r--r--gcc/ada/s-stratt-xdr.adb7
-rw-r--r--gcc/ada/s-strhas.adb7
-rw-r--r--gcc/ada/s-taprob.ads7
-rw-r--r--gcc/ada/s-taprop-linux.adb53
-rw-r--r--gcc/ada/s-taprop-mingw.adb25
-rw-r--r--gcc/ada/s-tarest.adb150
-rw-r--r--gcc/ada/s-tarest.ads48
-rw-r--r--gcc/ada/s-tasini.adb37
-rw-r--r--gcc/ada/s-taskin.adb66
-rw-r--r--gcc/ada/s-taskin.ads53
-rw-r--r--gcc/ada/s-tassta.adb85
-rw-r--r--gcc/ada/s-tassta.ads32
-rw-r--r--gcc/ada/s-tfsetr-default.adb13
-rw-r--r--gcc/ada/s-tfsetr-vxworks.adb3
-rw-r--r--gcc/ada/s-tpoben.adb42
-rw-r--r--gcc/ada/s-tpoben.ads46
-rw-r--r--gcc/ada/s-tpobop.adb74
-rw-r--r--gcc/ada/s-tporft.adb4
-rw-r--r--gcc/ada/s-tposen.adb10
-rw-r--r--gcc/ada/s-tposen.ads13
-rw-r--r--gcc/ada/s-tratas-default.adb6
-rw-r--r--gcc/ada/s-unstyp.ads6
-rw-r--r--gcc/ada/s-wchcnv.adb5
-rw-r--r--gcc/ada/scans.adb27
-rw-r--r--gcc/ada/scans.ads32
-rw-r--r--gcc/ada/scil_ll.adb152
-rw-r--r--gcc/ada/scil_ll.ads18
-rw-r--r--gcc/ada/scn.adb10
-rw-r--r--gcc/ada/scn.ads6
-rw-r--r--gcc/ada/scng.adb350
-rw-r--r--gcc/ada/scng.ads6
-rw-r--r--gcc/ada/scos.ads12
-rw-r--r--gcc/ada/sem.adb321
-rw-r--r--gcc/ada/sem.ads21
-rw-r--r--gcc/ada/sem_aggr.adb1087
-rw-r--r--gcc/ada/sem_aggr.ads3
-rw-r--r--gcc/ada/sem_attr.adb1545
-rw-r--r--gcc/ada/sem_attr.ads52
-rw-r--r--gcc/ada/sem_aux.adb137
-rw-r--r--gcc/ada/sem_aux.ads6
-rw-r--r--gcc/ada/sem_case.adb276
-rw-r--r--gcc/ada/sem_case.ads7
-rw-r--r--gcc/ada/sem_cat.adb94
-rw-r--r--gcc/ada/sem_ch10.adb253
-rw-r--r--gcc/ada/sem_ch11.adb38
-rw-r--r--gcc/ada/sem_ch12.adb980
-rw-r--r--gcc/ada/sem_ch12.ads48
-rw-r--r--gcc/ada/sem_ch13.adb3533
-rw-r--r--gcc/ada/sem_ch13.ads42
-rw-r--r--gcc/ada/sem_ch3.adb1752
-rw-r--r--gcc/ada/sem_ch3.ads4
-rw-r--r--gcc/ada/sem_ch4.adb932
-rw-r--r--gcc/ada/sem_ch4.ads14
-rw-r--r--gcc/ada/sem_ch5.adb295
-rw-r--r--gcc/ada/sem_ch5.ads3
-rw-r--r--gcc/ada/sem_ch6.adb2402
-rw-r--r--gcc/ada/sem_ch6.ads11
-rw-r--r--gcc/ada/sem_ch7.adb537
-rw-r--r--gcc/ada/sem_ch7.ads19
-rw-r--r--gcc/ada/sem_ch8.adb604
-rw-r--r--gcc/ada/sem_ch9.adb184
-rw-r--r--gcc/ada/sem_dim.adb138
-rw-r--r--gcc/ada/sem_dim.ads12
-rw-r--r--gcc/ada/sem_disp.adb238
-rw-r--r--gcc/ada/sem_dist.adb18
-rw-r--r--gcc/ada/sem_elab.adb338
-rw-r--r--gcc/ada/sem_elim.adb9
-rw-r--r--gcc/ada/sem_eval.adb312
-rw-r--r--gcc/ada/sem_eval.ads220
-rw-r--r--gcc/ada/sem_intr.adb29
-rw-r--r--gcc/ada/sem_mech.adb24
-rw-r--r--gcc/ada/sem_prag.adb4277
-rw-r--r--gcc/ada/sem_prag.ads37
-rw-r--r--gcc/ada/sem_res.adb977
-rw-r--r--gcc/ada/sem_res.ads94
-rw-r--r--gcc/ada/sem_type.adb159
-rw-r--r--gcc/ada/sem_util.adb4071
-rw-r--r--gcc/ada/sem_util.ads313
-rw-r--r--gcc/ada/sem_warn.adb122
-rw-r--r--gcc/ada/sem_warn.ads4
-rwxr-xr-xgcc/ada/set_targ.adb26
-rw-r--r--gcc/ada/sigtramp-vxworks-target.inc18
-rw-r--r--gcc/ada/sigtramp-vxworks-vxsim.c141
-rw-r--r--gcc/ada/sigtramp-vxworks.c76
-rw-r--r--gcc/ada/sigtramp.h13
-rw-r--r--gcc/ada/sinfo.adb198
-rw-r--r--gcc/ada/sinfo.ads365
-rw-r--r--gcc/ada/sinput-c.adb3
-rw-r--r--gcc/ada/sinput-l.adb80
-rw-r--r--gcc/ada/sinput-l.ads45
-rw-r--r--gcc/ada/sinput.adb54
-rw-r--r--gcc/ada/sinput.ads52
-rw-r--r--gcc/ada/snames.adb-tmpl10
-rw-r--r--gcc/ada/snames.ads-tmpl37
-rw-r--r--gcc/ada/socket.c2
-rw-r--r--gcc/ada/spark_xrefs.adb7
-rw-r--r--gcc/ada/spark_xrefs.ads91
-rw-r--r--gcc/ada/sprint.adb58
-rw-r--r--gcc/ada/stringt.adb37
-rw-r--r--gcc/ada/stringt.ads19
-rw-r--r--gcc/ada/styleg.adb8
-rw-r--r--gcc/ada/styleg.ads6
-rw-r--r--gcc/ada/stylesw.adb8
-rw-r--r--gcc/ada/stylesw.ads6
-rw-r--r--gcc/ada/switch-b.adb19
-rw-r--r--gcc/ada/switch-c.adb42
-rw-r--r--gcc/ada/switch-m.adb52
-rw-r--r--gcc/ada/sysdep.c39
-rw-r--r--gcc/ada/system-aix.ads9
-rw-r--r--gcc/ada/system-aix64.ads157
-rw-r--r--gcc/ada/system-darwin-arm.ads (renamed from gcc/ada/system-darwin-x86_64.ads)8
-rw-r--r--gcc/ada/system-darwin-ppc.ads7
-rw-r--r--gcc/ada/system-darwin-ppc64.ads153
-rw-r--r--gcc/ada/system-darwin-x86.ads6
-rw-r--r--gcc/ada/system-djgpp.ads (renamed from gcc/ada/system-freebsd-x86.ads)8
-rw-r--r--gcc/ada/system-freebsd.ads (renamed from gcc/ada/system-freebsd-x86_64.ads)11
-rw-r--r--gcc/ada/system-hpux-ia64.ads4
-rw-r--r--gcc/ada/system-hpux.ads4
-rw-r--r--gcc/ada/system-linux-aarch64-ilp32.ads (renamed from gcc/ada/system-linux-armel.ads)10
-rw-r--r--gcc/ada/system-linux-alpha.ads5
-rw-r--r--gcc/ada/system-linux-arm.ads (renamed from gcc/ada/system-linux-x86_64.ads)7
-rw-r--r--gcc/ada/system-linux-armeb.ads156
-rw-r--r--gcc/ada/system-linux-hppa.ads4
-rw-r--r--gcc/ada/system-linux-ia64.ads4
-rw-r--r--gcc/ada/system-linux-m68k.ads (renamed from gcc/ada/system-linux-ppc64.ads)17
-rw-r--r--gcc/ada/system-linux-mips.ads14
-rw-r--r--gcc/ada/system-linux-mips64el.ads148
-rw-r--r--gcc/ada/system-linux-mipsel.ads148
-rw-r--r--gcc/ada/system-linux-ppc.ads9
-rw-r--r--gcc/ada/system-linux-s390.ads8
-rw-r--r--gcc/ada/system-linux-s390x.ads147
-rw-r--r--gcc/ada/system-linux-sh4.ads4
-rw-r--r--gcc/ada/system-linux-sparc.ads8
-rw-r--r--gcc/ada/system-linux-sparcv9.ads148
-rw-r--r--gcc/ada/system-linux-x86.ads6
-rw-r--r--gcc/ada/system-mingw-x86_64.ads200
-rw-r--r--gcc/ada/system-mingw.ads6
-rw-r--r--gcc/ada/system-rtems.ads5
-rw-r--r--gcc/ada/system-solaris-sparc.ads7
-rw-r--r--gcc/ada/system-solaris-sparcv9.ads148
-rw-r--r--gcc/ada/system-solaris-x86.ads6
-rw-r--r--gcc/ada/system-solaris-x86_64.ads148
-rw-r--r--gcc/ada/system-vxworks-arm.ads6
-rw-r--r--gcc/ada/system-vxworks-m68k.ads2
-rw-r--r--gcc/ada/system-vxworks-mips.ads2
-rw-r--r--gcc/ada/system-vxworks-ppc.ads4
-rw-r--r--gcc/ada/system-vxworks-sparcv9.ads2
-rw-r--r--gcc/ada/system-vxworks-x86.ads2
-rw-r--r--gcc/ada/table.adb38
-rw-r--r--gcc/ada/table.ads27
-rw-r--r--gcc/ada/targparm.ads4
-rw-r--r--gcc/ada/terminals.c26
-rw-r--r--gcc/ada/tracebak.c32
-rw-r--r--gcc/ada/treepr.adb158
-rw-r--r--gcc/ada/types.ads4
-rw-r--r--gcc/ada/types.h5
-rw-r--r--gcc/ada/uintp.adb9
-rw-r--r--gcc/ada/uintp.ads12
-rw-r--r--gcc/ada/uintp.h6
-rw-r--r--gcc/ada/uname.adb120
-rw-r--r--gcc/ada/usage.adb52
-rw-r--r--gcc/ada/validsw.adb4
-rw-r--r--gcc/ada/vxworks-crtbe-link.spec13
-rw-r--r--gcc/ada/widechar.adb11
-rw-r--r--gcc/ada/xoscons.adb9
-rw-r--r--gcc/ada/xr_tabls.adb12
-rw-r--r--gcc/ada/xref_lib.adb51
-rw-r--r--gcc/ada/xref_lib.ads4
532 files changed, 63052 insertions, 46085 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 46810bc77b..c8ff9626a3 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,417 +1,2818 @@
-2016-08-22 Release Manager
+2017-05-02 Release Manager
- * GCC 6.2.0 released.
+ * GCC 7.1.0 released.
-2016-06-13 Eric Botcazou <ebotcazou@adacore.com>
+2017-04-04 Andreas Krebbel <krebbel@linux.vnet.ibm.com>
- * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Variable>: Deal with
- PLUS_EXPR in the expression of a renaming.
+ * system-linux-s390.ads: Use Long_Integer'Size to define
+ Memory_Size.
-2016-06-11 Eric Botcazou <ebotcazou@adacore.com>
+2017-04-04 Eric Botcazou <ebotcazou@adacore.com>
- * gcc-interface/trans.c (Case_Statement_to_gnu): Deal with characters.
+ * sem_ch3.adb (Build_Derived_Record_Type): Fix long line.
-2016-06-11 Pierre-Marie de Rodat <derodat@adacore.com>
+2017-04-03 Jonathan Wakely <jwakely@redhat.com>
- * gcc-interface/decl.c (gnat_to_gnu_entity): Do not clobber
- gnat_entity_name with temporary names for XUP and XUT types.
+ * doc/gnat_ugn/gnat_and_program_execution.rst: Fix typo.
+ * g-socket.adb (To_Host_Entry): Fix typo in comment.
+ * gnat_ugn.texi: Fix typo.
+ * raise.c (_gnat_builtin_longjmp): Fix capitalization in comment.
+ * s-stposu.adb (Allocate_Any_Controlled): Fix typo in comment.
+ * sem_ch3.adb (Build_Derived_Record_Type): Likewise.
+ * sem_util.adb (Mark_Coextensions): Likewise.
+ * sem_util.ads (Available_Full_View_Of_Component): Likewise.
-2016-06-06 Eric Botcazou <ebotcazou@adacore.com>
+2017-03-28 Andreas Schwab <schwab@suse.de>
- * gcc-interface/utils.c (gnat_internal_attribute_table): Add support
- for noinline and noclone attributes.
- (handle_noinline_attribute): New handler.
- (handle_noclone_attribute): Likewise.
+ PR ada/80117
+ * system-linux-aarch64-ilp32.ads: New file.
+ * gcc-interface/Makefile.in (LIBGNAT_TARGET_PAIRS_COMMON): Rename
+ from LIBGNAT_TARGET_PAIRS.
+ (LIBGNAT_TARGET_PAIRS_32, LIBGNAT_TARGET_PAIRS_64): Define.
+ (LIBGNAT_TARGET_PAIRS): Use LIBGNAT_TARGET_PAIRS_COMMON, and
+ LIBGNAT_TARGET_PAIRS_64 or LIBGNAT_TARGET_PAIRS_32 for -mabi=lp64
+ or -mabi=ilp32, resp.
-2016-06-06 Eric Botcazou <ebotcazou@adacore.com>
+2017-03-14 James Cowgill <James.Cowgill@imgtec.com>
- * gcc-interface/utils2.c (build_call_alloc_dealloc): Do not substitute
- placeholder expressions here but...
- * gcc-interface/trans.c (gnat_to_gnu) <N_Free_Statement>: ...here.
- Make an exception to the protection of a CALL_EXPR result with an
- unconstrained type only in the same cases as Call_to_gnu.
+ * s-osinte-linux.ads (struct_sigaction): Use correct type for sa_flags.
-2016-06-01 Simon Wright <simon@pushface.org>
+2017-03-08 Thanassis Tsiodras <ttsiodras@gmail.com>
- PR ada/71358
- * g-comlin.adb (Display_Section_Help): Do not dereference
- Config.Switches if it's null.
- (Getopt): Likewise.
+ PR ada/79903
+ * socket.c (__gnat_gethostbyaddr): Add missing test for __rtems__.
-2016-05-31 Eric Botcazou <ebotcazou@adacore.com>
+2017-03-08 Eric Botcazou <ebotcazou@adacore.com>
- * s-osinte-kfreebsd-gnu.ads (clock_getres): Define.
- (Get_Page_Size): Remove duplicate and return int.
+ PR ada/79945
+ * system-linux-ppc.ads (Default_Bit_Order): Use Standard's setting.
-2016-05-31 Jan Sommer <soja-lists@aries.uberspace.de>
+ * system-linux-arm.ads (Default_Bit_Order): Likewise.
+ * system-linux-mips.ads (Default_Bit_Order): Likewise.
+ * system-linux-armeb.ads: Delete.
+ * system-linux-mipsel.ads: Likewise.
+ * gcc-interface/Makefile.in (MIPS/Linux): Adjust.
+ (ARM/Linux): Likewise.
- PR ada/71317
- * s-osinte-rtems.ads (clock_getres): Define.
- (Get_Page_Size): Remove duplicate and return int.
+2017-02-24 Jakub Jelinek <jakub@redhat.com>
-2016-05-06 Eric Botcazou <ebotcazou@adacore.com>
+ PR c/79677
+ * gcc-interface/misc.c (gnat_handle_option): Pass true to
+ handle_generated_option GENERATED_P.
- PR ada/70969
- * system-darwin-ppc64.ads: Add pragma No_Elaboration_Code_All.
- * system-linux-armeb.ads: Likewise.
- * system-linux-mips64el.ads: Likewise.
- * system-linux-mips.ads: Likewise.
- * system-linux-mipsel.ads: Likewise.
- * system-linux-ppc64.ads: Likewise.
- * system-linux-sparcv9.ads: Likewise.
- * system-rtems.ads: Likewise.
+2017-02-24 Eric Botcazou <ebotcazou@adacore.com>
-2016-05-04 Samuel Thibault <samuel.thibault@ens-lyon.org>
+ * gcc-interface/decl.c (gnat_to_gnu_field): Do not remove the wrapper
+ around a justified modular type if it doesn't have the same scalar
+ storage order as the enclosing record type.
- * s-osinte-gnu.ads (Get_Page_Size): Return int and use getpagesize
- instead of __getpagesize.
+2017-02-24 Eric Botcazou <ebotcazou@adacore.com>
-2016-04-28 Eric Botcazou <ebotcazou@adacore.com>
+ * gcc-interface/trans.c (gnat_to_gnu): Do not apply special handling
+ of boolean rvalues to function calls.
- PR ada/70900
- Backport from mainline
- 2016-04-18 Ed Schonberg <schonberg@adacore.com>
+2017-02-24 Eric Botcazou <ebotcazou@adacore.com>
- * sem_ch6.adb (Process_Formals): Do not set a delay freeze on
- a subprogram that returns a class-wide type, if the subprogram
- is a compilation unit, because otherwise gigi will treat the
- subprogram as external, leading to link errors.
+ * gcc-interface/utils.c (fold_bit_position): New function.
+ (rest_of_record_type_compilation): Call it instead of bit_position to
+ compute the field position and remove the call to remove_conversions.
+ (compute_related_constant): Factor out the multiplication in both
+ operands, if any, and streamline the final test.
-2016-05-02 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
+2017-02-24 Eric Botcazou <ebotcazou@adacore.com>
- * gcc-interface/Makefile.in (install-gcc-specs): Use foreach.
- Honor DESTDIR.
+ * gcc-interface/trans.c (return_value_ok_for_nrv_p): Add sanity check.
-2016-04-28 Eric Botcazou <ebotcazou@adacore.com>
+2017-02-24 Eric Botcazou <ebotcazou@adacore.com>
- PR ada/70786
- * a-textio.adb (Get_Immediate): Add missing 'not' in expression.
+ * gcc-interface/decl.c: Include demangle.h.
+ (is_cplusplus_method): Return again true for a primitive operation
+ only if it is dispatching. For a subprogram with an interface name,
+ call the demangler to get the number of C++ parameters and compare it
+ with the number of Ada parameters.
-2016-04-28 Eric Botcazou <ebotcazou@adacore.com>
+2017-02-24 Eric Botcazou <ebotcazou@adacore.com>
- Backport from mainline
- 2016-04-27 Eric Botcazou <ebotcazou@adacore.com>
+ * gcc-interface/trans.c (Handled_Sequence_Of_Statements_to_gnu): If
+ there is no end label, put the location of the At_End procedure on
+ the call to the procedure.
- * gcc-interface/misc.c (gnat_init): Do not call
- internal_reference_types.
+2017-02-24 Eric Botcazou <ebotcazou@adacore.com>
-2016-04-27 Release Manager
+ * gcc-interface/misc.c (gnat_type_max_size): Try to return a meaningful
+ value for array types with TYPE_INDEX_TYPE set on their domain type.
+ * gcc-interface/utils.c (max_size): For operations and expressions, do
+ not build a new node if the operands have not changed or are missing.
- * GCC 6.1.0 released.
+2017-02-24 Eric Botcazou <ebotcazou@adacore.com>
-2016-04-27 Svante Signell <svante.signell@gmail.com>
+ * gcc-interface/utils.c (max_size) <tcc_expression>: Flip the second
+ argument when recursing on TRUTH_NOT_EXPR.
- * gcc-interface/Makefile.in (x86 GNU/Hurd): Use s-osinte-gnu.adb.
- * s-osinte-gnu.ads: Small tweaks.
- * s-osinte-gnu.adb: New file.
+2017-02-12 John Marino <gnugcc@marino.st>
-2016-04-02 Eric Botcazou <ebotcazou@adacore.com>
+ * system-freebsd-x86.ads: Rename into...
+ * system-freebsd.ads: ...this.
+ (Default_Bit_Order): Define using Standard'Default_Bit_Order.
+ * gcc-interface/Makefile.in: Support aarch64-freebsd.
+ (x86-64/FreeBSD): Adjust to above renaming.
+ (i386/FreeBSD): Likewise.
- * gcc-interface/decl.c (components_to_record): Restrict the previous
- change to fields with variable size.
+2017-02-09 Gerald Pfeifer <gerald@pfeifer.com>
-2016-03-27 Eric Botcazou <ebotcazou@adacore.com>
+ * comperr.adb: Update FSF bug reporting URL.
- * gcc-interface/decl.c (components_to_record): Add special case for
- single field with representation clause at offset 0.
+2017-02-01 Eric Botcazou <ebotcazou@adacore.com>
+ Jakub Jelinek <jakub@redhat.com>
-2016-03-16 Svante Signell <svante.signell@gmail.com>
+ PR ada/79309
+ * adaint.c (__gnat_killprocesstree): Fix broken string handling.
- * gcc-interface/Makefile.in: Add support for x86 GNU/Hurd.
- * s-osinte-gnu.ads: New file.
+2017-01-25 Maxim Ostapenko <m.ostapenko@samsung.com>
-2016-03-13 Eric Botcazou <ebotcazou@adacore.com>
+ PR lto/79061
+ * gcc-interface/utils.c (get_global_context): Pass main_input_filename
+ to build_translation_unit_decl.
- * system-vxworks-m68k.ads (Stack_Check_Probes): Set to True.
- (Stack_Check_Limits): Set to False.
- * system-vxworks-mips.ads (Stack_Check_Probes): Set to True.
- (Stack_Check_Limits): Set to False.
- * system-vxworks-ppc.ads (Stack_Check_Probes): Set to True.
- (Stack_Check_Limits): Set to False.
- * system-vxworks-sparcv9.ads (Stack_Check_Probes): Set to True.
- (Stack_Check_Limits): Set to False.
- * system-vxworks-x86.ads (Stack_Check_Probes): Set to True.
- (Stack_Check_Limits): Set to False.
+2017-01-23 Javier Miranda <miranda@adacore.com>
-2016-03-07 Eric Botcazou <ebotcazou@adacore.com>
+ * sem_util.adb (New_Copy_Tree): Code cleanup:
+ removal of the internal map (ie. variable Actual_Map, its
+ associated local variables, and all the code handling it).
+ * sem_ch9.adb (Analyze_Task_Type_Declaration): in GNATprove mode
+ force loading of the System package when processing a task type.
+ (Analyze_Protected_Type_Declaration): in GNATprove mode force
+ loading of the System package when processing a protected type.
+ * sem_ch10.adb (Analyze_Compilation_Unit): in GNATprove mode
+ force loading of the System package when processing compilation
+ unit with a main-like subprogram.
+ * frontend.adb (Frontend): remove forced loading of the System
+ package.
- * gcc-interface/trans.c (statement_node_p): New predicate.
- (gnat_to_gnu): Invoke it to detect statement nodes. In ASIS mode, do
- not return dummy results for expressions attached to packed array
- implementation types.
+2017-01-23 Ed Schonberg <schonberg@adacore.com>
-2016-03-07 Eric Botcazou <ebotcazou@adacore.com>
+ * sem_prag.adb (Default_Initial_Condition): If the desired type
+ declaration is a derived type declaration with discriminants,
+ it is rewritten as a private type declaration.
+ * sem_ch13.adb (Replace_Type_References_Generic,
+ Visible_Component): A discriminated private type with descriminnts
+ has components that must be rewritten as selected components
+ if they appear as identifiers in an aspect expression such as
+ a Default_Initial_Condition.
+ * sem_util.adb (Defining_Entity): support N_Iterator_Specification
+ nodes.
- * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Variable>: Always mark
- the expression of a renaming manually in case #3.
+2017-01-23 Hristian Kirtchev <kirtchev@adacore.com>
-2016-03-02 Dominik Vogt <vogt@linux.vnet.ibm.com>
+ * ghost.ads, ghost.adb (Is_Ignored_Ghost_Unit): New routine.
+ * gnat1drv.adb Generate an empty object file for an ignored
+ Ghost compilation unit.
+ * inline.adb, sem_util.adb, sem_ch4.adb: Minor reformatting.
- * system-linux-s390.ads: Enable Stack_Check_Probes.
- * system-linux-s390.ads: Likewise.
+2017-01-23 Yannick Moy <moy@adacore.com>
-2016-02-29 Martin Liska <mliska@suse.cz>
+ * sem_ch4.adb (Analyze_Indexed_Component_Form):
+ Adapt to inlined prefix with string literal subtype.
+ * inline.adb (Expand_Inlined_Call): Keep unchecked
+ conversion inside inlined call when formal type is constrained.
- * gcc-interface/utils.c (set_reverse_storage_order_on_pad_type):
- Replace ENABLE_CHECKING macro with flag_checking.
+2017-01-23 Javier Miranda <miranda@adacore.com>
-2016-02-29 Eric Botcazou <ebotcazou@adacore.com>
+ * sem_util.adb (New_Copy_Tree): Code cleanup:
+ removal of global variables. All the global variables, global
+ functions and tables of this subprogram are now declared locally.
- * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Access_Type>: Retrofit
- handling of unconstrained array types as designated types into common
- processing. Also handle array types as incomplete designated types.
+2017-01-23 Gary Dismukes <dismukes@adacore.com>
-2016-02-29 Eric Botcazou <ebotcazou@adacore.com>
+ * exp_strm.ads: Minor reformatting and typo fixes.
- * gcc-interface/decl.c (gnat_to_gnu_entity) <Concurrent types>: In
- ASIS mode, fully lay out the minimal record type.
+2017-01-23 Hristian Kirtchev <kirtchev@adacore.com>
-2016-02-29 Eric Botcazou <ebotcazou@adacore.com>
+ * sem_aggr.adb, par_sco.adb, exp_util.adb, sem.adb, sem_ch4.adb,
+ exp_aggr.adb: Minor reformatting.
+ * g-diopit.adb: minor grammar/punctuation fix in comment.
+ * g-byorma.ads: minor fix of unbalanced parens in comment.
- * gcc-interface/trans.c (finalize_nrv_r): Remove obsolete code.
- (build_return_expr): Likewise.
- (Call_to_gnu): If this is a function call and there is no target,
- create a temporary for the return value for all aggregate types,
- but never create it for a return statement. Push a binding level
- around the call in more cases. Remove obsolete code.
+2017-01-23 Hristian Kirtchev <kirtchev@adacore.com>
-2016-02-29 Eric Botcazou <ebotcazou@adacore.com>
+ * par.adb: Update the documentation of component Labl.
+ * par-ch6.adb (P_Return_Statement): Set the expected label of
+ an extended return statement to Error.
- * gcc-interface/ada-tree.h (DECL_RETURN_VALUE_P): New macro.
- * gcc-interface/gigi.h (gigi): Remove useless attribute.
- (gnat_gimplify_expr): Likewise.
- (gnat_to_gnu_external): Declare.
- * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Constant>: Factor out
- code dealing with the expression of external constants into...
- Invoke gnat_to_gnu_external instead.
- <E_Variable>: Invoke gnat_to_gnu_external to translate renamed objects
- when not for a definition. Deal with COMPOUND_EXPR and variables with
- DECL_RETURN_VALUE_P set for renamings and with the case of a dangling
- 'reference to a function call in a renaming. Remove obsolete test and
- adjust associated comment.
- * gcc-interface/trans.c (Call_to_gnu): Set DECL_RETURN_VALUE_P on the
- temporaries created to hold the return value, if any.
- (gnat_to_gnu_external): ...this. New function.
- * gcc-interface/utils.c (create_var_decl): Detect a constant created
- to hold 'reference to function call.
- * gcc-interface/utils2.c (build_unary_op) <ADDR_EXPR>: Add folding
- for COMPOUND_EXPR in the DECL_RETURN_VALUE_P case.
-
-2016-02-17 Eric Botcazou <ebotcazou@adacore.com>
-
- * exp_ch4.adb (Expand_N_Indexed_Component): Activate synchronization if
- the prefix denotes an entity which Has_Atomic_Components.
- * gcc-interface/trans.c (node_is_atomic): Return true if the prefix
- denotes an entity which Has_Atomic_Components.
-
-2016-02-17 Eric Botcazou <ebotcazou@adacore.com>
-
- * gcc-interface/utils2.c (gnat_protect_expr): Make a SAVE_EXPR only
- for fat pointer or scalar types.
-
-2016-02-16 Eric Botcazou <ebotcazou@adacore.com>
-
- * gcc-interface/gigi.h (maybe_debug_type): New inline function.
- * gcc-interface/misc.c (gnat_get_array_descr_info): Use it.
- Call maybe_character_value on the array bounds. Get to the base type
- of the index type and call maybe_debug_type on it.
- * gcc-interface/utils.c (finish_character_type): Add special treatment
- for char_type_node.
-
-2016-02-16 Eric Botcazou <ebotcazou@adacore.com>
-
- * gcc-interface/misc.c (gnat_enum_underlying_base_type): New function.
- (LANG_HOOKS_ENUM_UNDERLYING_BASE_TYPE): Define to above.
-
-2016-02-12 Jakub Jelinek <jakub@redhat.com>
-
- * prj-tree.ads: Spelling fixes - behaviour -> behavior and
- neighbour -> neighbor.
- * prep.adb: Likewise.
- * prj.ads: Likewise.
- * prepcomp.adb: Likewise.
- * g-socket.ads: Likewise.
- * s-imgrea.adb: Likewise.
- * a-calend.adb: Likewise.
- * exp_disp.adb: Likewise.
- * doc/gnat_ugn/gnat_utility_programs.rst: Likewise.
- * g-socket.adb: Likewise.
- * sem_ch12.adb: Likewise.
- * terminals.c: Likewise.
-
-2016-02-08 Bernd Schmidt <bschmidt@redhat.com>
-
- * gcc-interface/misc.c (gnat_init): Remove second argument in call to
- build_common_tree_nodes.
-
-2016-02-08 Eric Botcazou <ebotcazou@adacore.com>
-
- * gcc-interface/utils.c (create_var_decl): Set again DECL_COMMON and
- DECL_IGNORED_P last.
-
-2016-01-28 Eric Botcazou <ebotcazou@adacore.com>
-
- * gcc-interface/gigi.h (enum attr_type): Rename into...
- (enum attrib_type): ...this.
- (struct attrib): Adjust.
- * gcc-interface/decl.c (prepend_one_attribute): Likewise.
-
-2016-01-20 Eric Botcazou <ebotcazou@adacore.com>
-
- * exp_ch2.adb (Expand_Current_Value): Make an appropriate character
- literal if the entity is of a character type.
- * gcc-interface/lang.opt (fsigned-char): New option.
- * gcc-interface/misc.c (gnat_handle_option): Accept it.
- (gnat_init): Adjust comment.
- * gcc-interface/gigi.h (finish_character_type): New prototype.
- (maybe_character_type): New inline function.
- (maybe_character_value): Likewise.
- * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Enumeration_Type>: For
- a character of CHAR_TYPE_SIZE, make a signed type if flag_signed_char.
- Set TYPE_ARTIFICIAL early and call finish_character_type on the type.
- <E_Enumeration_Subtype>: For a subtype of character with RM_Size and
- Esize equal to CHAR_TYPE_SIZE, make a signed type if flag_signed_char.
- Copy TYPE_STRING_FLAG from type to subtype.
- <E_Array_Type>: Deal with character index types.
- <E_Array_Subtype>: Likewise.
- * gcc-interface/trans.c (gigi): Replace unsigned_char_type_node with
- char_type_node throughout.
- (build_raise_check): Likewise.
- (get_type_length): Deal with character types.
- (Attribute_to_gnu) <Attr_Pos>: Likewise. Remove obsolete range check
- code. Minor tweak.
- <Attr_Pred>: Likewise.
- (Loop_Statement_to_gnu): Likewise.
- (Raise_Error_to_gnu): Likewise.
- <N_Indexed_Component>: Deal with character index types. Remove
- obsolete code.
- <N_Slice>: Likewise.
- <N_Type_Conversion>: Deal with character types. Minor tweak.
- <N_Unchecked_Type_Conversion>: Likewise.
- <N_In>: Likewise.
- <N_Op_Eq>: Likewise.
- (emit_index_check): Delete.
- * gcc-interface/utils.c (finish_character_type): New function.
- (gnat_signed_or_unsigned_type_for): Deal with built-in character types.
- * gcc-interface/utils2.c (expand_sloc): Replace unsigned_char_type_node
- with char_type_node.
- (build_call_raise): Likewise.
- (build_call_raise_column): Likewise.
- (build_call_raise_range): Likewise.
-
-2016-01-18 Eric Botcazou <ebotcazou@adacore.com>
-
- * gcc-interface/gigi.h (build_call_raise_column): Adjust prototype.
- (build_call_raise_range): Likewise.
- (gnat_unsigned_type): Delete.
- (gnat_signed_type): Likewise.
- (gnat_signed_or_unsigned_type_for): New prototype.
- (gnat_unsigned_type_for): New inline function.
- (gnat_signed_type_for): Likewise.
- * gcc-interface/cuintp.c (build_cst_from_int): Call build_int_cst.
- * gcc-interface/decl.c (gnat_to_gnu_entity): Likewise.
- (gnat_to_gnu_entity) <E_Array_Type>: Always translate the index types
- and compute their base type from that.
- <E_Array_Subtype>: Remove duplicate declaration.
- * gcc-interface/misc.c (get_array_bit_stride): Call build_int_cst.
- * gcc-interface/trans.c (get_type_length): Likewise.
- (Attribute_to_gnu): Likewise.
- (Loop_Statement_to_gnu): Likewise.
- (Call_to_gnu): Likewise.
- (gnat_to_gnu): Call build_real, build_int_cst, gnat_unsigned_type_for
- and gnat_signed_type_for. Minor tweaks.
- (build_binary_op_trapv): Likewise.
- (emit_check): Likewise.
- (convert_with_check): Likewise.
- (Raise_Error_to_gnu): Adjust calls to the build_call_raise family of
- functions. Minor tweaks.
- (Case_Statement_to_gnu): Remove dead code.
- (gnat_to_gnu): Call gnat_unsigned_type_for and gnat_signed_type_for.
- (init_code_table): Minor reordering.
- * gcc-interface/utils.c (gnat_unsigned_type): Delete.
- (gnat_signed_type): Likewise.
- (gnat_signed_or_unsigned_type_for): New function.
- (unchecked_convert): Use directly the size in the test for precision
- vs size adjustments.
- (install_builtin_elementary_types): Call gnat_signed_type_for.
- * gcc-interface/utils2.c (nonbinary_modular_operation): Call
- build_int_cst.
- (build_goto_raise): New function taken from...
- (build_call_raise): ...here. Call it.
- (build_call_raise_column): Add KIND parameter and call it.
- (build_call_raise_range): Likewise.
-
-2016-01-18 Eric Botcazou <ebotcazou@adacore.com>
-
- * gcc-interface/ada-tree.h (TYPE_IMPLEMENTS_PACKED_ARRAY_P): Rename to
- (TYPE_IMPL_PACKED_ARRAY_P): ...this.
- (TYPE_CAN_HAVE_DEBUG_TYPE_P): Do not test TYPE_DEBUG_TYPE.
- * gcc-interface/decl.c (gnat_to_gnu_entity): Simplify NULL_TREE tests
- and tweak gnat_encodings tests throughout.
- (initial_value_needs_conversion): Likewise.
- (intrin_arglists_compatible_p): Likewise.
- * gcc-interface/misc.c (gnat_print_type): Likewise.
- (gnat_get_debug_type): Likewise.
- (gnat_get_fixed_point_type_info): Likewise.
- (gnat_get_array_descr_info): Likewise.
- (get_array_bit_stride): Likewise.
- (gnat_get_type_bias): Fix formatting.
- (enumerate_modes): Likewise.
- * gcc-interface/trans.c (gnat_to_gnu): Likewise.
- (add_decl_expr): Simplify NULL_TREE test.
- (end_stmt_group): Likewise.
- (build_binary_op_trapv): Fix formatting.
- (get_exception_label): Use switch statement.
- (init_code_table): Move around.
- * gcc-interface/utils.c (global_bindings_p): Simplify NULL_TREE test.
- (gnat_poplevel): Likewise.
- (gnat_set_type_context): Likewise.
- (defer_or_set_type_context): Fix formatting.
- (gnat_pushdecl): Simplify NULL_TREE test.
- (maybe_pad_type): Likewise.
- (add_parallel_type): Likewise.
- (create_range_type): Likewise.
- (process_deferred_decl_context): Likewise.
- (convert): Likewise.
- (def_builtin_1): Likewise.
- * gcc-interface/utils2.c (find_common_type): Likewise.
- (build_binary_op): Likewise.
- (gnat_rewrite_reference): Likewise.
- (get_inner_constant_reference): Likewise.
-
-2016-01-18 Eric Botcazou <ebotcazou@adacore.com>
-
- PR ada/69219
- * gcc-interface/trans.c (check_inlining_for_nested_subprog): Consider
- the parent function instead of the current function in order to issue
- the warning or the error. Add guard for ignored functions.
-
-2016-01-17 Jakub Jelinek <jakub@redhat.com>
-
- * adaint.c (__gnat_killprocesstree): Avoid -Wparentheses warning.
-
-2016-01-15 Jakub Jelinek <jakub@redhat.com>
-
- * adaint.c (__gnat_locate_exec_on_path): Use const char * instead
- of char * for path_val to avoid warnings.
-
-2016-01-06 Pierre-Marie de Rodat <derodat@adacore.com>
-
- * gcc-interface/utils.c: Bump copyright year.
- (rest_of_record_type_compilation): Add XVE/XVU parallel types to
- the current lexical scope.
-
-2016-01-04 Jakub Jelinek <jakub@redhat.com>
+2017-01-23 Tristan Gingold <gingold@adacore.com>
- * gnat_ugn.texi: Bump @copying's copyright year.
- * gnat_rm.texi: Likewise.
+ * s-boustr.ads, s-boustr.adb (Is_Full): New function.
+
+2017-01-23 Ed Schonberg <schonberg@adacore.com>
+
+ * expander.adb: Handle N_Delta_Aggregate.
+
+2017-01-23 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch6.adb (Expand_Call): Improve the code that
+ checks if some formal of the called subprogram is a class-wide
+ interface, to handle subtypes of class-wide interfaces.
+
+2017-01-23 Javier Miranda <miranda@adacore.com>
+
+ * checks.adb (Apply_Parameter_Aliasing_Checks):
+ Remove side effects of the actuals before generating the overlap
+ check.
+
+2017-01-23 Justin Squirek <squirek@adacore.com>
+
+ * exp_strm.ads, exp_strm.ads
+ (Build_Record_Or_Elementary_Input_Function): Add an extra parameter so
+ as to avoid getting the underlying type by default.
+ * exp_attr.adb (Expand_N_Attribute_Reference): Remove use of
+ underlying type in the Iiput and output attribute cases when
+ building their respective functions.
+
+2017-01-23 Gary Dismukes <dismukes@adacore.com>
+
+ * scng.adb: Minor reformatting of error message.
+
+2017-01-23 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Analyze_Expression_Function): Do not attempt
+ to freeze the return type of an expression funxtion that is a
+ completion, if the type is a limited view and the non-limited
+ view is available.
+
+2017-01-23 Ed Schonberg <schonberg@adacore.com>
+
+ * par-ch4.adb (P_Aggregate_Or_Parent_Expr): Recognize delta
+ aggregate construct.
+ (P_Record_Or_Array_Component_Association): An array aggregate
+ can start with an Iterated_Component_Association.
+ * scng.adb: Modify error message on improper use of @ in earlier
+ versions of the language.
+ * sinfo.ads: New node kind N_Delta_Aggregate.
+ * sinfo.adb: An N_Delta_Aggregate has component associations and
+ an expression.
+ * sem_res.adb (Resolve): Call Resolve_Delta_Aggregate.
+ * sem_aggr.ads, sem_aggr.adb (Resolve_Iterated_Component_Association):
+ Create a new index for each one of the choices in the association,
+ to prevent spurious homonyms in the scope.
+ (Resolve_Delta_Aggregate): New.
+ * sem.adb: An N_Delta_Aggregate is analyzed like an aggregate.
+ * exp_util.adb (Insert_Actions): Take into account
+ N_Delta_Aggregate.
+ * exp_aggr.ads: New procedure Expand_N_Delta_Aggregate.
+ * exp_aggr.adb: New procedure Expand_N_Delta_Aggregate,
+ and local procedures Expand_Delta_Array_Aggregate and
+ expand_Delta_Record_Aggregate.
+ * sprint.adb: Handle N_Delta_Aggregate.
+
+2017-01-23 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch11.adb (Expand_N_Exception_Declaration): Generate an
+ empty name when the exception declaration is subject to pragma
+ Discard_Names.
+ (Null_String): New routine.
+
+2017-01-23 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * par-ch9.adb (P_Protected_Definition): Parse
+ any optional and potentially illegal pragmas which appear in
+ a protected operation declaration list.
+ (P_Task_Items): Parse
+ any optional and potentially illegal pragmas which appear in a
+ task item list.
+
+2017-01-23 Pascal Obry <obry@adacore.com>
+
+ * s-taprop-mingw.adb (Enter_Task): Initialize the Thread handle which
+ is needed when a foreign thread call a Win32 API using a thread handle
+ like GetThreadTimes() for example.
+
+2017-01-23 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Do not
+ allow an 'Address clause to be specified on a prefix of a
+ class-wide type.
+
+2017-01-23 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * checks.adb (Insert_Valid_Check): Ensure that the prefix of
+ attribute 'Valid is a renaming of the original expression when
+ the expression denotes a name. For all other kinds of expression,
+ use a constant to capture the value.
+ * exp_util.adb (Is_Name_Reference): Moved to Sem_Util.
+ * sem_util.ads, sem_util.adb (Is_Name_Reference): Moved from Exp_Util.
+
+2017-01-23 Justin Squirek <squirek@adacore.com>
+
+ * sem_eval.adb (Eval_Integer_Literal): Add special
+ case to avoid optimizing out check if the literal appears in
+ an if-expression.
+
+2017-01-23 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Do not
+ allow an 'Address clause to be specified on a prefix of a
+ class-wide type.
+
+2017-01-23 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * checks.adb (Insert_Valid_Check): Ensure that the prefix of
+ attribute 'Valid is a renaming of the original expression when
+ the expression denotes a name. For all other kinds of expression,
+ use a constant to capture the value.
+ * exp_util.adb (Is_Name_Reference): Moved to Sem_Util.
+ * sem_util.ads, sem_util.adb (Is_Name_Reference): Moved from Exp_Util.
+
+2017-01-23 Justin Squirek <squirek@adacore.com>
+
+ * sem_eval.adb (Eval_Integer_Literal): Add special
+ case to avoid optimizing out check if the literal appears in
+ an if-expression.
+
+2017-01-23 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch4.adb (Try_Primitive_Operations,
+ Is_Valid_First_Argument_Of): argument is valid if it is a derived
+ type with unknown discriminants that matches its underlying
+ record view.
+ * exp_util.adb (Expand_Subtype_From_Expr): Do not expand
+ expression if its type is derived from a limited type with
+ unknown discriminants, because the expansion (which is a call)
+ must be expanded in the enclosing context to add the proper build-
+ in-place parameters to the call.
+ * lib.ads, exp_ch9.adb: Minor fixes in comments.
+
+2017-01-23 Yannick Moy <moy@adacore.com>
+
+ * frontend.adb (Frontend): Do not load runtime
+ unit for GNATprove when parsing failed.
+ * exp_ch9.adb: minor removal of extra whitespace
+ * exp_ch6.adb: minor typo in comment
+ * sem_util.adb: Code cleanup.
+ * exp_ch9.ads, par-ch2.adb: minor style fixes in whitespace and comment
+ * a-ngcefu.adb: minor style fix in whitespace
+
+2017-01-23 Thomas Quinot <quinot@adacore.com>
+
+ * scos.ads: Document usage of 'd' as default SCO kind for
+ declarations.
+ * par_sco.adb (Traverse_Declarations_Or_Statements.
+ Traverse_Degenerate_Subprogram): New supporting routine for expression
+ functions and null procedures.
+ (Traverse_Declarations_Or_Statements.Traverse_One): Add
+ N_Expression_Function to the subprogram case; add required
+ support for null procedures and expression functions.
+
+2017-01-23 Bob Duff <duff@adacore.com>
+
+ * namet.ads (Bounded_String): Decrease the size of type
+ Bounded_String to avoid running out of stack space.
+ * namet.ads (Append): Don't ignore buffer overflow; raise
+ Program_Error instead.
+
+2017-01-23 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch5.adb, freeze.adb, par-ch4.adb, scng.adb, sem_ch13.adb,
+ sem_ch3.adb, sem_ch5.adb, sem_ch5.ads, sem_util.adb, sinfo.ads: Minor
+ reformatting.
+ * exp_ch9.adb: minor style fix in comment.
+
+2017-01-23 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch4.adb (Analyze_Allocator): Handle properly a type derived
+ for a limited record extension with unknown discriminants whose
+ full view has no discriminants.
+
+2017-01-23 Yannick Moy <moy@adacore.com>
+
+ * exp_spark.adb: Alphabetize with clauses.
+
+2017-01-23 Yannick Moy <moy@adacore.com>
+
+ * sem_util.adb (Has_Enabled_Property): Treat
+ protected objects and variables differently from other variables.
+
+2017-01-23 Thomas Quinot <quinot@adacore.com>
+
+ * sem_ch13.adb (Adjust_Record_For_Reverse_Bit_Order):
+ Split original Ada 95 part off into new subprogram
+ below. Call that subprogram (instead of proceeding with
+ AI95-0133 behaviour) if debug switch -gnatd.p is in use.
+ (Adjust_Record_For_Reverse_Bit_Order_Ada_95): ... new subprogram
+ * debug.adb Document new switch -gnatd.p
+ * freeze.adb (Freeze_Entity.Freeze_Record_Type): Do not adjust
+ record for reverse bit order if an error has already been posted
+ on the record type. This avoids generating extraneous "info:"
+ messages for illegal code.
+
+2017-01-23 Justin Squirek <squirek@adacore.com>
+
+ * sem_ch3.adb (Analyze_Declarations): Correct comments
+ * freeze.adb (Find_Constant): Add detection of deferred constants
+ so they are not incorrectly flagged as premature.
+
+2017-01-23 Ed Schonberg <schonberg@adacore.com>
+
+ * scans.ads: New token At_Sign. Remove '@' from list of illegal
+ characters for future version of the language. '@' is legal name.
+ * scng.ads, scng.adb (Scan): Handle '@' appropriately.
+ * scn.adb (Scan_Reserved_Identifier): An occurrence of '@'
+ denotes a Target_Name.
+ * par-ch4.adb (P_Name, P_Primary): Handle Target_Name.
+ * sinfo.ads, sinfo.adb (N_Target_Name): New non-terminal node.
+ (Has_Target_Names): New flag on N_Assignment_Statement, to
+ indicate that RHS has occurrences of N_Target_Name.
+ * sem.adb: Call Analyze_Target_Name.
+ * sem_ch5.ads, sem_ch5.adb (Analyze_Target_Name): New subpogram.
+ (urrent_LHS): Global variable that denotes LHS of assignment,
+ used in the analysis of Target_Name nodes.
+ * sem_res.adb (Resolve_Target_Name): New procedure.
+ * exp_ch5.adb (Expand_Assign_With_Target_Names): (AI12-0125):
+ N is an assignment statement whose RHS contains occurences of @
+ that designate the value of the LHS of the assignment. If the
+ LHS is side-effect free the target names can be replaced with
+ a copy of the LHS; otherwise the semantics of the assignment
+ is described in terms of a procedure with an in-out parameter,
+ and expanded as such.
+ (Expand_N_Assignment_Statement): Call
+ Expand_Assign_With_Target_Names when needed.
+ * exp_util.adb (Insert_Actions): Take into account N_Target_Name.
+ * sprint.adb: Handle N_Target_Name.
+
+2017-01-23 Eric Botcazou <ebotcazou@adacore.com>
+
+ * checks.adb: Minor fix in comment.
+
+2017-01-23 Philippe Gil <gil@adacore.com>
+
+ * g-debpoo.adb (Do_Report) remove freed chunks from chunks
+ count in Sort = Memory_Usage or Allocations_Count
+
+2017-01-23 Justin Squirek <squirek@adacore.com>
+
+ * sem_ch3.adb: Code cleanup.
+
+2017-01-23 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_prag.adb (Analyze_Refined_Depends_In_Decl_Part): Move all global
+ variables to the local variable section. Update the profile
+ of various nested routine that previously had visibility
+ of those globals. One the matching phase has completed,
+ remove certain classes of clauses which are considered noise.
+ (Check_Dependency_Clause): Properly detect a match between two
+ 'Result attributes. Update the various post-match cases to use
+ Is_Already_Matched as this routine now automatically recognizes
+ a previously matched 'Result attribute.
+ (Is_Already_Matched): New routine.
+ (Remove_Extra_Clauses): New routine.
+ (Report_Extra_Clauses): Remove the detection of ... => null
+ clauses as this is now done in Remove_Extra_Clauses.
+
+2017-01-23 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_aggr.adb (Resolve_Array_Aggregate): In ASIS mode do not
+ report on spurious overlaps between values involving a subtype
+ with a static predicate, because the expansion of such a subtype
+ into individual ranges in inhibited in ASIS mode.
+
+2017-01-23 Justin Squirek <squirek@adacore.com>
+
+ * sem_ch3.adb (Analyze_Declarations): Add detection
+ of an edge case and delay freezing if it is present.
+
+2017-01-23 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch3.adb, exp_spark.adb, exp_attr.adb, sem_ch9.adb, sem_prag.adb,
+ sem_util.adb, sem_warn.adb, exp_ch3.adb: Minor reformatting.
+
+2017-01-23 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * freeze.adb (Freeze_Subprogram): Ensure that all anonymous
+ access-to-subprogram types inherit the convention of the
+ associated subprogram. (Set_Profile_Convention): New routine.
+ * sem_ch6.adb (Check_Conformance): Do not compare the conventions
+ of the two entities directly, use Conventions_Match to account
+ for anonymous access-to-subprogram and subprogram types.
+ (Conventions_Match): New routine.
+
+2017-01-23 Claire Dross <dross@adacore.com>
+
+ * exp_spark.adb (Expand_SPARK_Attribute_Reference): For attributes
+ which return Universal_Integer, force the overflow check flag for
+ Length and Range_Length for types as big as Long_Long_Integer.
+
+2017-01-23 Claire Dross <dross@adacore.com>
+
+ * exp_spark.adb (Expand_SPARK_Attribute_Reference): For
+ attributes which return Universal_Integer, introduce a conversion
+ to the expected type with the appropriate check flags set.
+ * sem_res.adb (Resolve_Range): The higher bound can be in Typ's
+ base type if the range is null. It may still be invalid if it
+ is higher than the lower bound. This is checked later in the
+ context in which the range appears.
+
+2017-01-23 Pierre-Marie de Rodat <derodat@adacore.com>
+
+ * scos.ads: Introduce a constant to represent ignored
+ dependencies in SCO_Unit_Table_Entry.
+
+2017-01-23 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch9.adb (Expand_N_Protected_Type_Declaration): Remove extra
+ spaces from error messages.
+
+2017-01-23 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch3.adb (Check_Large_Modular_Array): New procedure,
+ subsidiary to Expand_N_Object_ Declaration, to compute a guard on
+ an object declaration for an array type with a modular index type
+ with the size of Long_Long_Integer. Special processing is needed
+ in this case to compute reliably the size of the object, and
+ eventually to raise Storage_Error, when wrap-around arithmetic
+ might compute a meangingless size for the object.
+
+2017-01-23 Justin Squirek <squirek@adacore.com>
+
+ * a-wtenau.adb, par-endh.adb, sem_prag.adb,
+ sem_type.adb: Code cleanups.
+
+2017-01-23 Bob Duff <duff@adacore.com>
+
+ * sem_res.adb (Resolve_Call): In the part of the code where
+ it is deciding whether to turn the call into an indexed
+ component, avoid doing so if the call is to an instance of
+ Unchecked_Conversion. Otherwise, the compiler turns it into an
+ indexed component, and resolution of that turns it back into a
+ function call, and so on, resulting in infinite recursion.
+ * sem_util.adb (Needs_One_Actual): If the first formal has a
+ default, then return False.
+
+2017-01-21 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_eval.adb (Compile_Time_Compare): Reinstate the expr+literal (etc)
+ optimizations when the type is modular and the offsets are equal.
+
+2017-01-20 Thomas Quinot <quinot@adacore.com>
+
+ * sem_warn.adb (Warn_On_Useless_Assignment): Adjust wording of warning
+ message.
+
+2017-01-20 Nicolas Roche <roche@adacore.com>
+
+ * terminals.c: Ignore failures on setpgid and tcsetpgrp commands.
+
+2017-01-20 Bob Duff <duff@adacore.com>
+
+ * sem_eval.adb (Compile_Time_Compare): Disable the expr+literal
+ (etc) optimizations when the type is modular.
+
+2017-01-20 Yannick Moy <moy@adacore.com>
+
+ * sem_ch6.adb (Move_Pragmas): move some pragmas,
+ but copy the SPARK_Mode pragma instead of moving it.
+ (Build_Subprogram_Declaration): Ensure that the generated spec
+ and original body share the same SPARK_Pragma aspect/pragma.
+ * sem_util.adb, sem_util.ads (Copy_SPARK_Mode_Aspect): New
+ procedure to copy SPARK_Mode aspect.
+
+2017-01-20 Bob Duff <duff@adacore.com>
+
+ * sem_ch3.adb (Analyze_Declarations): Disable Resolve_Aspects
+ even in ASIS mode.
+ * sem_ch13.adb (Resolve_Name): Enable setting the entity to
+ Empty even in ASIS mode.
+
+2017-01-20 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch9.adb: minor style fixes in comments.
+ * sem_ch9.adb (Analyze_Delay_Relative): in GNATprove mode a delay
+ relative statement introduces an implicit dependency on
+ Ada.Real_Time.Clock_Time.
+ * sem_util.adb: Minor reformatting.
+
+2017-01-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch13.adb (Analyze_Aspect_Specifications): Aspect Alignment
+ must be treated as delayed aspect even if the expression is
+ a literal, because the aspect affects the freezing and the
+ elaboration of the object to which it applies.
+
+2017-01-20 Tristan Gingold <gingold@adacore.com>
+
+ * s-osinte-vxworks.ads (Interrup_Range): New subtype.
+
+2017-01-20 Ed Schonberg <schonberg@adacore.com>
+
+ * lib-xref.adb (Generate_Reference): Do not warn about the
+ presence of a pragma Unreferenced if the entity appears as the
+ actual in a procedure call that does not come from source.
+
+2017-01-20 Pascal Obry <obry@adacore.com>
+
+ * expect.c, terminals.c: Fix some warnings about unused variables.
+ * gsocket.h, adaint.c, adaint.h: Fix some more warnings in the C part
+ of the runtime.
+
+2017-01-20 Bob Duff <duff@adacore.com>
+
+ * exp_attr.adb (Constrained): Apply an access check (check that
+ the prefix is not null) when the prefix denotes an object of an
+ access type; that is, when there is an implicit dereference.
+
+2017-01-20 Gary Dismukes <dismukes@adacore.com>
+
+ * s-rident.ads (constant Profile_Info): Remove
+ No_Calendar from GNAT_Extended_Ravenscar restrictions.
+
+2017-01-20 Tristan Gingold <gingold@adacore.com>
+
+ * s-maccod.ads: Add pragma No_Elaboration_Code_All
+
+2017-01-20 Hristian Kirtchev <kirtchev@adacore.com>
-2016-01-02 Eric Botcazou <ebotcazou@adacore.com>
+ * ghost.adb (Mark_Ghost_Clause): New routine.
+ (Prune_Node): Do not prune compilation unit nodes.
+ (Remove_Ignored_Ghost_Code): Prune the compilation unit node directly.
+ This does not touch the node itself, but does prune all its fields.
+ * ghost.ads (Mark_Ghost_Clause): New routine.
+ * sem_ch8.adb (Analyze_Use_Package): Emit an error when a use
+ package clause mentions Ghost and non-Ghost packages. Mark a
+ use package clause as Ghost when it mentions a Ghost package.
+ (Analyze_Use_Type): Emit an error when a use type clause mentions
+ Ghost and non-Ghost types. Mark a use type clause as Ghost when
+ it mentions a Ghost type.
+ * sem_ch10.adb (Analyze_With_Clause): Mark a with clause as
+ Ghost when it withs a Ghost unit.
+
+2017-01-20 Javier Miranda <miranda@adacore.com>
+
+ * sem_res.adb (Resolve_Call): If a function call
+ returns a limited view of a type and at the point of the call the
+ function is not declared in the extended main unit then replace
+ it with the non-limited view, which must be available. If the
+ called function is in the extended main unit then no action is
+ needed since the back-end handles this case.
+
+2017-01-20 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch7.adb (Contains_Subp_Or_Const_Refs): Rename into...
+ (Contains_Subprograms_Refs): ...this. Adjust comment
+ for constants. (Is_Subp_Or_Const_Ref): Rename into...
+ (Is_Subprogram_Ref): ...this.
+ (Has_Referencer): Rename Has_Non_Subp_Const_Referencer variable into
+ Has_Non_Subprograms_Referencer and adjust comment. Remove
+ incorrect shortcut for package declarations and bodies.
+
+2017-01-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Complete_Private_Subtype): If the scope of the
+ base type differs from that of the completion and the private
+ subtype is an itype (created for a constraint on an access
+ type e.g.), set Delayed_Freeze on both to prevent out-of-scope
+ anomalies in gigi.
+
+2017-01-20 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch6.adb (Analyze_Subprogram_Body_Helper):
+ When inheriting the SPARK_Mode of a prior expression function,
+ look at the properly resolved entity rather than the initial
+ candidate which may denote a homonym.
+
+2017-01-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_prag.adb (Rewrite_Assertion_Kind): If the name is
+ Precondition or Postcondition, and the context is pragma
+ Check_Policy, indicate that this Pre-Ada2012 usage is deprecated
+ and suggest the standard names Assertion_Policy /Pre /Post
+ instead.
+
+2017-01-20 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch10.adb, sem_cat.adb: Minor reformatting.
+
+2017-01-20 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch3.adb (Access_Type_Declaration): Protect access to the
+ Entity attribute.
+ * sem_ch10.adb (Install_Siblings): Skip processing malformed trees.
+ * sem_cat.adb (Validate_Categoriztion_Dependency): Skip processing
+ malformed trees.
+
+2017-01-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch13.adb (Analyze_Aspect_Specification, case
+ Dynamic_Predicate): If the entity E is a subtype that inherits
+ a static predicate for its parent P,, the inherited and the
+ new predicate combine in the generated predicate function,
+ and E only has a dynamic predicate.
+
+2017-01-20 Tristan Gingold <gingold@adacore.com>
+
+ * s-boustr.ads, s-boustr.adb: New package.
+ * Makefile.rtl: Add s-boustr.
+
+2017-01-20 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * inline.adb (Process_Formals): Qualify the
+ expression of a return statement when it yields a universal type.
+
+2017-01-20 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * freeze.adb (Freeze_All): Freeze the default
+ expressions of all eligible formal parameters that appear in
+ entries, entry families, and protected subprograms.
+
+2017-01-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Check_Nonoverridable_Aspects); Refine check
+ for illegal inherited Implicit_Dereference aspects with renamed
+ discriminants.
+
+2017-01-20 Javier Miranda <miranda@adacore.com>
+
+ * debug.adb (switch d.6): do not avoid declaring unreferenced itypes.
+ * nlists.ads (Lock_Lists, Unlock_Lists): New subprograms.
+ * nlists.adb (Lock_Lists, Unlock_Lists): New subprograms.
+ (Set_First, Set_Last, Set_List_Link, Set_Next, Set_Parent,
+ Set_Prev, Tree_Read): Adding assertion.
+ * atree.ads (Lock_Nodes, Unlock_Nodes): New subprograms.
+ * atree.adb (Lock_Nodes, Unlock_Nodes): New subprograms.
+ (Set_Analyzed, Set_Check_Actuals, Set_Comes_From_Source,
+ Set_Ekind, Set_Error_Posted, Set_Has_Aspects,
+ Set_Is_Ignored_Ghost_Node, Set_Original_Node, Set_Paren_Count,
+ Set_Parent, Set_Sloc, Set_Nkind, Set_FieldNN, Set_NodeNN,
+ Set_ListNN, Set_ElistNN, Set_NameN, Set_StrN, Set_UintNN,
+ Set_UrealNN, Set_FlagNNN, Set_NodeN_With_Parent,
+ Set_ListN_With_Parent): Adding assertion.
+
+2017-01-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_prag.adb (Process_Convention): Diagnose properly a pragma
+ import that applies to several homograph subprograms. when one
+ of them is declared by a subprogram body.
+
+2017-01-20 Justin Squirek <squirek@adacore.com>
+
+ * exp_ch6.adb (Expand_Call): Remove optimization
+ that nulls out calls to null procedures.
+
+2017-01-20 Yannick Moy <moy@adacore.com>
+
+ * inline.adb (Expand_Inlined_Call): Keep more
+ precise type of actual for inlining whenever possible. In
+ particular, do not switch to the formal type in GNATprove mode in
+ some case where the GNAT backend might require it for visibility.
+
+2017-01-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Check_Non_Overridable_Aspects): An inherited
+ aspect Implicit_Dereference can be inherited by a full view if
+ the partial view has no discriminants, because there is no way
+ to apply the aspect to the partial view.
+ (Build_Derived_Record_Type): If derived type renames discriminants
+ of the parent, the new discriminant inherits the aspect from
+ the old one.
+ * sem_ch4.adb (Analyze_Call): Handle properly a parameterless
+ call through an access discriminant designating a subprogram.
+ * sem_ch5.adb (Analyze_Assignment): (Analyze_Call): Handle
+ properly a parameterless call through an access discriminant on
+ the left-hand side of an assignment.
+ * sem_res.adb (resolve): If an interpreation involves a
+ discriminant with an implicit dereference and the expression is an
+ entity, resolution takes place later in the appropriate routine.
+ * sem_ch13.adb (Analyze_Aspect_Implicit_Dereference): Recognize
+ access discriminants that designate a subprogram type.
+
+2017-01-20 Pascal Obry <obry@adacore.com>
+
+ * a-locale.adb, a-locale.ads: Update Ada.Locales for RM 2012 COR:1:2016
+
+2017-01-20 Yannick Moy <moy@adacore.com>
+
+ * sem_ch10.adb (Check_No_Elab_Code_All): Do not issue an error
+ on implicitly with'ed units in GNATprove mode.
+ * sinfo.ads (Implicit_With): Document use of flag for implicitly
+ with'ed units in GNATprove mode.
+
+2017-01-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_cat.adb (Validate_Static_Object_Name): In a preelaborated
+ unit Do not report an error on a non-static entity that appears
+ in the context of a spec expression, such as an aspect expression.
+
+2017-01-20 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * einfo.adb: Flag298 now denotes Is_Underlying_Full_View.
+ (Is_Underlying_Full_View): New routine.
+ (Set_Is_Underlying_Full_View): New routine.
+ (Write_Entity_Flags): Add an entry for Is_Underlying_Full_View.
+ * einfo.ads Add new attribute Is_Underlying_Full_View.
+ (Is_Underlying_Full_View): New routine along with pragma Inline.
+ (Set_Is_Underlying_Full_View): New routine along with pragma Inline.
+ * exp_util.adb (Build_DIC_Procedure_Body): Do not consider
+ class-wide types and underlying full views. The first subtype
+ is used as the working type for all Itypes, not just array base types.
+ (Build_DIC_Procedure_Declaration): Do not consider
+ class-wide types and underlying full views. The first subtype
+ is used as the working type for all Itypes, not just array
+ base types.
+ * freeze.adb (Freeze_Entity): Inherit the freeze node of a full
+ view or an underlying full view without clobbering the attributes
+ of a previous freeze node.
+ (Inherit_Freeze_Node): New routine.
+ * sem_ch3.adb (Build_Derived_Private_Type): Mark an underlying
+ full view as such.
+ (Build_Underlying_Full_View): Mark an underlying full view as such.
+ * sem_ch7.adb (Install_Private_Declarations): Mark an underlying
+ full view as such.
+
+2017-01-20 Yannick Moy <moy@adacore.com>
+
+ * sinfo.ads: Document lack of Do_Division_Check flag
+ on float exponentiation.
+
+2017-01-19 Javier Miranda <miranda@adacore.com>
+
+ * ghost.adb (Propagate_Ignored_Ghost_Code): Protect access to the
+ identifier attribute of a block-statement node. Required to avoid
+ assertion failure when building the new containers library.
+
+2017-01-19 Bob Duff <duff@adacore.com>
+
+ * exp_ch3.adb: Update comment.
+
+2017-01-19 Vincent Celier <celier@adacore.com>
+
+ * gprep.adb (Gnatprep): Parse the definition file without
+ "replace in comments" even when switch -C is used.
+
+2017-01-19 Justin Squirek <squirek@adacore.com>
+
+ * exp_ch9.adb (Is_Pure_Barrier): Create function
+ Is_Count_Attribute to identify an expansion of the 'Count
+ attribute.
+
+2017-01-19 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch5.adb (Analyze_Loop_Statement): In GNATprove mode the
+ statements within an element iterator loop are only analyzed
+ agter the loop is rewritten. Within a generic the analysis must
+ be performed in any case to complete name capture.
+
+2017-01-19 Bob Duff <duff@adacore.com>
+
+ * sem_prag.adb (Analyze_Pragma): Check for ignored pragmas first,
+ before checking for unrecognized pragmas.
+ Initialize Pname on its declarations; that's always good style.
+
+2017-01-19 Claire Dross <dross@adacore.com>
+
+ * exp_ch7.adb (Build_Invariant_Procedure_Body): Semi-insert the
+ body into the tree for GNATprove by setting its Parent field. The
+ components invariants of composite types are not checked by
+ the composite type's invariant procedure in GNATprove mode.
+ (Build_Invariant_Procedure_Declaration): Semi-insert the
+ declaration into the tree for GNATprove by setting its Parent
+ field.
+ * freeze.adb (Freeze_Arry_Type):In GNATprove mode, do not add
+ the component invariants to the array type invariant procedure
+ so that the procedure can be used to check the array type
+ invariants if any.
+ (Freeze_Record_Type): In GNATprove mode, do
+ not add the component invariants to the record type invariant
+ procedure so that the procedure can be used to check the record
+ type invariants if any.
+
+2017-01-19 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * lib-xref-spark_specific.adb: Minor reformatting.
+ * exp_ch7.adb (Add_Parent_Invariants): Do not process array types.
+
+2017-01-19 Javier Miranda <miranda@adacore.com>
+
+ * exp_aggr.adb (Pass_Aggregate_To_Back_End): Renamed as
+ Build_Back_End_Aggregate.
+ (Generate_Aggregate_For_Derived_Type): Code cleanup.
+ (Prepend_Stored_Values): Code cleanup.
+
+2017-01-19 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Analyze_Expression_Function): Check for an
+ incomplete return type after attempting to freeze it, so that
+ other freeze actiona are generated in the proper order.
+
+2017-01-19 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_aggr.adb (Resolve_Aggregate): If the type is a string
+ type, ie. a type whose component is a character type, and the
+ aggregate is positional, do not convert into a string literal
+ if the index type is not an integer type, because the original
+ type may be required in an enclosing operation.
+
+2017-01-19 Bob Duff <duff@adacore.com>
+
+ * binde.adb, debug.adb: Enable new elaboration order algorithm
+ by default. -dp switch reverts to the old algorithm.
+
+2017-01-19 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch3.adb Add with and use clauses for Exp_Ch7.
+ (Analyze_Declarations): Create the DIC and Invariant
+ procedure bodies s after all freezing has taken place.
+ (Build_Assertion_Bodies): New routine.
+ * sem_ch7.adb Remove the with and use clauses for Exp_Ch7
+ and Exp_Util.
+ (Analyze_Package_Specification): Remove the
+ generation of the DIC and Invariant procedure bodies. This is
+ now done by Analyze_Declarations.
+ * sem_disp.adb (Check_Dispatching_Operation): DIC and Invariant
+ procedures are never treated as primitives.
+
+2017-01-19 Yannick Moy <moy@adacore.com>
+
+ * frontend.adb: Analyze inlined bodies and check elaboration
+ rules in GNATprove mode too.
+ * sem_elab.adb (Delay_Element): Add Boolean component to save
+ indication that call is in SPARK code. (Check_Elab_Calls):
+ Check elaboration rules in GNATprove mode, and correctly set
+ the current value of SPARK_Mode.
+ * lib-xref-spark_specific.adb
+ (Add_SPARK_Xrefs): Simplify iteration over dereferences.
+
+2017-01-19 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch4.adb (Expand_Concatenate): Do no enable overflow
+ checks on the expression for the high bound of concatenation
+ when checks are disabled, to suppress warnings about potential
+ constraint errors in restricted runtimes.
+
+2017-01-19 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch3.adb (Expand_Freeze_Enumeration_Type): Mark the
+ representation-to-position function as inlined.
+ * sem_cat.adb (Set_Categorization_From_Scope): Do not modify
+ the purity of an internally generated entity if it has been
+ explicitly marked as pure for optimization purposes.
+ * exp_aggr.adb: Minor reformatting.
+
+2017-01-19 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch6.adb (Expand_Call): Remove side effects on
+ actuals that are allocators with qualified expression since the
+ initialization of the object is performed by means of individual
+ statements (and hence it must be done before the call).
+
+2017-01-19 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Analyze_Declarations): Minor reformatting.
+ (Build_Derived_Enumeration_Type): If the derived type inherits a
+ dynamic predicate from its parent, the bounds of the type must
+ freeze because an explicit constraint is constructed for the
+ type and the corresponding range is elaborated now.
+
+2017-01-19 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_attr.ads: minor fix of inconsistent casing in comment
+ * lib-writ.ads: minor align comments in columns
+ * sem_ch3.adb: Minor reformatting.
+ * spark_xrefs.ads: minor fix typo in SPARK-related comment
+ * table.ads: minor style fix in comment
+ * lib-xref-spark_specific.adb
+ (Add_SPARK_Xrefs): simplify processing of SPARK cross-references.
+ * sem_ch12.adb: minor whitespace fix
+ * freeze.adb: Add comment.
+ * sem_util.adb (Unique_Name): for instances of
+ generic subprograms ignore the name of the wrapper package.
+
+2017-01-19 Javier Miranda <miranda@adacore.com>
+
+ * exp_aggr.adb (Resolve_Record_Aggregate):
+ Factorize code needed for aggregates of limited and unlimited
+ types in a new routine.
+ (Pass_Aggregate_To_Back_End): New subprogram.
+
+2017-01-19 Yannick Moy <moy@adacore.com>
+
+ * sinfo.adb (Pragma_Name): Only access up to Last_Pair of Pragma_Map.
+
+2017-01-19 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch4.ads, sem_ch4.adb (Try_Object_Operation): Make subprogram
+ public, for use elsewhere.
+ * sem_ch6.adb (Analyze_Procedure_Call): In SPARK_Mode and within
+ an Inlined_body, recognize a call that uses object notation
+ and has not been rewritten as a regular call because regular
+ expansion has not taken place.
+
+2017-01-19 Bob Duff <duff@adacore.com>
+
+ * checks.adb (Apply_Type_Conversion_Checks): Disable small optimization
+ in case of generic formal discrete types, because it causes crashes in
+ the compiler when built with assertions on.
+
+2017-01-19 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * lib-xref-spark_specific.adb, sem_util.adb, sem_util.ads,
+ sem_ch4.adb, sem_ch8.adb, lib-xref.ads: Minor reformatting.
+
+2017-01-19 Bob Duff <duff@adacore.com>
+
+ * bcheck.adb (Check_Consistent_Dynamic_Elaboration_Checking):
+ Increment Warnings_Detected. It was decrementing, which is
+ wrong since we just issued a warning message.
+ * binderr.ads (Errors_Detected, Warnings_Detected): Declare
+ these variables to be of subtype Nat instead of Int, because
+ they should never be negative.
+
+2017-01-19 Javier Miranda <miranda@adacore.com>
+
+ * contracts.adb (Build_Postconditions_Procedure): Replace
+ Generate_C_Code by Modify_Tree_For_C.
+ * exp_aggr.adb (Build_Record_Aggr_Code, Expand_Array_Aggregate):
+ Replace Generate_C_Code by Modify_Tree_For_C.
+ * exp_attr.adb (Float_Valid, Is_GCC_Target): Replace Generate_C_Code by
+ Modify_Tree_For_C.
+ * exp_ch11.adb (Expand_N_Exception_Declaration): Replace
+ Generate_C_Code by Modify_Tree_For_C.
+ * exp_ch4.adb (Expand_Allocator_Expression): Replace
+ Generate_C_Code by Modify_Tree_For_C.
+ * exp_dbug.adb (Qualify_Entity_Name): Replace Generate_C_Code
+ by Modify_Tree_For_C.
+ * exp_util.adb (Remove_Side_Effects, Side_Effect_Free): Replace
+ Generate_C_Code by Modify_Tree_For_C.
+ * sem_res.adb (Resolve_Type_Conversion): Replace Generate_C_Code
+ by Modify_Tree_For_C.
+ * sinfo.ads (Modify_Tree_For_C): Adding documentation.
+
+2017-01-19 Javier Miranda <miranda@adacore.com>
+
+ * sem_util.ads, sem_util.adb (Expression_Of_Expression_Function): New
+ subprogram.
+ (Is_Inlinable_Expression_Function): New subprogram.
+ * exp_ch6.ads, exp_ch6.adb (Expression_Of_Expression_Function): Moved
+ to Sem_Util.
+ (Is_Inlinable_Expression_Function): Moved to Sem_Util.
+
+2017-01-19 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch4.adb (Diagnose_Call): Improve error message when a
+ selected component has a prefix that might be interpreted
+ as a parameterless function call, but none of the candidate
+ interpretations is parameterless, and there is a hidden homonym
+ of the prefix that is a package.
+ * sem_ch8.adb (Find_Selected_Component): If the prefix might be
+ interpreted as a parameterless function call and its analysis
+ fails, do not call Analyze_Selected_Component.
+
+2017-01-19 Steve Baird <baird@adacore.com>
+
+ * sem_util.ads: Add new Use_Full_View Boolean parameter to
+ Get_Index_Bounds.
+ * sem_util.adb (Get_Index_Bounds): replace calls to Scalar_Range with
+ calls to a newly-defined Scalar_Range_Of_Right_View function.
+
+2017-01-19 Arnaud Charlet <charlet@adacore.com>
+
+ * gnat1drv.adb: minor fix of unbalanced parens in comment
+ * lib-xref.ads (Traverse_Compilation_Unit): declaration moved
+ to visible part of the package to allow re-use in GNATprove.
+ * lib-xref-spark_specific.adb (Traverse_Stub): routine refactored
+ from repeated code of Traverse_Compilation_Unit.
+ (Traverse_Declaration_Or_Statement): fixed detection of
+ generic subprograms and packages; also, iteration over case
+ statement alternatives rewritten to avoid testing if the first
+ alternative is present (since it must be present due to Ada
+ syntax restrictions).
+
+2017-01-19 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch6.adb (Expand_N_Subprogram_Body): Mark the spec as
+ returning by reference not just for subprogram body stubs,
+ but for all subprogram cases.
+ * sem_util.adb: Code reformatting.
+ (Requires_Transient_Scope): Update the call to Results_Differ.
+ (Results_Differ): Update the parameter profile and the associated
+ comment on usage.
+
+2017-01-19 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_dim.adb (Analyze_Dimension): Analyze object declaration and
+ identifier nodes that do not come from source, to handle properly
+ dimensionality check within an inlined body which inclddes both
+ original operands and rewritten operands. This removes spurious
+ dimensionality errors in the presence of front-end inlining,
+ as well as in SPARK mode.
+
+2017-01-16 Jakub Jelinek <jakub@redhat.com>
+
+ PR driver/49726
+ * gcc-interface/lang.opt (gant, gnatO, gnat): Add Driver flag.
+
+2017-01-13 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
+
+ * gcc-interface/Makefile.in (SPARC/Solaris): Fix typo.
+
+2017-01-13 Arnaud Charlet <charlet@adacore.com>
+
+ * doc/gnat_ugn/getting_started_with_gnat.rst,
+ doc/gnat_ugn/inline_assembler.rst,
+ doc/gnat_ugn/building_executable_programs_with_gnat.rst,
+ doc/gnat_ugn/elaboration_order_handling_in_gnat.rst,
+ doc/gnat_ugn/about_this_guide.rst,
+ doc/gnat_ugn/platform_specific_information.rst,
+ doc/gnat_ugn/example_of_binder_output.rst,
+ doc/gnat_ugn/gnat_and_program_execution.rst,
+ doc/gnat_ugn/gnat_utility_programs.rst,
+ doc/gnat_ugn/the_gnat_compilation_model.rst,
+ doc/gnat_rm/implementation_defined_attributes.rst,
+ doc/gnat_rm/compatibility_and_porting_guide.rst,
+ doc/gnat_rm/standard_library_routines.rst,
+ doc/gnat_rm/standard_and_implementation_defined_restrictions.rst,
+ doc/gnat_rm/implementation_defined_pragmas.rst,
+ doc/gnat_rm/the_gnat_library.rst,
+ doc/gnat_rm/obsolescent_features.rst,
+ doc/gnat_rm/about_this_guide.rst,
+ doc/gnat_rm/the_implementation_of_standard_i_o.rst,
+ doc/gnat_rm/implementation_of_ada_2012_features.rst,
+ doc/gnat_rm/interfacing_to_other_languages.rst,
+ doc/gnat_rm/implementation_defined_aspects.rst,
+ doc/gnat_rm.rst: Update documentation.
+ * gnat_rm.texi, gnat_ugn.texi: Regenerated.
+
+2017-01-13 Ed Schonberg <schonberg@adacore.com>
+
+ * einfo.ads: minor grammar fixes in comment of Normalized_Position_Max.
+ * scil_ll.adb: Minor style fix in comment.
+ * sem_ch8.adb (Analyze_Expanded_Name): Perform dimension analysis
+ even if entity is already set, because the node may be renalyzed
+ after inlining transformations.
+
+2017-01-13 Javier Miranda <miranda@adacore.com>
+
+ * sem_res.adb (Resolve_Call): Do not establish a transient scope
+ for a call to inlinable expression function (since the call will
+ be replaced by its returned object).
+ * exp_ch6.ads (Is_Inlinable_Expression_Function): New subprogram.
+ * exp_ch6.adb (Expression_Of_Expression_Function): New subprogram.
+ (Expand_Call): For inlinable expression function call replace the
+ call by its returned object.
+ (Is_Inlinable_Expression_Function): New subprogram.
+
+2017-01-13 Gary Dismukes <dismukes@adacore.com>
+
+ * checks.adb: Minor typo fix and reformatting.
+
+2017-01-13 Javier Miranda <miranda@adacore.com>
+
+ * contracts.adb (Contract_Only_Subprograms): Remove formal.
+ (Copy_Original_Specification): Removed.
+ (Skip_Contract_Only_Subprogram): Move here checks previously
+ located in the caller of this routine (to leave the code more clean).
+ (Build_Contract_Only_Subprogram): Code cleanup.
+ * scil_ll.ads, scil_ll.adb (Get_Contract_Only_Body_Name): Removed.
+ (Get_Contract_Only_Missing_Body_Name): Removed.
+
+2017-01-13 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch6.adb (Cloned_Expression): New subprogram.
+ (Freeze_Expr_Types): Complete previous patch since the expression
+ of an expression-function may have iterators and loops with
+ defining identifiers which, as part of the preanalysis of the
+ expression, may be left decorated with itypes that will not be
+ available in the tree passed to the backend.
+
+2017-01-13 Ed Schonberg <schonberg@adacore.com>
+
+ * checks.adb (Apply_Type_Conversion_Checks): Optimize a type
+ conversion to Integer of an expression that is an attribute
+ reference 'Pos on an enumeration type.
+
+2017-01-13 Bob Duff <duff@adacore.com>
+
+ * atree.ads: Minor comment fix.
+
+2017-01-13 Justin Squirek <squirek@adacore.com>
+
+ * sem_ch6.adb (Check_Aggregate_Accessibility): Ignore function
+ calls in accessibility check on return statement.
+
+2017-01-13 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch6.adb (Analyze_Subprogram_Body_Helper):
+ Ensure that the input body is a subprogram body before trying to
+ determine whether it denoted an expression function. Note that
+ subprogram body stubs cannot denote expression functions.
+
+2017-01-13 Gary Dismukes <dismukes@adacore.com>
+
+ * bindgen.adb, sem_ch6.adb, binde.adb, exp_ch3.adb: Minor reformatting
+ and typo fixes.
+
+2017-01-13 Javier Miranda <miranda@adacore.com>
+
+ * einfo.ads (Component_Bit_Offset): Fix documentation.
+ * sem_ch13.adb (Check_Record_Representation_Clause): Skip check
+ on record holes for components with unknown compile-time offsets.
+
+2017-01-13 Bob Duff <duff@adacore.com>
+
+ * ali.ads, ali.adb (Static_Elaboration_Model_Used): Remove unused flag.
+ * g-locfil.ads: Minor comment fix.
+
+2017-01-13 Bob Duff <duff@adacore.com>
+
+ * binde.adb (Elab_New): New elaboration order algorithm
+ that is expected to cause fewer ABE issues. This is a work in
+ progress. The new algorithm is currently disabled, and can be
+ enable by the -dp switch, or by modifying the Do_Old and Do_New
+ etc. flags and rebuilding. Experimental code is included to
+ compare the results of the old and new algorithms.
+ * binde.ads: Use GNAT.Dynamic_Tables instead of Table, so we
+ can have multiple of these tables, so the old and new algorithms
+ can coexist.
+ * bindgen.ads (Gen_Output_File): Pass Elab_Order as an 'in'
+ parameter of type array. This avoids the global variable, and
+ allows bounds checking (which is normally defeated by the tables
+ packages). It also ensures that the Elab_Order is read-only
+ to Bindgen.
+ * bindgen.adb: Pass Elab_Order as an 'in' parameter to all
+ subprograms that need it, as above.
+ * debug.adb: Document new -dp switch. Modify doc of old -do
+ switch.
+ * gnatbind.adb (Gnatbind): Make use of new interfaces to Binde
+ and Bindgen. Move writing of closure (-R and -Ra switches)
+ to Binde; that's more convenient.
+
+2017-01-13 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Analyze_Expression_Function): If the expression
+ function is a completion, all entities referenced in the
+ expression are frozen. As a consequence, a reference to an
+ uncompleted private type from an enclosing scope is illegal.
+
+2017-01-13 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch6.adb (Freeze_Expr_Types): New subprogram.
+ (Analyze_Subprogram_Body_Helper): At the occurrence of an
+ expression function declaration that is a completion, its
+ expression causes freezing (AI12-0103).
+
+2017-01-13 Vadim Godunko <godunko@adacore.com>
+
+ * a-coinho-shared.adb: Fix memory leaks in Constant_Reference and
+ Reference functions of Ada.Containers.Indefinite_Holders.
+
+2017-01-13 Bob Duff <duff@adacore.com>
+
+ * s-os_lib.ads: Minor comment fixes.
+
+2017-01-13 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch3.adb (Default_Initialize_Object): Do not default
+ initialize an object when it is of a task type and restriction
+ No_Tasking is in effect because the initialization is obsolete.
+ * exp_ch9.adb (Build_Master_Entity): Do not generate a master when
+ restriction No_Tasking is in effect.
+ (Build_Master_Renaming): Do not rename a master when restriction
+ No_Tasking is in effect.
+
+2017-01-13 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_aggr.adb (Resolve_Array_Aggregate): The code that verifies
+ the legality of An others clause applies as well to a choice in
+ an Iterated_component_ association.
+ (Resolve_Iterated_Component_Association): An others choice
+ is legal.
+ * exp_aggr.adb (Aggr_Assignment_OK_For_Backend): An
+ Iterated_Component_Association is not static.
+
+2017-01-13 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch3.adb (Freeze_Type): Mark the Ghost mode as set in case
+ control is passed to the expresion handler before the new mode
+ is set.
+ * sem_ch12.adb (Analyze_Package_Instantiation,
+ Analyze_Subprogram_Instantiation): Mark the Ghost mode as set
+ in case control is passed to the expresion handler before the
+ new mode is set.
+
+2017-01-13 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_aggr.adb, sem_ch3.adb, inline.adb, sem_util.adb, exp_ch4.adb,
+ exp_aggr.adb: Minor reformatting.
+
+2017-01-13 Gary Dismukes <dismukes@adacore.com>
+
+ * inline.adb: Minor reformatting and typo fix.
+
+2017-01-13 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_util.ads, sem_util.adb (Choice_List): Move function here
+ from sem_aggr.adb, for use elsewhere.
+ * sem_ch3.adb (Analyze_Object_Declaration): Use Choice_List.
+ * sem_aggr.adb (Resolve_Array_Aggregate): Remove
+ Iterated_Component_Present.
+ * exp_aggr.adb: Use Choice_List throughout, to handle
+ Iterated_Component_Associations.
+ (Gen_Loop): Generate proper loop for an
+ Iterated_Component_Association: loop variable has the identifier
+ of the original association. Generate a loop even for a single
+ component choice, in order to make loop parameter visible in
+ expression.
+ (Flatten): An Iterated_Component_Association is not static.
+
+2017-01-13 Yannick Moy <moy@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Op_Expon): Ensure that the value of
+ float exponentiation for statically known small negative values
+ is the reciprocal of the exponentiation for the opposite value
+ of the exponent.
+ * s-exnllf.adb (Exn_Float, Exn_Long_Float, Exn_Long_Long_Float):
+ Ensure that the value of float exponentiation for negative values
+ is the reciprocal of the exponentiation for the opposite value
+ of the exponent.
+ * inline.adb (Expand_Inlined_Call): Fix the count
+ for the number of generated gotos.
+
+2017-01-13 Yannick Moy <moy@adacore.com>
+
+ * inline.adb: Code cleanup.
+ * sem_util.adb (Is_OK_Volatile_Context): Add
+ expression in delay statement as OK for volatile context.
+
+2017-01-13 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_aggr.adb (Resolve_Array_Aggregate): In normal compilation
+ mode a choice that is a subtype with a static predicate is
+ replaced by the values it covers. This transformation must not
+ be performed in ASIS mode, to preserve the source for analysis.
+
+2017-01-13 Justin Squirek <squirek@adacore.com>
+
+ * nlists.ads: Correct minor typo.
+
+2017-01-13 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_ch13.adb: Minor reformatting and typo fix.
+
+2017-01-13 Ed Schonberg <schonberg@adacore.com>
+
+ * par-ch4.adb (P_Aggregate_Or_Parent_Expr): An
+ Iterated_Component_Association is a named association in an
+ array aggregate.
+ * sem_aggr.adb (Resolve_Iterated_Component_Association): New
+ procedure, subsidiary of Resolve_Array_Aggregate, to analyze
+ and resolve the discrete choices and the expression of the
+ new construct.
+ * sinfo.adb, sinfo.ads: In analogy with N_Component_Association,
+ Loop_Actions and Box_Present are attributes of
+ N_Iterated_Component_Association nodes. Box_Present is always
+ False in this case.
+ * sprint.adb (Sprint_Node): An Iterated_Component_Association
+ has a Discrete_Choices list, as specified in the RM. A
+ Component_Association for aggregate uses instead a Choices list.
+ We have to live with this small inconsistency because the new
+ construct also has a defining identifier, and there is no way
+ to merge the two node structures.
+
+2017-01-13 Yannick Moy <moy@adacore.com>
+
+ * inline.adb (Remove_Aspects_And_Pragmas): Add Unused to the
+ list of pragmas to remove. Remove pragmas from the list of
+ statements in the body to inline.
+ * namet.adb, namet.ads (Nam_In): New version with 12 parameters.
+
+2017-01-13 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Resolve_Aspects): New procedure, subsidiary of
+ Analyze_Declarations, to analyze and resolve the expressions of
+ aspect specifications in the current declarative list, so that
+ the expressions have proper entity and type info. This is needed
+ for ASIS when there is no subsequent expansion to generate this
+ semantic information.
+ * sem_ch13.adb (Check_Aspect_At_End_Of_Declarations): Use Etype of
+ original expression, to suppress cascaded errors when expression
+ has been constant-folded.
+ (Resolve_Aspect_Expressions, Resolve_Name): Preserve entities in
+ ASIS mode, because there is no subsequent expansion to decorate
+ the tree.
+
+2017-01-13 Yannick Moy <moy@adacore.com>
+
+ * inline.adb, inline.ads (Call_Can_Be_Inlined_In_GNATprove_Mode):
+ New function to detect when a call may be inlined or not in
+ GNATprove mode.
+ (Expand_Inlined_Call): Ensure that a temporary
+ is always created in the cases where a type conversion may be
+ needed on an input parameter in GNATprove mode, so that GNATprove
+ sees the check to perform.
+ * sem_res.adb (Resolve_Call): In GNATprove mode, skip inlining
+ when not applicable due to actual requiring type conversion
+ with possible check but no temporary value can be copied for
+ GNATprove to see the check.
+
+2017-01-13 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_aggr.adb, par_sco.adb, s-osprim-mingw.adb, exp_ch5.adb,
+ exp_prag.adb, sem_ch3.adb, xr_tabls.adb, lib-xref-spark_specific.adb,
+ layout.adb, sem_dist.adb, exp_spark.adb, exp_ch7.adb, gnatcmd.adb,
+ exp_util.adb, prj-proc.adb, sem_aux.adb, comperr.adb, g-memdum.adb,
+ exp_attr.adb, s-intman-solaris.adb, exp_ch9.adb, make.adb, live.adb,
+ g-sercom-linux.adb, sem_dim.adb, mlib-prj.adb, s-intman-posix.adb,
+ sem_ch9.adb, sem_ch10.adb, prep.adb, einfo.adb, scng.adb, checks.adb,
+ prj-strt.adb, sem_prag.adb, eval_fat.adb, sem_ch12.adb, sem.adb,
+ a-numaux-x86.adb, a-stwifi.adb, i-cobol.adb, prj.adb,
+ get_spark_xrefs.adb, s-tasini.adb, rtsfind.adb, freeze.adb,
+ g-arrspl.adb, par-ch4.adb, sem_util.adb, sem_res.adb, expander.adb,
+ sem_attr.adb, exp_dbug.adb, prj-pp.adb, a-stzfix.adb, s-interr.adb,
+ s-wchcnv.adb, switch-m.adb, gnat1drv.adb, sinput-l.adb, stylesw.adb,
+ contracts.adb, s-intman-android.adb, g-expect.adb, exp_ch4.adb,
+ g-comlin.adb, errout.adb, sinput.adb, s-exctra.adb, repinfo.adb,
+ g-spipat.adb, g-debpoo.adb, exp_ch6.adb, sem_ch4.adb, exp_ch13.adb,
+ a-wtedit.adb, validsw.adb, pprint.adb, widechar.adb, makeutl.adb,
+ ali.adb, set_targ.adb, sem_mech.adb, sem_ch6.adb, gnatdll.adb,
+ get_scos.adb, g-pehage.adb, s-tratas-default.adb, gnatbind.adb,
+ prj-dect.adb, g-socthi-mingw.adb, par-prag.adb, prj-nmsc.adb,
+ exp_disp.adb, par-ch12.adb, binde.adb, sem_ch8.adb,
+ s-tfsetr-default.adb, s-regexp.adb, gprep.adb, s-tpobop.adb,
+ a-teioed.adb, sem_warn.adb, sem_eval.adb, g-awk.adb, s-io.adb,
+ a-ztedit.adb, xoscons.adb, exp_intr.adb, sem_cat.adb, sprint.adb,
+ g-socket.adb, exp_dist.adb, sem_ch13.adb, s-tfsetr-vxworks.adb,
+ par-ch3.adb, treepr.adb, g-forstr.adb, g-catiio.adb, par-ch5.adb,
+ uname.adb, osint.adb, exp_ch3.adb, prj-env.adb, a-strfix.adb,
+ a-stzsup.adb, prj-tree.adb, s-fileio.adb: Update all eligible case
+ statements to reflect the new style for case alternatives. Various
+ code clean up and reformatting.
+
+2017-01-13 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_util.adb: Minor reformatting.
+
+2017-01-13 Yannick Moy <moy@adacore.com>
+
+ * exp_spark.adb: Code cleanup.
+ * sem_ch9.adb (Analyze_Delay_Until): Resolve
+ expression so that calls are identified as such inside delay
+ until.
+
+2017-01-13 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_util.adb (Insert_Actions): Handle Iterated_Component_Association.
+ * par-ch3.adb (P_Discrete_Choice_List): An
+ Iterated_Component_Association is an array aggregate component.
+ * par-ch4.adb (P_Iterated_Component_Association): New procedure.
+ (Is_Quantified_Expression): New function that performs a lookahead
+ to distinguish quantified expressions from iterated component
+ associations.
+ (P_Aggregate_Or_Paren_Expr): Recognize iterated component
+ associations.
+ (P_Unparen_Cond_Case_Quant_Expression, P_Primary): Ditto.
+ * sem.adb (Analyze): Handle Iterated_Component_Association.
+ * sem_aggr.adb (Resolve_Array_Aggregate): Dummy handling of iterated
+ component associations.
+ * sinfo.ads, sinfo.adb: Entries for for
+ N_Iterated_Component_Association and its fields.
+ * sprint.adb (Sprint_Node_Actual): Handle
+ N_Iterated_Component_Association.
+
+2017-01-13 Justin Squirek <squirek@adacore.com>
+
+ * sem_ch12.adb (Analyze_Package_Instantiation): Move disabiling
+ of the style check until after preanalysis of acutals.
+
+2017-01-13 Yannick Moy <moy@adacore.com>
+
+ * sem_ch13.adb: Minor reformatting.
+ * par-ch11.adb: minor style fix in whitespace
+ * gnatbind.adb (Gnatbind): Scope of Std_Lib_File
+ reduced to Add_Artificial_ALI_File; style fix in declaration of
+ Text; grammar fix in comment.
+ * osint-c.adb (Read_Library_Info): strip trailing NUL from result.
+ * freeze.adb: Cleanup to pass pragma instead of
+ expression to call.
+ * exp_spark.adb (Expand_SPARK_Attribute_Reference): New procedure to
+ replace System'To_Address by equivalent call.
+
+2017-01-13 Arnaud Charlet <charlet@adacore.com>
+
+ * bindusg.adb: Improve usage output for -f switch.
+
+2017-01-13 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * frontend.adb, freeze.adb, sem_res.adb, sem_attr.adb, sem_ch8.adb:
+ Minor reformatting.
+
+2017-01-13 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch13.adb (Is_Predicate_Static): Following the intent of the RM,
+ treat comparisons on strings as legal in a Static_Predicate.
+ (Is_Predicate_Static, Is_Type_Ref): Predicate also returns true on
+ a function call that is the expansion of a string comparison.The
+ function call is built when compiling the corresponding predicate
+ function, but the expression has been found legal as a static
+ predicate during earlier analysis.
+ * sem_eval.adb (Real_Or_String_Static_Predicate_Matches): Handle
+ properly a function call that is the expansion of a string
+ comparison operation, in order to recover the Static_Predicate
+ expression and apply it to a static argument when needed.
+
+2017-01-13 Tristan Gingold <gingold@adacore.com>
+
+ * s-mmap.adb, s-mmap.ads (Open_Read_No_Exception): New function.
+ (Open_Read): Re-implement using Open_Read_No_Exception.
+ (Open_Write): Raise exception in case of error.
+ * s-mmosin-mingw.adb (Open_Common): Do not raise exception.
+ * s-mmosin-unix.adb (Open_Read, Open_Write): Do not
+ reaise exception.
+ * s-mmosin-mingw.ads, s-mmosin-unix.ads (Open_Read): Adjust comment.
+
+2017-01-13 Yannick Moy <moy@adacore.com>
+
+ * checks.adb: Code cleanup.
+
+2017-01-13 Yannick Moy <moy@adacore.com>
+
+ * freeze.adb (Check_Inherited_Conditions): Use analyzed pragma
+ expression instead of unanalyzed aspect expression for checking
+ the validity of inheriting an operation. Also copy the expression
+ being passing it to Build_Class_Wide_Expression, as this call
+ modifies its argument.
+ * sem_util.ads Fix comment to reference correct function name
+ New_Copy_Tree.
+
+2017-01-13 Javier Miranda <miranda@adacore.com>
+
+ * sem_res.adb (Resolve_Generalized_Indexing): Compiling in ASIS mode,
+ when we propagate information about the indexes back to the original
+ indexing mode and the prefix of the index is a function call, do not
+ remove any parameter from such call.
+
+2017-01-13 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_ch6.ads (Needs_BIP_Finalization_Master): Update comment.
+ * exp_ch6.adb (Needs_BIP_Finalization_Master): Return True for
+ a build-in-place function whose result type is tagged.
+
+2017-01-13 Yannick Moy <moy@adacore.com>
+
+ * sem_ch8.adb (Analyze_Subprogram_Renaming.Build_Class_Wide_Wrapper):
+ Do not generate a wrapper when the only candidate is a class-wide
+ subprogram.
+ (Analyze_Subprogram_Renaming): Do not freeze the renaming or renamed
+ inside a generic context.
+
+2017-01-13 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_util.adb (Add_Inherited_Tagged_DIC):
+ Pass the object parameters of both the parent and the derived
+ type DIC procedure to the reference replacement circuitry.
+ (Find_DIC_Type): Modify the circuitry to present the partial
+ view of a private type in case the private type defines its own
+ DIC pragma.
+ (Replace_Object_And_Primitive_References): Add two
+ optional formal parameters. Update the comment on usage. Update
+ the replacement of references to object parameters.
+
+2017-01-13 Gary Dismukes <dismukes@adacore.com>
+
+ * einfo.adb, sem_ch6.adb, atree.adb: Minor reformatting and typo fix.
+
+2017-01-13 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_res.adb (Resolve_Actuals): Apply Scalar_Range_Check to
+ an out parameter that is a type conversion, independently of th
+ range check that may apply to the expression of the conversion,
+ for use in GNATProve.
+
+2017-01-13 Yannick Moy <moy@adacore.com>
+
+ * gnat1drv.adb (Gnat1drv): Move the implicit with for System in
+ GNATprove_Mode here to Frontend.
+ * frontend.adb (Frontend): Move the implicit with for System
+ in GNATprove_Mode here as it ismore correct this way; the old
+ place only worked by chance, since there were no overloaded names.
+ * rtsfind.ads (RE_Id, RE_Unit_Table): Add RE_Tasking_State.
+ * sem_attr.adb (Analyze_Attribute): In GNATprove_Mode, for the
+ four attributes identified in SRM 9(18), add an implicit with
+ to Ada.Task_Identification.
+ * sem_ch8.adb (Analyze_Subprogram_Renaming.Build_Class_Wide_Wrapper):
+ Deal specially with the wrapper introduced for AI05-0071 in GNATprove
+ mode.
+ * checks.adb (Apply_Discriminant_Check,
+ Apply_Selected_Length_Checks, Apply_Selected_Range_Checks):
+ In GNATprove mode, we do not apply the checks, but we still
+ analyze the expression to possibly issue errors on SPARK
+ code when a run-time error can be detected at compile time.
+ (Selected_Length_Checks, Selected_Range_Checks): Perform analysis
+ in GNATprove mode.
+
+2017-01-13 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * expander.adb (Expand): Add a warning about using return
+ statements in Ghost management code.
+ * exp_ch3.adb (Freeze_Type): Add a warning about using return
+ statements in Ghost management code.
+ * exp_ch7.adb (Build_Invariant_Procedure_Body,
+ Build_Invariant_Procedure_Declaration): Add a warning about
+ using return statements in Ghost management code.
+ * exp_disp.adb (Make_DT): Add a warning about using return
+ statements in Ghost management code.
+ * exp_util.adb (Build_DIC_Procedure_Body,
+ Build_DIC_Procedure_Declaration, Make_Predicated_Call): Add a
+ warning about using return statements in Ghost management code.
+ * freeze.adb (Freeze_Entity): Add a warning about using return
+ statements in Ghost management code.
+ * sem.adb (Analyze, Do_Analyze): Add a warning about using return
+ statements in Ghost management code.
+ * sem_ch3.adb (Analyze_Object_Declaration, Process_Full_View): Add
+ a warning about using return statements in Ghost management code.
+ * sem_ch5.adb (Analyze_Assignment): Add a warning about using
+ return statements in Ghost management code.
+ * sem_ch6.adb (Analyze_Procedure_Call,
+ Analyze_Subprogram_Body_Helper): Add a warning about using return
+ statements in Ghost management code.
+ * sem_ch7.adb (Analyze_Package_Body_Helper): Add a warning about
+ using return statements in Ghost management code.
+ * sem_ch12.adb (Analyze_Package_Instantiation,
+ Analyze_Subprogram_Instantiation, Instantiate_Package_Body,
+ Instantiate_Subprogram_Body): Add a warning about using return
+ statements in Ghost management code.
+ * sem_ch13.adb (Build_Predicate_Functions,
+ Build_Predicate_Function_Declarations): Add a warning about
+ using return statements in Ghost management code.
+ * sem_prag.adb (Analyze_Contract_Cases_In_Decl_Part,
+ Analyze_Initial_Condition_In_Decl_Part, Analyze_Pragma,
+ Analyze_Pre_Post_Condition_In_Decl_Part): Add a warning about
+ using return statements in Ghost management code.
+
+2017-01-13 Tristan Gingold <gingold@adacore.com>
+
+ * s-mmosin-mingw.adb: Fix pragma import.
+
+2017-01-13 Arnaud Charlet <charlet@adacore.com>
+
+ * gnat1drv.adb (Adjust_Global_Switches): Ignore -gnateE in
+ codepeer mode.
+
+2017-01-13 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * atree.adb (Allocate_Initialize_Node): A newly created node is
+ no longer marked as Ghost at this level.
+ (Mark_New_Ghost_Node): New routine.
+ (New_Copy): Mark the copy as Ghost.
+ (New_Entity): Mark the entity as Ghost.
+ (New_Node): Mark the node as Ghost.
+ * einfo.adb (Is_Checked_Ghost_Entity): This attribute can now
+ apply to unanalyzed entities.
+ (Is_Ignored_Ghost_Entity): This attribute can now apply to unanalyzed
+ entities.
+ (Set_Is_Checked_Ghost_Entity): This attribute now
+ applies to all entities as well as unanalyzed entities.
+ (Set_Is_Ignored_Ghost_Entity): This attribute now applies to
+ all entities as well as unanalyzed entities.
+ * expander.adb Add with and use clauses for Ghost.
+ (Expand): Install and revert the Ghost region associated with the node
+ being expanded.
+ * exp_ch3.adb (Expand_Freeze_Array_Type): Remove all Ghost-related code.
+ (Expand_Freeze_Class_Wide_Type): Remoe all Ghost-related code.
+ (Expand_Freeze_Enumeration_Type): Remove all Ghost-related code.
+ (Expand_Freeze_Record_Type): Remove all Ghost-related code.
+ (Freeze_Type): Install and revert the Ghost region associated
+ with the type being frozen.
+ * exp_ch5.adb Remove with and use clauses for Ghost.
+ (Expand_N_Assignment_Statement): Remove all Ghost-related code.
+ * exp_ch6.adb Remove with and use clauses for Ghost.
+ (Expand_N_Procedure_Call_Statement): Remove all Ghost-relatd code.
+ (Expand_N_Subprogram_Body): Remove all Ghost-related code.
+ * exp_ch7.adb (Build_Invariant_Procedure_Body): Install and revert the
+ Ghost region of the working type.
+ (Build_Invariant_Procedure_Declaration): Install and revert
+ the Ghost region of the working type.
+ (Expand_N_Package_Body): Remove all Ghost-related code.
+ * exp_ch8.adb Remove with and use clauses for Ghost.
+ (Expand_N_Exception_Renaming_Declaration): Remove all Ghost-related
+ code.
+ (Expand_N_Object_Renaming_Declaration): Remove all Ghost-related code.
+ (Expand_N_Package_Renaming_Declaration): Remove all Ghost-related code.
+ (Expand_N_Subprogram_Renaming_Declaration): Remove all Ghost-related
+ code.
+ * exp_ch13.adb Remove with and use clauses for Ghost.
+ (Expand_N_Freeze_Entity): Remove all Ghost-related code.
+ * exp_disp.adb (Make_DT): Install and revert the Ghost region of
+ the tagged type. Move the generation of various entities within
+ the Ghost region of the type.
+ * exp_prag.adb Remove with and use clauses for Ghost.
+ (Expand_Pragma_Check): Remove all Ghost-related code.
+ (Expand_Pragma_Contract_Cases): Remove all Ghost-related code.
+ (Expand_Pragma_Initial_Condition): Remove all Ghost-related code.
+ (Expand_Pragma_Loop_Variant): Remove all Ghost-related code.
+ * exp_util.adb (Build_DIC_Procedure_Body): Install
+ and revert the Ghost region of the working types.
+ (Build_DIC_Procedure_Declaration): Install and revert the
+ Ghost region of the working type.
+ (Make_Invariant_Call): Install and revert the Ghost region of the
+ associated type.
+ (Make_Predicate_Call): Reimplemented. Install and revert the
+ Ghost region of the associated type.
+ * freeze.adb (Freeze_Entity): Install and revert the Ghost region
+ of the entity being frozen.
+ (New_Freeze_Node): Removed.
+ * ghost.adb Remove with and use clauses for Opt.
+ (Check_Ghost_Completion): Update the parameter profile
+ and all references to formal parameters.
+ (Ghost_Entity): Update the comment on usage.
+ (Install_Ghost_Mode): New routines.
+ (Is_Ghost_Assignment): New routine.
+ (Is_Ghost_Declaration): New routine.
+ (Is_Ghost_Pragma): New routine.
+ (Is_Ghost_Procedure_Call): New routine.
+ (Is_Ghost_Renaming): Removed.
+ (Is_OK_Declaration): Reimplemented.
+ (Is_OK_Pragma): Reimplemented.
+ (Is_OK_Statement): Reimplemented.
+ (Is_Subject_To_Ghost): Update the comment on usage.
+ (Mark_And_Set_Ghost_Assignment): New routine.
+ (Mark_And_Set_Ghost_Body): New routine.
+ (Mark_And_Set_Ghost_Completion): New routine.
+ (Mark_And_Set_Ghost_Declaration): New routine.
+ (Mark_And_Set_Ghost_Instantiation): New routine.
+ (Mark_And_Set_Ghost_Procedure_Call): New routine.
+ (Mark_Full_View_As_Ghost): Removed.
+ (Mark_Ghost_Declaration_Or_Body): New routine.
+ (Mark_Ghost_Pragma): New routine.
+ (Mark_Ghost_Renaming): New routine.
+ (Mark_Pragma_As_Ghost): Removed.
+ (Mark_Renaming_As_Ghost): Removed.
+ (Propagate_Ignored_Ghost_Code): Update the comment on usage.
+ (Prune_Node): Freeze nodes no longer need special pruning, they
+ are processed by the general ignored Ghost code mechanism.
+ (Restore_Ghost_Mode): New routine.
+ (Set_Ghost_Mode): Reimplemented.
+ (Set_Ghost_Mode_From_Entity): Removed.
+ * ghost.ads Add with and use clauses for Ghost.
+ (Check_Ghost_Completion): Update the parameter profile
+ along with the comment on usage.
+ (Install_Ghost_Mode): New routine.
+ (Is_Ghost_Assignment): New routine.
+ (Is_Ghost_Declaration): New routine.
+ (Is_Ghost_Pragma): New routine.
+ (Is_Ghost_Procedure_Call): New routine.
+ (Mark_And_Set_Ghost_Assignment): New routine.
+ (Mark_And_Set_Ghost_Body): New routine.
+ (Mark_And_Set_Ghost_Completion): New routine.
+ (Mark_And_Set_Ghost_Declaration): New routine.
+ (Mark_And_Set_Ghost_Instantiation): New routine.
+ (Mark_And_Set_Ghost_Procedure_Call): New routine.
+ (Mark_Full_View_As_Ghost): Removed.
+ (Mark_Ghost_Pragma): New routine.
+ (Mark_Ghost_Renaming): New routine.
+ (Mark_Pragma_As_Ghost): Removed.
+ (Mark_Renaming_As_Ghost): Removed.
+ (Restore_Ghost_Mode): New routine.
+ (Set_Ghost_Mode): Redefined.
+ (Set_Ghost_Mode_From_Entity): Removed.
+ * sem.adb (Analyze): Install and revert the Ghost region of the
+ node being analyzed.
+ (Do_Analyze): Change the way a clean Ghost
+ region is installed and reverted.
+ * sem_ch3.adb (Analyze_Full_Type_Declaration): Remove
+ all Ghost-related code.
+ (Analyze_Incomplete_Type_Decl): Remove all Ghost-related code.
+ (Analyze_Number_Declaration): Remove all Ghost-related code.
+ (Analyze_Object_Declaration): Install and revert the Ghost region of
+ a deferred object declaration's completion.
+ (Array_Type_Declaration): Remove all Ghost-related code.
+ (Build_Derived_Type): Update the comment on
+ the propagation of Ghost attributes from a parent to a derived type.
+ (Derive_Subprogram): Remove all Ghost-related code.
+ (Make_Class_Wide_Type): Remove all Ghost-related code.
+ (Make_Implicit_Base): Remove all Ghost-related code.
+ (Process_Full_View): Install and revert the Ghost region of
+ the partial view. There is no longer need to check the Ghost
+ completion here.
+ * sem_ch5.adb (Analyze_Assignment): Install and revert the Ghost
+ region of the left hand side.
+ * sem_ch6.adb (Analyze_Abstract_Subprogram_Declaration): Remove
+ all Ghost-related code.
+ (Analyze_Expression_Function): Remove all Ghost-related code.
+ (Analyze_Generic_Subprogram_Body): Remove all Ghost-related code.
+ (Analyze_Procedure_Call): Install and revert the Ghost region of
+ the procedure being called.
+ (Analyze_Subprogram_Body_Helper): Install and revert the Ghost
+ region of the spec or body.
+ (Analyze_Subprogram_Declaration): Remove all Ghost-related code.
+ (Build_Subprogram_Declaration): Remove all Ghost-related code.
+ (Find_Corresponding_Spec): Remove all Ghost-related code.
+ (Process_Formals): Remove all Ghost-related code.
+ * sem_ch7.adb (Analyze_Package_Body_Helper): Install and revert
+ the Ghost region of the spec.
+ (Analyze_Package_Declaration): Remove all Ghost-related code.
+ * sem_ch8.adb (Analyze_Exception_Renaming): Mark a renaming as
+ Ghost when it aliases a Ghost entity.
+ (Analyze_Generic_Renaming): Mark a renaming as Ghost when it aliases
+ a Ghost entity.
+ (Analyze_Object_Renaming): Mark a renaming as Ghost when
+ it aliases a Ghost entity.
+ (Analyze_Package_Renaming): Mark a renaming as Ghost when it aliases
+ a Ghost entity.
+ (Analyze_Subprogram_Renaming): Mark a renaming as Ghost when it
+ aliases a Ghost entity.
+ * sem_ch11.adb Remove with and use clauses for Ghost.
+ (Analyze_Exception_Declaration): Remove all Ghost-related code.
+ * sem_ch12.adb (Analyze_Generic_Package_Declaration): Remove all
+ Ghost-related code.
+ (Analyze_Generic_Subprogram_Declaration): Remove all Ghost-related
+ code.
+ (Analyze_Package_Instantiation): Install and revert the Ghost region
+ of the package instantiation.
+ (Analyze_Subprogram_Instantiation): Install
+ and revert the Ghost region of the subprogram instantiation.
+ (Instantiate_Package_Body): Code clean up. Install and revert the
+ Ghost region of the package body.
+ (Instantiate_Subprogram_Body): Code clean up. Install and revert the
+ Ghost region of the subprogram body.
+ * sem_ch13.adb (Build_Predicate_Functions): Install
+ and revert the Ghost region of the related type.
+ (Build_Predicate_Function_Declaration): Code clean up. Install
+ and rever the Ghost region of the related type.
+ * sem_prag.adb (Analyze_Contract_Cases_In_Decl_Part):
+ Install and revert the Ghost region of the pragma.
+ (Analyze_Initial_Condition_In_Decl_Part): Install and revert the
+ Ghost region of the pragma.
+ (Analyze_Pragma): Install and revert the Ghost region of various
+ pragmas. Mark a pragma as Ghost when it is related to a Ghost entity
+ or encloses a Ghost entity.
+ (Analyze_Pre_Post_Condition): Install and revert the Ghost
+ region of the pragma.
+ (Analyze_Pre_Post_Condition_In_Decl_Part): Install and revert the
+ Ghost region of the pragma.
+ * sem_res.adb (Resolve): Remove all Ghost-related code.
+ * sem_util.adb (Is_Declaration): Reimplemented.
+ (Is_Declaration_Other_Than_Renaming): New routine.
+ * sem_util.ads (Is_Declaration_Other_Than_Renaming): New routine.
+ * sinfo.adb (Is_Checked_Ghost_Pragma): New routine.
+ (Is_Ghost_Pragma): Removed.
+ (Is_Ignored_Ghost_Pragma): New routine.
+ (Set_Is_Checked_Ghost_Pragma): New routine.
+ (Set_Is_Ghost_Pragma): Removed.
+ (Set_Is_Ignored_Ghost_Pragma): New routine.
+ * sinfo.ads: Update the documentation on Ghost mode and
+ Ghost regions. New attributes Is_Checked_Ghost_Pragma
+ and Is_Ignored_Ghost_Pragma along with usages in nodes.
+ Remove attribute Is_Ghost_Pragma along with usages in nodes.
+ (Is_Checked_Ghost_Pragma): New routine along with pragma Inline.
+ (Is_Ghost_Pragma): Removed along with pragma Inline.
+ (Is_Ignored_Ghost_Pragma): New routine along with pragma Inline.
+ (Set_Is_Checked_Ghost_Pragma): New routine along with pragma Inline.
+ (Set_Is_Ghost_Pragma): Removed along with pragma Inline.
+ (Set_Is_Ignored_Ghost_Pragma): New routine along with pragma Inline.
+
+2017-01-12 Tristan Gingold <gingold@adacore.com>
+
+ * s-mmap.ads, s-mmap.adb, s-mmosin-unix.ads, s-mmosin-unix.adb,
+ s-mmauni-long.ads, s-mmosin-mingw.ads, s-mmosin-mingw.adb: New files.
+
+2017-01-12 Yannick Moy <moy@adacore.com>
+
+ * errout.adb, errout.ads (Initialize): Factor common treatment
+ in Reset_Warnings.
+ (Reset_Warnings): New procedure to reset counts related to warnings.
+ (Record_Compilation_Errors): New variable to store the presence of an
+ error, used in gnat2why to allow changing the Warning_Mode.
+ (Compilation_Errors): Use new variable Record_Compilation_Errors to
+ store the presence of an error.
+
+2017-01-12 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch13.adb (Analyze_Aspect_Specifications):
+ For Interrupt_Handler and Attach_ Handler aspects, decorate the
+ internally built reference to the protected procedure as coming
+ from sources and force its analysis.
+
+2017-01-12 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Build_Derived_Type): For a scalar derived type,
+ inherit predicates if any from the first_subtype of the parent,
+ not from the anonymous parent type.
+ * sem_eval.adb (Is_Static_Subtype): A type that inherits a dynamic
+ predicate is not a static subtype.
+
+2017-01-12 Gary Dismukes <dismukes@adacore.com>
+
+ * freeze.adb (Check_Suspicious_Convention): New procedure
+ performing a warning check on discriminated record types with
+ convention C or C++. Factored out of procedure Freeze_Record_Type,
+ and changed to only apply to base types (to avoid spurious
+ warnings on subtypes). Minor improvement of warning messages
+ to refer to discriminated rather than variant record types.
+ (Freeze_Record_Type): Remove code for performing a suspicious
+ convention check.
+ (Freeze_Entity): Only call Freeze_Record_Type
+ on types that aren't declared within any enclosing generic units
+ (rather than just excluding the type when the innermost scope
+ is generic). Call Check_Suspicious_Convention whether or not
+ the type is declared within a generic unit.
+ * sem_ch8.adb (In_Generic_Scope): Move this function to Sem_Util.
+ * sem_util.ads, sem_util.adb (In_Generic_Scope): New function (moved
+ from Sem_Ch8).
+
+2017-01-12 Tristan Gingold <gingold@adacore.com>
+
+ * sysdep.c, adaint.c, rtinit.c, ming32.h:
+ (__gnat_current_codepage): Renamed from CurrentCodePage
+ (__gnat_current_ccs_encoding): Renamed from CurrentCCSEncoding
+
+2017-01-12 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Fully_Conformant_Expressions): Handle properly
+ quantified expressions, following AI12-050: the loop parameters
+ of two quantified expressions are conformant if they have the
+ same identifier.
+
+2017-01-12 Arnaud Charlet <charlet@adacore.com>
+
+ * gcc-interface/Makefile.in: Clean up VxWorks targets.
+
+2017-01-12 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute_Reference, case Loop_Entry):
+ Hnadle properly the attribute reference when it appears as part
+ of an expression in another loop aspect.
+
+2017-01-12 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch3.adb (Check_Predicated_Discriminant): New procedure,
+ subsidiary of Build_Initialization_Call, to complete generation
+ of predicate checks on discriminants whose (sub)types have
+ predicates, and to add checks on variants that do not have an
+ others clause.
+ * sem_util.adb (Gather_Components): A missing Others alternative is
+ not an error when the type of the discriminant is a static predicate
+ (and coverage has been checked when analyzing the case statement). A
+ runtime check is generated to verify that a given discriminant
+ satisfies the predicate (RM 3.8.1. (21.1/2)).
+
+2017-01-12 Yannick Moy <moy@adacore.com>
+
+ * gnat1drv.adb (Adjust_Global_Switches): Only
+ perform checking of exception mechanism when generating code.
+
+2017-01-12 Justin Squirek <squirek@adacore.com>
+
+ * exp_ch7.adb (Add_Type_Invariants, Process_Array_Component):
+ Remove handling of access component with invariant.
+ (Build_Invariant_Procedure_Declaration): Remove return on class
+ wide type.
+ * freeze.adb (Freeze_Array_Type, Freeze_Record_Type): Remove
+ conditional exception for component or array so Has_Own_Invariants
+ flag is not falsly set.
+ * sem_ch3.adb (Make_Class_Wide_Type): Initialize copy of class
+ wide type to have no invariant flags.
+
+2017-01-12 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch9.adb, sem_prag.adb, s-tassta.adb, sem_util.adb, s-tarest.adb,
+ sem_ch13.adb: Minor reformatting.
+
+2017-01-12 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_aggr.adb (Build_Record_Aggr_Code): Guard against a missing
+ adjustment primitive when the ancestor type was not properly frozen.
+ (Gen_Assign): Guard against a missing initialization
+ primitive when the component type was not properly frozen.
+ (Initialize_Array_Component): Guard against a missing adjustment
+ primitive when the component type was not properly frozen.
+ (Initialize_Record_Component): Guard against a missing adjustment
+ primitive when the component type was not properly frozen.
+ (Process_Transient_Component_Completion): The transient object may
+ not be finalized when its associated type was not properly frozen.
+ * exp_ch3.adb (Build_Assignment): Guard against a missing
+ adjustment primitive when the component type was not properly frozen.
+ (Build_Initialization_Call): Guard against a missing
+ initialization primitive when the associated type was not properly
+ frozen.
+ (Expand_N_Object_Declaration): Guard against a missing
+ adjustment primitive when the base type was not properly frozen.
+ (Predefined_Primitive_Bodies): Create an empty Deep_Adjust
+ body when there is no adjustment primitive available. Create an
+ empty Deep_Finalize body when there is no finalization primitive
+ available.
+ * exp_ch4.adb (Apply_Accessibility_Check): Guard against a
+ missing finalization primitive when the designated type was
+ not properly frozen.
+ (Expand_N_Allocator): Guard against a missing initialization primitive
+ when the designated type was not properly frozen.
+ * exp_ch5.adb (Make_Tag_Ctrl_Assignment): Add the adjustment call
+ only when the corresponding adjustment primitive is available.
+ * exp_ch7.adb (Build_Adjust_Or_Finalize_Statements): Generate the
+ adjustment/finalization statements only when there is an available
+ primitive to carry out the action.
+ (Build_Initialize_Statements): Generate the initialization/finalization
+ statements only when there is an available primitive to carry out the
+ action.
+ (Make_Adjust_Call): Do not generate a call when the underlying
+ type is not present due to a possible missing full view.
+ (Make_Final_Call): Do not generate a call when the underlying
+ type is not present due to a possible missing full view.
+ (Make_Finalize_Address_Stmts): Generate an empty body when the
+ designated type lacks a finalization primitive.
+ (Make_Init_Call): Do not generate a call when the underlying type is
+ not present due to a possible missing full view.
+ (Process_Component_For_Adjust): Add the adjustment call only when the
+ corresponding adjustment primitive is available.
+ (Process_Component_For_Finalize): Add the finalization call only when
+ the corresponding finalization primitive is available.
+ (Process_Object_Declaration): Use a null statement to emulate a
+ missing call to the finalization primitive of the object type.
+ * exp_ch7.ads (Make_Adjust_Call): Update the comment on usage.
+ (Make_Final_Call): Update the comment on usage.
+ (Make_Init_Call): Update the comment on usage.
+ * exp_util.adb (Build_Transient_Object_Statements): Code reformatting.
+
+2017-01-12 Arnaud Charlet <charlet@adacore.com>
+
+ * einfo.ads: Update documentation of Address_Taken.
+ * sem_attr.adb (Analyze_Access_Attribute, Resolve_Attribute
+ [Access_Attribute]): Only consider 'Access/'Unchecked_Access
+ for subprograms when setting Address_Taken flag.
+
+2017-01-12 Patrick Bernardi <bernardi@adacore.com>
+
+ * sem_ch10.adb (Analyze_With_Clause): Removed code that turned
+ Configurable_Run_Time_Mode off when analysing with'ed predefined
+ libraries.
+
+2017-01-12 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_prag.adb: Minor reformatting.
+ * sem_util.adb (Unique_Entity): fix result for
+ bodies of entry families.
+
+2017-01-12 Justin Squirek <squirek@adacore.com>
+
+ * sem_prag.adb (Analyze_Pragma): Add appropriate calls to
+ Resolve_Suppressible in the pragma Assertion_Policy case.
+ (Resolve_Suppressible): Created this function to factor out
+ common code used to resolve Suppress to either Ignore or Check
+ * snames.ads-tmpl: Add name for Suppressible.
+
+2017-01-12 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_ch9.adb, s-secsta.adb, snames.ads-tmpl, exp_ch3.adb: Minor
+ reformatting.
+ * debug.adb: Minor comment fixes.
+
+2017-01-12 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_util.adb (Unique_Entity): For concurrent
+ bodies that are defined with stubs and complete a declaration
+ of a single concurrent object return the entity of an implicit
+ concurrent type, not the entity of the anonymous concurrent
+ object.
+ * debug.adb: -gnatd.J is no longer used.
+ * make.adb (Globalize): Removed, no longer used.
+ * sem_ch9.adb: minor typo in comment for entry index
+
+2017-01-12 Patrick Bernardi <bernardi@adacore.com>
+
+ * aspect.adb, aspect.ads: Added new aspect Secondary_Stack_Size.
+ * exp_ch3.adb (Build_Init_Statements): As part of initialising
+ the value record of a task, set its _Secondary_Stack_Size field
+ if present.
+ * exp_ch9.adb (Expand_N_Task_Type_Declaration): Create
+ a _Secondary_Stack_Size field in the value record of
+ the task if a Secondary_Stack_Size rep item is present.
+ (Make_Task_Create_Call): Include secondary stack size
+ parameter. If No_Secondary_Stack restriction is in place, passes
+ stack size of 0.
+ * par-prag.adb, sem_prag.adb, sem_prag.ads: Added new pragma
+ Secondary_Stack_Size.
+ * s-secsta.adb, s-secsta.ads (Minimum_Secondary_Stack_Size): New
+ function to define the overhead of the secondary stack.
+ * s-tarest.adb (Create_Restricted_Task,
+ Create_Restricted_Task_Sequential): Functions now include
+ Secondary_Stack_Size parameter to pass to Initialize_ATCB.
+ * s-tarest.adb (Create_Restricted_Task,
+ Create_Restricted_Task_Sequential): Calls to Initialize_ATCB now
+ include Secondary_Stack_Size parameter.
+ (Task_Wrapper): Secondary stack now allocated to the size specified by
+ the Secondary_Stack_Size parameter in the task's ATCB.
+ * s-taskin.adb, s-taskin.adb (Common_ATCB, Initialize_ATCB): New
+ Secondary_Stack_Size component.
+ * s-tassta.adb, s-tassta.ads (Create_Restricted_Task,
+ Create_Restricted_Task_Sequential): Function now include
+ Secondary_Stack_Size parameter.
+ (Task_Wrapper): Secondary stack now allocated to the size
+ specified by the Secondary_Stack_Size parameter in the task's
+ ATCB.
+ * s-tproft.adb (Register_Foreign_Thread): Amended Initialize_ATCB call
+ to include Secondary_Stack_Size parameter.
+ * sem_ch13.adb (Analyze_Aspect_Specification): Add support for
+ Secondary_Stack_Size aspect, turning the aspect into its corresponding
+ internal attribute.
+ (Analyze_Attribute_Definition): Process Secondary_Stack_Size attribute.
+ * snames.adb-tmpl, snames.ads-tmpl: Added names
+ Name_Secondary_Stack_Size, Name_uSecondary_Stack_Size,
+ Attribute_Secondary_Stack_Size and Pragma_Secondary_Stack_Size.
+
+2017-01-12 Yannick Moy <moy@adacore.com>
+
+ * exp_spark.adb (Expand_SPARK_Potential_Renaming): Fix sloc of copied
+ subtree.
+
+2017-01-12 Justin Squirek <squirek@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference):
+ Fix Finalization_Size case by properly resolving the type after
+ rewritting the node.
+
+2017-01-12 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_util.adb (Build_DIC_Procedure_Body): Semi-insert the body into
+ the tree.
+ (Build_DIC_Procedure_Declaration): Semi-insert the body into the tree.
+ * binde.adb, exp_ch5.adb, sem_type.adb, sem.ads, sem_res.adb,
+ exp_sel.ads: Minor reformatting.
+
+2017-01-12 Justin Squirek <squirek@adacore.com>
+
+ * exp_ch6.adb (Expand_Call): Add guard to prevent
+ invariant checks from being created for internally generated
+ subprograms.
+
+2017-01-12 Bob Duff <duff@adacore.com>
+
+ * lib-writ.ads: Remove incorrect comment.
+
+2017-01-12 Javier Miranda <miranda@adacore.com>
+
+ * debug.adb (-gnatd.K): Enable generation of contract-only
+ procedures in CodePeer mode.
+ * contracts.adb (Build_And_Analyze_Contract_Only_Subprograms):
+ New subprogram.
+ (Analyze_Contracts): Generate contract-only procedures if -gnatdK is
+ set.
+ * scil_ll.ads, scil_ll.adb (Get_Contract_Only_Body_Name): New
+ subprogram.
+ (Get_Contract_Only_Missing_Body_Name): New subprogram.
+ (Get_Contract_Only_Body): New subprogram.
+ (Set_Contract_Only_Body): New subprogram.
+ (Is_Contract_Only_Body): New subprogram.
+ (Set_Is_Contract_Only_Body): New subprogram.
+ (SCIL_Nodes): Replace table by hash-table.
+
+2017-01-12 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch6.adb: Minor reformatting.
+ * spark_xrefs.ads: minor cleanup of comments for SPARK xrefs
+
+2017-01-12 Bob Duff <duff@adacore.com>
+
+ * binde.adb (Forced): New reason for a dependence.
+ (Force_Elab_Order): Implementation of the new switch.
+ * binde.ads: Minor comment fixes.
+ * bindusg.adb: Add -f switch. Apparently, there was an -f switch
+ long ago that is no longer supported; removed comment about that.
+ * opt.ads (Force_Elab_Order_File): Name of file specified for
+ -f switch.
+ * switch-b.adb: Parse -f switch.
+
+2017-01-12 Justin Squirek <squirek@adacore.com>
+
+ * exp_ch6.adb (Check_View_Conversion): Created this function
+ to properly chain calls to check type invariants that may be
+ present in a subprogram call after the subprogram.
+ (Expand_Call): Add a conditional to identify when a view conversion
+ needs to be checked.
+ * nlists.adb, nlists.ads (Prepend_New): New routine.
+ (Prepend_New_To): New routine.
+
+2017-01-12 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sinfo.ads: Minor reformatting.
+
+2017-01-12 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_util.adb, exp_util.ads, einfo.ads: Minor typo fixes and
+ reformatting.
+
+2017-01-12 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch6.adb (Make_Build_In_Place_Call_In_Anonymous_Context): Add new
+ variable Definite. Create a local object and pass its 'Access to the
+ BIP function when the result type is either definite or it does not
+ require any finalization or secondary stack management.
+
+2017-01-12 Bob Duff <duff@adacore.com>
+
+ * contracts.adb, einfo.adb, errout.adb, exp_attr.adb,
+ exp_ch3.adb, exp_ch7.adb, exp_ch9.adb, exp_prag.adb, freeze.adb,
+ frontend.adb, ghost.adb, inline.adb, lib-writ.adb, lib-xref.adb,
+ par.adb, par-ch10.adb, par-ch2.adb, par-prag.adb, par_sco.adb,
+ sem_attr.adb, sem_aux.adb, sem_ch10.adb, sem_ch12.adb,
+ sem_ch13.adb, sem_ch6.adb, sem_ch8.adb, sem_ch9.adb, sem_elab.adb,
+ sem_prag.adb, sem_res.adb, sem_util.adb, sem_util.ads,
+ sem_warn.adb, sinfo.adb, sinfo.ads, sprint.adb (Pragma_Name):
+ Change name to Pragma_Name_Unmapped.
+ (Pragma_Name_Mapped): Change name to Pragma_Name.
+ This is because the "mapped" version should be the usual case.
+
+2017-01-09 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * einfo.ads, einfo.adb: Remove uses of flags Has_Default_Init_Cond,
+ Is_Default_Init_Cond_Procedure, and
+ Has_Inherited_Default_Init_Cond. Add uses of flags
+ Has_Own_DIC, Is_DIC_Procedure, and Has_Inherited_DIC.
+ (Default_Init_Cond_Procedure): Removed.
+ (DIC_Procedure): New routine.
+ (Has_Default_Init_Cond): Removed.
+ (Has_DIC): New routine.
+ (Has_Inheritable_Invariants): The attribute applies to the base type.
+ (Has_Inherited_Default_Init_Cond): Removed.
+ (Has_Inherited_DIC): New routine.
+ (Has_Inherited_Invariants): The attribute applies to the base type.
+ (Has_Own_DIC): New routine.
+ (Has_Own_Invariants): The attribute applies to the base type.
+ (Is_Default_Init_Cond_Procedure): Removed.
+ (Is_DIC_Procedure): New routine.
+ (Set_Default_Init_Cond_Procedure): Removed.
+ (Set_DIC_Procedure): New routine.
+ (Set_Has_Default_Init_Cond): Removed.
+ (Set_Has_Inheritable_Invariants): The attribute applies
+ to the base type.
+ (Set_Has_Inherited_Default_Init_Cond): Removed.
+ (Set_Has_Inherited_DIC): New routine.
+ (Set_Has_Inherited_Invariants): The attribute applies to the base type.
+ (Set_Has_Own_DIC): New routine.
+ (Set_Has_Own_Invariants): The attribute applies to the base type.
+ (Set_Is_Default_Init_Cond_Procedure): Removed.
+ (Set_Is_DIC_Procedure): New routine.
+ (Write_Entity_Flags): Update the output of all flags related to
+ default initial condition.
+ * exp_ch3.adb (Expand_N_Object_Declaration): Update the generation
+ of the call to the DIC procedure.
+ (Freeze_Type): Generate the body of the DIC procedure.
+ * exp_ch7.adb (Build_Invariant_Procedure_Body): Replace
+ all occurrences of Create_Append with Append_New_To. Do
+ not generate an invariant procedure for a class-wide type.
+ The generated body acts as a freeze action of the working type.
+ (Build_Invariant_Procedure_Declaration): Do not generate an
+ invariant procedure for a class-wide type.
+ (Create_Append): Removed.
+ * exp_util.adb: Add with and use clauses for Sem_Ch3, sem_ch6,
+ sem_Ch12, Sem_Disp, and GNAT.HTable. Move the handling of
+ class-wide pre/postcondition description and data structures from
+ Sem_Prag.
+ (Build_Class_Wide_Expression): Moved from Sem_Prag.
+ (Build_DIC_Call): New routine.
+ (Build_DIC_Procedure_Body): New routine.
+ (Build_DIC_Procedure_Declaration): New routine.
+ (Entity_Hash): Moved from Sem_Prag.
+ (Find_DIC_Type): New routine.
+ (Update_Primitives_Mapping): Reimplemented.
+ (Update_Primitives_Mapping_Of_Types): New routine.
+ * exp_util.ads (Build_Class_Wide_Expression): Moved from Sem_Prag.
+ (Build_DIC_Call): New routine.
+ (Build_DIC_Procedure_Body): New routine.
+ (Build_DIC_Procedure_Declaration): New routine.
+ (Update_Primitives_Mapping): Moved from Sem_Prag.
+ (Update_Primitives_Mapping_Of_Types): New routine.
+ * nlists.adb (Append_New): New routine.
+ (Append_New_To): New routine.
+ * nlists.ads (Append_New): New routine.
+ (Append_New_To): New routine.
+ * sem_ch3.adb (Analyze_Declarations): Do not generate the bodies
+ of DIC procedures here. This is now done at the end of the
+ visible declarations, private declarations, and at the freeze
+ point of a type.
+ (Analyze_Private_Extension_Declaration):
+ A private extension inherits the DIC pragma of a parent type.
+ (Analyze_Subtype_Declaration): No need to propagate invariant
+ attributes to a subtype as those apply to the base type.
+ (Build_Derived_Record_Type): No need to inherit invariants here
+ as this is now done in Build_Derived_Type.
+ (Build_Derived_Type): Inherit both the DIC pragma and invariants from
+ a parent type.
+ (Process_Full_View): Update the propagation of DIC attributes.
+ (Propagate_Default_Init_Cond_Attributes): Removed.
+ * sem_ch7.adb Add with and use clauses for Exp_Util.
+ (Analyze_Package_Specification): Create the body of the DIC
+ procedure at the end of the visible and private declarations.
+ (Preserve_Full_Attributes): Propagate DIC attributes.
+ * sem_ch9.adb (Analyze_Protected_Type_Declaration): Propagate
+ DIC attributes.
+ (Analyze_Task_Type_Declaration): Propagate DIC attributes.
+ * sem_elab.adb (Check_A_Call): Update the call to
+ Is_Nontrivial_Default_Init_Cond_Procedure.
+ * sem_prag.adb Remove the with and use clauses for
+ GNAT.HTable. Move the handling of class- wide pre/postcondition
+ description and data structures to Exp_Util.
+ (Analyze_Pragma): Create the declaration of the DIC procedure. There
+ is no need to propagate invariant-related attributes at this point
+ as this is done in Build_Invariant_Procedure_Declaration.
+ (Build_Class_Wide_Expression): Moved to Exp_Util.
+ (Entity_Hash): Moved to Exp_Util.
+ (Update_Primitives_Mapping): Moved to Exp_Util.
+ * sem_prag.ads (Build_Class_Wide_Expression): Moved to Exp_Util.
+ (Update_Primitives_Mapping): Moved to Exp_Util.
+ * sem_util.adb: Remove with and use clauses for Ghost
+ and Sem_Ch13.
+ (Build_Default_Init_Cond_Call): Removed.
+ (Build_Default_Init_Cond_Procedure_Bodies): Removed.
+ (Build_Default_Init_Cond_Procedure_Declaration): Removed.
+ (Get_Views): Reimplemented.
+ (Has_Full_Default_Initialization): Reimplement the section on DIC.
+ (Inherit_Default_Init_Cond_Procedure): Removed.
+ (Is_Nontrivial_Default_Init_Cond_Procedure): Removed.
+ (Is_Nontrivial_DIC_Procedure): New routine.
+ (Is_Verifiable_DIC_Pragma): New routine.
+ (Propagate_DIC_Attributes): New routine.
+ * sem_util.ads (Build_Default_Init_Cond_Call): Removed.
+ (Build_Default_Init_Cond_Procedure_Bodies): Removed.
+ (Build_Default_Init_Cond_Procedure_Declaration): Removed.
+ (Inherit_Default_Init_Cond_Procedure): Removed.
+ (Is_Nontrivial_Default_Init_Cond_Procedure): Removed.
+ (Is_Nontrivial_DIC_Procedure): New routine.
+ (Is_Verifiable_DIC_Pragma): New routine.
+ (Propagate_DIC_Attributes): New routine.
+ * sem_warn.adb (Is_OK_Fully_Initialized): Reimplement the section
+ on DIC.
+ * sinfo.ads, sinfo.adb: Add new attribute Expression_Copy along with
+ usage in nodes.
+ (Expression_Copy): New routine along with pragma Inline.
+ (Set_Expression_Copy): New routine along with pragma Inline.
+
+2017-01-06 Bob Duff <duff@adacore.com>
+
+ * bindgen.adb (Gen_Adainit, Gen_Adafinal): Change
+ "Bind_Main_Program" to "not Bind_For_Library", because otherwise
+ we won't generate the call to s_stalib_adafinal when the main
+ is not written in Ada.
+
+2017-01-06 Bob Duff <duff@adacore.com>
+
+ * sem_prag.adb: Minor: remove pragma Warnings.
+
+2017-01-06 Tristan Gingold <gingold@adacore.com>
+
+ * Makefile.rtl: Do not compile s-stchop by default.
+
+2017-01-06 Patrick Bernardi <bernardi@adacore.com>
+
+ * aspects.adb, aspects.ads, exp_ch3.adb, exp_ch9.adb, par-prag.adb,
+ sem_ch13.adb, sem_prag.adb, sem_prag.ads, snames.adb-tmpl,
+ snames.ads-tmpl, s-secsta.adb, s-secsta.ads, s-tarest.adb,
+ s-tarest.ads, s-taskin.adb, s-taskin.ads, s-tassta.adb, s-tassta.ads:
+ Reverted previous change for now.
+
+2017-01-06 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch3.adb (Build_Initialization_Call): Apply predicate
+ check to default discriminant value if checks are enabled.
+ (Build_Assignment): If type of component has static predicate,
+ apply check to its default value, if any.
+
+2017-01-06 Patrick Bernardi <bernardi@adacore.com>
+
+ * aspect.adb, aspect.ads: Added new aspect Secondary_Stack_Size.
+ * exp_ch3.adb (Build_Init_Statements): As part of initialising
+ the value record of a task, set its _Secondary_Stack_Size field
+ if present.
+ * exp_ch9.adb (Expand_N_Task_Type_Declaration): Create
+ a _Secondary_Stack_Size field in the value record of
+ the task if a Secondary_Stack_Size rep item is present.
+ (Make_Task_Create_Call): Include secondary stack size
+ parameter. If No_Secondary_Stack restriction is in place, passes
+ stack size of 0.
+ * par-prag.adb, sem_prag.adb, sem_prag.ads: Added new pragma
+ Secondary_Stack_Size.
+ * s-secsta.adb, s-secsta.ads (Minimum_Secondary_Stack_Size): New
+ function to define the overhead of the secondary stack.
+ * s-tarest.adb (Create_Restricted_Task,
+ Create_Restricted_Task_Sequential): Functions now include
+ Secondary_Stack_Size parameter to pass to Initialize_ATCB.
+ * s-tarest.adb (Create_Restricted_Task,
+ Create_Restricted_Task_Sequential): Calls to Initialize_ATCB
+ now include Secondary_Stack_Size parameter.
+ (Task_Wrapper):
+ Secondary stack now allocated to the size specified by the
+ Secondary_Stack_Size parameter in the task's ATCB.
+ * s-taskin.adb, s-taskin.adb (Common_ATCB, Initialise_ATCB): New
+ Secondary_Stack_Size component.
+ * s-tassta.adb, s-tassta.ads (Create_Restricted_Task,
+ Create_Restricted_Task_Sequential): Function now include
+ Secondary_Stack_Size parameter.
+ (Task_Wrapper): Secondary stack
+ now allocated to the size specified by the Secondary_Stack_Size
+ parameter in the task's ATCB.
+ * sem_ch13.adb (Analyze_Aspect_Specification): Add support
+ for Secondary_Stack_Size aspect, turning the aspect into its
+ corresponding internal attribute.
+ (Analyze_Attribute_Definition):
+ Process Secondary_Stack_Size attribute.
+ * snames.adb-tmpl, snames.ads-tmpl: Added names
+ Name_Secondary_Stack_Size, Name_uSecondary_Stack_Size,
+ Attribute_Secondary_Stack_Size and Pragma_Secondary_Stack_Size.
+
+2017-01-06 Pascal Obry <obry@adacore.com>
+
+ * a-direio.adb, a-direio.ads, a-sequio.adb, a-sequio.ads: Add Flush to
+ Sequential_IO and Direct_IO.
+
+2017-01-06 Bob Duff <duff@adacore.com>
+
+ * snames.ads-tmpl (Renamed): New name for the pragma argument.
+ * par-ch2.adb: Allow the new pragma (with analysis deferred
+ to Sem_Prag).
+ * sinfo.ads, sinfo.adb (Map_Pragma_Name, Pragma_Name_Mapped):
+ Keep a mapping from new pragma names to old names.
+ * sem_prag.adb: Check legality of pragma Rename_Pragma, and
+ implement it by calling Map_Pragma_Name.
+ * checks.adb, contracts.adb, einfo.adb, errout.adb,
+ * exp_attr.adb, exp_ch3.adb, exp_ch6.adb, exp_ch7.adb, exp_ch9.adb,
+ * exp_prag.adb, exp_util.adb, freeze.adb, frontend.adb, ghost.adb,
+ * inline.adb, lib-writ.adb, scans.adb, scans.ads, sem_attr.adb,
+ * sem_aux.adb, sem_ch10.adb, sem_ch13.adb, sem_ch6.adb, sem_ch9.adb,
+ * sem_elab.adb, sem_res.adb, sem_util.adb, sem_util.ads,
+ * sem_warn.adb: Call Pragma_Name_Mapped instead of Pragma_Name
+ as appropriate.
+
+2017-01-06 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch9.adb: Minor reformatting.
+
+2017-01-06 Tristan Gingold <gingold@adacore.com>
+
+ * exp_ch9.ads, exp_ch9.adb (Build_Entry_Names): Remove (unused).
+ * rtsfind.ads (RE_Task_Entry_Names_Array, RO_ST_Set_Entry_Names)
+ (RE_Protected_Entry_Names_Array, RO_PE_Set_Entry_Names): Remove
+ (unused).
+ * s-taskin.ads, s-taskin.adb (Set_Entry_Names,
+ Task_Entry_Names_Array, Task_Entry_Names_Access): Remove.
+ * s-tpoben.ads, s-tpoben.adb (Set_Entry_Names,
+ Protected_Entry_Names_Array, Protected_Entry_Names_Access): Remove.
+
+2017-01-06 Bob Duff <duff@adacore.com>
+
+ * sinfo.ads, sinfo.adb (Map_Pragma_Name): Preparation work,
+ dummy implementation of Map_Pragma_Name.
+
+2017-01-06 Tristan Gingold <gingold@adacore.com>
+
+ * exp_ch9.adb (Expand_N_Protected_Type_Declaration): Make the
+ entry_body variable constant.
+ * s-taprob.ads (Entry_Body_Access): Move to s-tposen.
+ * s-tpoben.ads (Protected_Entry_Body_Access): Now access
+ to constant.
+ * s-tposen.ads (Entry_Body_Access): Moved from s-taprob,
+ now access to constant.
+
+2017-01-06 Gary Dismukes <dismukes@adacore.com>
+
+ * einfo.ads, sem_res.adb, sem_attr.adb, sem_ch6.adb: Minor
+ reformatting and typo fixes.
+
+2017-01-06 Bob Duff <duff@adacore.com>
+
+ * snames.ads-tmpl: New names for pragma renaming.
+ * snames.adb-tmpl (Is_Configuration_Pragma_Name): Minor cleanup.
+ * par-prag.adb: Add new pragma name to case statement.
+ * sem_prag.adb (Rename_Pragma): Initial cut at semantic analysis
+ of the pragma.
+ * sinfo.ads, sinfo.adb (Pragma_Name_Mapped): Preparation work,
+ Dummy implementation of Pragma_Name_Mapped.
+
+2017-01-06 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch6.adb (Expand_Protected_Subprogram_Call): Add guard to
+ better detect call within an entry_wrapper.
+ * sem_res.adb (Resolve_Call): A protected call within an
+ entity_wrapper is analyzed in the context of the protected
+ object but corresponds to a pre-analysis and is not an access
+ before elaboration.
+ * sem_attr.adb: Minor reformatting.
+
+2017-01-06 Justin Squirek <squirek@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): Modify semantic checks for
+ Finalization_Size to allow a prefix of any non-class-wide type.
+ * sem_attr.ads Modify comment for Finalization_Size to include
+ definite type use case.
+
+2017-01-06 Ed Schonberg <schonberg@adacore.com>
+
+ * einfo.ads, einfo.adb (Is_Entry_Wrapper): New flag, defined
+ on procedures that are wrappers created for entries that have
+ preconditions.
+ * sem_ch6.adb (Analyze_Subrogram_Body_Helper): If the subprogram
+ body is an entry_wrapper, compile it in the context of the
+ synchronized type, because a precondition may refer to funtions
+ of the type.
+ * exp_ch9.adb (Build_Contract_Wrapper): Set Is_Entry_Wrapper on
+ body entity.
+ * exp_ch6.adb (Expand_Protected_Subprogram_Call): if the call is
+ within an Entry_Wrapper this is an external call whose target
+ is the synchronized object that is the actual in the call to
+ the wrapper.
+
+2017-01-06 Yannick Moy <moy@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute/Attribute_Loop_Entry): Analyze node
+ in tree, which means not analyzing the previous prefix if the node has
+ been rewritten into its prefix.
+
+2017-01-06 Gary Dismukes <dismukes@adacore.com>
+
+ * s-tpobop.adb: Minor reformatting.
+
+2017-01-06 Ed Schonberg <schonberg@adacore.com>
+
+ * checks.adb (Ensure_Valid): Do not generate a validity check
+ within a generated predicate function, validity checks will have
+ been applied earlier when required.
+
+2017-01-06 Tristan Gingold <gingold@adacore.com>
+
+ * s-tpoben.ads (Protection_Entries): Add comment and reorder
+ components for performances.
+ * s-tpobop.adb (PO_Do_Or_Queue): Implement Max_Queue_Length runtime
+ semantic.
+
+2017-01-06 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_eval.adb (Check_Expression_Against_Static_Predicate):
+ If expression is compile-time known and obeys a static predicate
+ it must be labelled as static, to prevent spurious warnings and
+ run-time errors, e.g. in case statements. This is relevant when
+ the expression is the result of constant-folding a type conversion
+ whose expression is a variable with a known static value.
+
+2017-01-06 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_attr.adb, sem_attr.ads: Minor reformatting.
+
+2017-01-06 Justin Squirek <squirek@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference): Add entry for
+ expansion of Finalization_Size attribute.
+ * sem_attr.adb (Analyze_Attribute): Add entry to check the
+ semantics of Finalization_Size.
+ (Eval_Attribute): Add null entry for Finalization_Size.
+ * sem_attr.ads: Add Finalization_Size to the implementation
+ dependent attribute list.
+ * snames.ads-tmpl: Add name entry for Finalization_Size attribute.
+
+2017-01-06 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch5.adb (Analyze_Loop_Statement): If the loop includes an
+ iterator specification with a serious syntactic error, transform
+ construct into an infinite loop in order to continue analysis
+ and prevent a compiler abort.
+
+2017-01-06 Tristan Gingold <gingold@adacore.com>
+
+ * exp_ch9.adb (Expand_N_Protected_Type_Declaration): Do not generate
+ max_queue_lengths_array if unused.
+
+2017-01-06 Bob Duff <duff@adacore.com>
+
+ * errout.adb (Set_Msg_Text): Protect against out-of-bounds
+ array access, in case "\" is at the end of Text.
+ * stylesw.adb (Set_Style_Check_Options): Don't include input
+ characters in the error message template, because they could
+ be control characters such as "\", which Errout will try to
+ interpret.
+
+2017-01-06 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch4.adb (Find_Indexing_Operations, Inspect_Declarations):
+ For a private type examine the visible declarations that follow
+ the partial view, not just the private declarations that follow
+ the full view.
+
+2017-01-06 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch5.adb, sem_ch3.adb, checks.adb: Minor reformatting and
+ code cleanup.
+
+2017-01-06 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch5.adb (Get_Default_Iterator): For a derived type, the
+ alias of the inherited op is the parent iterator, no need to
+ examine dispatch table positions which might not be established
+ yet if type is not frozen.
+ * sem_disp.adb (Check_Controlling_Formals): The formal of a
+ predicate function may be a subtype of a tagged type.
+ * sem_ch3.adb (Complete_Private_Subtype): Adjust inheritance
+ of representation items for the completion of a type extension
+ where a predicate applies to the partial view.
+ * checks.ads, checks.adb (Apply_Predicate_Check): Add optional
+ parameter that designates function whose actual receives a
+ predicate check, to improve warning message when the check will
+ lead to infinite recursion.
+ * sem_res.adb (Resolve_Actuals): Pass additional parameter to
+ Apply_Predicate_Check.
+
+2017-01-06 Tristan Gingold <gingold@adacore.com>
+
+ * s-rident.ads (Profile_Info): Remove No_Entry_Queue from
+ Gnat_Extended_Ravenscar.
+ * exp_ch9.adb, s-tpoben.adb, s-tpoben.ads: Fix spelling.
+
+2017-01-06 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_util.ads: Minor typo fix and reformatting.
+
+2017-01-06 Yannick Moy <moy@adacore.com>
+
+ * ghost.adb Minor fixing of references to SPARK RM.
+ (Check_Ghost_Context): Check whether reference is to a lvalue
+ before issuing an error about violation of SPARK RM 6.9(13)
+ when declaration has Ghost policy Check and reference has Ghost
+ policy Ignore.
+ * sem_util.adb Minor indentation.
+ * sem_ch10.adb (Analyze_Package_Body_Stub, Analyze_Protected_Body_Stub,
+ Analyze_Task_Body_Stub): Set Ekind of the defining identifier.
+ * sem_util.ads (Unique_Defining_Entity): Document the result
+ for package body stubs.
+
+2017-01-06 Tristan Gingold <gingold@adacore.com>
+
+ * raise-gcc.c (abort): Macro to call Abort_Propagation.
+ * s-tpoben.ads (Protected_Entry_Queue_Max_Access): Make it access
+ constant.
+ * exp_ch9.adb (Expand_N_Protected_Type_Declaration):
+ Do not generate the Entry_Max_Queue_Lengths_Array if all default
+ values.
+ * exp_util.adb (Corresponding_Runtime_Package): Consider
+ Max_Queue_Length pragma.
+
+2017-01-06 Justin Squirek <squirek@adacore.com>
+
+ * exp_ch9.adb (Expand_N_Protected_Type_Declaration):
+ Remove declaration generation in the case of
+ System_Tasking_Protected_Objects_Single_Entry being used,
+ and add a warning message when this is detected to occur.
+ (Make_Initialize_Protection): Remove reference pass in the case
+ of System_Tasking_Protected_Objects_Single_Entry.
+ * rtsfind.ads: Remove RE_Protected_Entry_Queue_Max
+ * s-tposen.adb (Initialize_Protection_Entry): Remove
+ Entry_Queue_Max parameter.
+ * s-tposen.ads: Remove the types use to store the entry queue
+ maximum.
+ * sem_prag.adb (Analyze_Pragma): Remove entry families restriction
+
+2017-01-06 Yannick Moy <moy@adacore.com>
+
+ * sem_util.adb, sem_util.ads (Get_Enum_Lit_From_Pos): Strengthen
+ behavior of function, to also accept out of range positions
+ and raise Constraint_Error in such case, and to copy sloc from
+ literal if No_Location passed as location.
+ * uintp.adb, uintp.ads (UI_To_Int, UI_To_CC): Strengthen behavior
+ of functions to raise Constraint_Error in case of value not in
+ appropriate range.
+
+2017-01-06 Tristan Gingold <gingold@adacore.com>
+
+ * sem_util.adb, s-taprop-linux.adb (Finalize_TCB): Remove call to
+ Invalidate_Stack_Cache.
+
+2017-01-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * s-os_lib.adb: Minor fix to the signature of Readlink.
+
+2017-01-06 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch6.adb (Conforming_Types): Handle another
+ confusion between views in a nested instance with an actual
+ private type whose full view is not in scope.
+
+2017-01-06 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch5.adb (Expand_N_If_Statement): Obey existing comment and
+ mark a rewritten if statement as explicit (Comes_From_Source).
+
+2017-01-06 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_prag.adb, rtsfind.adb, sem_util.adb: Minor typo fixes.
+
+2017-01-06 Tristan Gingold <gingold@adacore.com>
+
+ * ada.ads, a-unccon.ads: Add pragma No_Elaboration_Code_All.
+
+2017-01-06 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_case.adb: Minor reformatting.
+
+2017-01-06 Thomas Quinot <quinot@adacore.com>
+
+ * g-socthi-mingw.adb: Remove now extraneous USE TYPE clause
+
+2017-01-06 Justin Squirek <squirek@adacore.com>
+
+ * aspects.adb: Register aspect in Canonical_Aspect.
+ * aspects.ads: Associate qualities of Aspect_Max_Queue_Length
+ into respective tables.
+ * einfo.ads, einfo.adb: Add a new attribute for
+ handling the parameters for Pragma_Max_Entry_Queue
+ (Entry_Max_Queue_Lengths_Array) in E_Protected_Type. Subprograms
+ for accessing and setting were added as well.
+ * par-prag.adb (Prag): Register Pramga_Max_Entry_Queue.
+ * exp_ch9.adb (Expand_N_Protected_Type_Declaration): Emit
+ declaration for pramga arguments and store them in the protected
+ type node.
+ (Make_Initialize_Protection): Pass a reference to
+ the Entry_Max_Queue_Lengths_Array in the protected type node to
+ the runtime.
+ * rtsfind.adb: Minor grammar fix.
+ * rtsfind.ads: Register new types taken from the
+ runtime libraries RE_Protected_Entry_Queue_Max and
+ RE_Protected_Entry_Queue_Max_Array
+ * s-tposen.adb, s-tpoben.adb
+ (Initialize_Protection_Entry/Initialize_Protection_Entries):
+ Add extra parameter and add assignment to local object.
+ * s-tposen.ads, s-tpoben.ads: Add new types to
+ store entry queue maximums and a field to the entry object record.
+ * sem_ch13.adb (Analyze_Aspect_Specifications): Add case statement
+ for Aspect_Max_Queue_Length.
+ (Check_Aspect_At_Freeze_Point):
+ Add aspect to list of aspects that don't require delayed analysis.
+ * sem_prag.adb (Analyze_Pragma): Add case statement for
+ Pragma_Max_Queue_Length, check semantics, and register arugments
+ in the respective entry nodes.
+ * sem_util.adb, sem_util.ads Add functions Get_Max_Queue_Length
+ and Has_Max_Queue_Length
+ * snames.ads-tmpl: Add constant for the new aspect-name
+ Name_Max_Queue_Length and corrasponding pragma.
+
+2017-01-06 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_util.adb (Is_Controlled_Function_Call):
+ Reimplemented. Consider any node which has an entity as the
+ function call may appear in various ways.
+
+2017-01-06 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_attr.adb (Rewrite_Stream_Proc_Call): Use
+ an unchecked type conversion when performing a view conversion
+ to/from a private type. In all other cases use a regular type
+ conversion to ensure that any relevant checks are properly
+ installed.
+
+2017-01-06 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_prag.adb, sem_ch8.adb: Minor reformatting.
+
+2017-01-06 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_case.adb (Explain_Non_Static_Bound): Suppress cascaded
+ error on case expression that is an entity, when coverage is
+ incomplete and entity has a static value obtained by local
+ propagation.
+ (Handle_Static_Predicate): New procedure, subsidiary of
+ Check_Choices, to handle case alternatives that are either
+ subtype names or subtype indications involving subtypes that
+ have static predicates.
+
+2017-01-06 Thomas Quinot <quinot@adacore.com>
+
+ * s-oscons-tmplt.c, g-socket.adb, g-socket.ads, g-sothco.ads:
+ (GNAT.Socket): Add support for Busy_Polling and Generic_Option
+
+2017-01-06 Bob Duff <duff@adacore.com>
+
+ * sem_elab.adb (Activate_Elaborate_All_Desirable): Don't add
+ Elaborate_All(P) to P itself. That could happen in obscure cases,
+ and always introduced a cycle (P body must be elaborated before
+ P body).
+ * lib-writ.ads: Comment clarification.
+ * ali-util.ads: Minor comment fix.
+ * ali.adb: Minor reformatting.
+
+2017-01-06 Tristan Gingold <gingold@adacore.com>
+
+ * a-exexpr-gcc.adb: Improve comment.
+
+2017-01-03 James Cowgill <James.Cowgill@imgtec.com>
+
+ * s-linux-mips.ads: Use correct signal and errno constants.
+ (sa_handler_pos, sa_mask_pos): Fix offsets for 64-bit MIPS.
+
+2017-01-03 James Cowgill <James.Cowgill@imgtec.com>
+
+ * s-linux-mips.ads: Rename from s-linux-mipsel.ads.
+ * gcc-interface/Makefile.in (MIPS/Linux): Merge mips and mipsel
+ sections.
+
+2017-01-01 Eric Botcazou <ebotcazou@adacore.com>
* gnatvsn.ads: Bump copyright year.
+2017-01-01 Jakub Jelinek <jakub@redhat.com>
+
+ * gnat_ugn.texi: Bump @copying's copyright year.
+ * gnat_rm.texi: Likewise.
-Copyright (C) 2016 Free Software Foundation, Inc.
+Copyright (C) 2017 Free Software Foundation, Inc.
Copying and distribution of this file, with or without modification,
are permitted in any medium without royalty provided the copyright
diff --git a/gcc/ada/ChangeLog-2016 b/gcc/ada/ChangeLog-2016
new file mode 100644
index 0000000000..0acae5761a
--- /dev/null
+++ b/gcc/ada/ChangeLog-2016
@@ -0,0 +1,5918 @@
+2016-12-07 Pierre-Marie de Rodat <derodat@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity): When they are global,
+ consider ___XR GNAT encodings variables for renamings as static so
+ they have a location in the debug info.
+
+2016-12-07 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Variable>: Translate
+ System.Address into ptr_type_node for every foreign convention.
+ (gnat_to_gnu_subprog_type): Likewise for result and parameter types.
+ (gnat_to_gnu_param): Do not do it here for GCC builtins.
+ (intrin_return_compatible_p): Likewise.
+
+2016-12-07 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Enumeration_Subtype>:
+ Also call finish_character_type on Character subtypes.
+ * gcc-interface/utils.c (finish_character_type): Deal with subtypes.
+
+2016-12-05 Mikael Pettersson <mikpe@it.uu.se>
+
+ PR ada/48835
+ * gcc-interface/Makefile.in: Add support for m68k-linux.
+ * system-linux-m68k.ads: New file.
+
+2016-12-05 Eric Botcazou <ebotcazou@adacore.com>
+
+ * system-darwin-ppc.ads (Support_Atomic_Primitives): Set to True only
+ if the word size is 64.
+
+2016-11-30 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_prag.adb, sem_ch6.adb: Minor reformatting and typo fixes.
+ * g-sechas.adb: Minor reformatting.
+ * lib-xref.ads: minor grammar fix in comment.
+ * lib-xref-spark_specific.adb
+ (Is_SPARK_Reference): do not ignore references to concurrent
+ objects.
+ * sinfo.ads: Fix of unbalanced parens in comment
+
+2016-11-30 Ed Schonberg <schonberg@adacore.com>
+
+ * lib-xref.adb (Get_Type_Reference): If the entity is a function
+ returning a classwide type, the type reference is obtained right
+ away and does not need further unwinding.
+
+2016-11-30 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch8.adb (Find_Renamed_Entity): For non-overloaded subprogram
+ actuals of generic units check that the spec of the renaming
+ and renamed entities match.
+
+2016-11-30 Tristan Gingold <gingold@adacore.com>
+
+ * raise-gcc.c: For CERT runtimes: do not use gcc includes, simplify
+ the handling.
+ * sem_attr.adb (Analyze_Attribute): Check No_Dynamic_Priorities
+ restriction for Priority Attribute.
+
+2016-11-27 Eric Botcazou <ebotcazou@adacore.com>
+
+ PR ada/78524
+ * gcc-interface/utils.c (max_size) <tcc_reference>: Add missing
+ conversion to original type in the PLACEHOLDER_EXPR case.
+
+2016-11-27 Eric Botcazou <ebotcazou@adacore.com>
+
+ PR ada/78531
+ * namet.h (Max_Line_Length): Define.
+ (struct Bounded_String): Declare Chars with exact size.
+ (namet__get_decoded_name_string): Delete.
+ (Get_Decoded_Name_String): Likewise.
+ (casing__set_all_upper_case): Likewise.
+
+2016-11-22 Uros Bizjak <ubizjak@gmail.com>
+
+ * gcc-interface/Make-lang.in (check-acats): Fix detection
+ of -j argument.
+
+2016-11-18 Richard Sandiford <richard.sandiford@arm.com>
+ Alan Hayward <alan.hayward@arm.com>
+ David Sherwood <david.sherwood@arm.com>
+
+ * gcc-interface/utils.c (create_label_decl): Use SET_DECL_MODE.
+
+2016-11-14 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/Makefile.in: Replace s-interr-hwint.adb with
+ s-interr-vxworks.adb throughout.
+
+2016-11-13 Bob Duff <duff@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity): In assertion about known
+ Esize, protect with !is_type and change !Unknown_Esize to Known_Esize.
+
+2016-11-13 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Signed_Integer_Subtype>:
+ Look at the underlying type for the signedness of the type.
+
+2016-11-13 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (annotate_value) <INTEGER_CST>: Deal specially
+ with negative constants.
+
+2016-11-13 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/utils2.c (gnat_protect_expr): Also protect only the
+ address if the expression is the component of a dereference.
+ Do not use a reference type for the final temporary reference.
+
+2016-11-13 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/Makefile.in (NO_OMIT_ADAFLAGS): Define.
+ (a-except.o): Replace -fno-inline with NO_INLINE_ADAFLAGS.
+ (s-memory.o): New rule.
+ (tracebak.o): Replace -fno-omit-frame-pointer with NO_OMIT_ADAFLAGS.
+
+2016-11-07 Tamar Christina <tamar.christina@arm.com>
+
+ * adaint.c: Added signal.h for Windows.
+
+2016-10-31 Jakub Jelinek <jakub@redhat.com>
+
+ * gcc-interface/misc.c (gnat_get_array_descr_info): Clear rank field.
+
+2016-10-24 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
+
+ * gcc-interface/Make-lang.in (lang_checks_parallelized): New target.
+ (check_gnat_parallelize): Likewise.
+
+2016-10-20 Nicolas Roche <roche@adacore.com>
+
+ * gcc-interface/Makefile (x86-64/Darwin): Restore missing pairs.
+ (x86/Darwin): Likewise.
+
+2016-10-19 Eric Botcazou <ebotcazou@adacore.com>
+
+ * system-linux-armel.ads: Rename into...
+ * system-linux-arm.ads: ...this
+ * gcc-interface/Makefile.in (ARM/Android): Adjust to above renaming.
+ (ARM/Linux): Likewise.
+ (Aarch64/Linux): Likewise.
+
+2016-10-18 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/Makefile.in (EXTRA_GNATRTL_NONTASKING_OBJS): Define.
+ (EXTRA_GNATRTL_TASKING_OBJS): Likewise.
+ (ARM/Android): Add atomic support.
+ (SPARC/Solaris): Simplify.
+ (x86/Solaris): Likewise.
+ (x86/Linux): Likewise.
+ (x86-64/kFreeBDS): Adjust and use system-freebsd-x86.ads
+ (x86/FreeBSD): Add s-mudido-affinity.adb.
+ (x86-64/FreeBSD): Likewise and use system-freebsd-x86.ads.
+ (s390/Linux): Simplify.
+ (PowerPC/AIX): Likewise.
+ (Cygwin/Mingw): Likewise.
+ (MIPSel/Linux): Likewise.
+ (ARM/Linux): Add atomic support.
+ (Aarch64/Linux): Use system-linux-armel.ads.
+ (SPARC/Linux): Simplify.
+ (IA-64/Linux): Minor tweak.
+ (IA-64/HP-UX): Likewise.
+ (Alpha/Linux): Likewise.
+ (x86-64/Linux): Use system-linux-x86.ads.
+ (x86/Darwin): Simplify.
+ (PowerPC/Darwin): Likewise.
+ (ARM/Darwin): Use system-darwin-arm.ads.
+ (ADA_EXCLUDE_SRCS): Minor reformatting.
+ * system-aix.ads (Word_Size): Change to Standard'Word_Size.
+ (Memory_Size): Change to 2 ** Word_Size.
+ (Support_Atomic_Primitives): Set to True.
+ * system-aix64.ads: Delete.
+ * system-darwin-arm.ads: New.
+ * system-darwin-ppc.ads (Word_Size): Change to Standard'Word_Size.
+ (Memory_Size): Change to 2 ** Word_Size.
+ (Support_Atomic_Primitives): Set to True.
+ * system-darwin-ppc64.ads: New.
+ * system-darwin-x86.ads (Word_Size): Change to Standard'Word_Size.
+ (Memory_Size): Change to 2 ** Word_Size.
+ * system-darwin-x86_64.ads: Delete.
+ * system-freebsd-x86.ads (Word_Size): Change to Standard'Word_Size.
+ (Memory_Size): Change to 2 ** Word_Size.
+ * system-freebsd-x86_64.ads: Delete.
+ * system-linux-alpha.ads (Support_Atomic_Primitives): Set to True.
+ * system-linux-armeb.ads (Word_Size): Change to Standard'Word_Size.
+ (Memory_Size): Change to 2 ** Word_Size.
+ (Support_Atomic_Primitives): Set to True.
+ * system-linux-armel.ads (Word_Size): Change to Standard'Word_Size.
+ (Memory_Size): Change to 2 ** Word_Size.
+ (Support_Atomic_Primitives): Set to True.
+ * system-linux-mips.ads: (Word_Size): Change to Standard'Word_Size.
+ (Memory_Size): Change to 2 ** Word_Size.
+ * system-linux-mipsel.ads (Word_Size): Change to Standard'Word_Size.
+ (Memory_Size): Change to 2 ** Word_Size.
+ * system-linux-s390.ads (Word_Size): Change to Standard'Word_Size.
+ (Memory_Size): Change to 2 ** Word_Size.
+ (Stack_Check_Probes): Set to True.
+ * system-linux-s390x.ads: Delete.
+ * system-linux-sparc.ads (Word_Size): Change to Standard'Word_Size.
+ (Memory_Size): Change to 2 ** Word_Size.
+ * system-linux-sparcv9.ads: Delete.
+ * system-linux-x86.ads (Word_Size): Change to Standard'Word_Size.
+ (Memory_Size): Change to 2 ** Word_Size.
+ * system-linux-x86_64.ads: Delete.
+ * system-mingw-x86_64.ads: Delete.
+ * system-mingw.ads (Word_Size): Change to Standard'Word_Size.
+ (Memory_Size): Change to 2 ** Word_Size.
+ * system-solaris-sparc.ads (Word_Size): Change to Standard'Word_Size.
+ (Memory_Size): Change to 2 ** Word_Size.
+ (Support_Atomic_Primitives): Set to True.
+ * system-solaris-sparcv9.ads: Delete.
+ * system-solaris-x86.ads (Word_Size): Change to Standard'Word_Size.
+ (Memory_Size): Change to 2 ** Word_Size.
+ * system-solaris-x86_64.ads: Delete.
+
+2016-10-17 Eric Botcazou <ebotcazou@adacore.com>
+
+ * system-darwin-ppc64.ads (Support_64_Bit_Divides): Delete.
+ * system-linux-armeb.ads (Support_64_Bit_Divides): Likewise.
+ * system-linux-mips.ads (Support_64_Bit_Divides): Likewise.
+ * system-linux-mips64el.ads (Support_64_Bit_Divides): Likewise.
+ * system-linux-mipsel.ads (Support_64_Bit_Divides): Likewise.
+ * system-linux-sparcv9.ads (Support_64_Bit_Divides): Likewise.
+ * system-rtems.ads (Support_64_Bit_Divides): Likewise.
+
+2016-10-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/misc.c (LANG_HOOKS_CUSTOM_FUNCTION_DESCRIPTORS):Define.
+ * gcc-interface/trans.c (Attribute_to_gnu) <Attr_Access>: Deal with
+ a zero TARGET_CUSTOM_FUNCTION_DESCRIPTORS specially for Code_Address.
+ Otherwise, if TARGET_CUSTOM_FUNCTION_DESCRIPTORS is positive, set
+ FUNC_ADDR_BY_DESCRIPTOR for 'Access/'Unrestricted_Access of nested
+ subprograms if the type can use an internal representation.
+ (call_to_gnu): Likewise, but set CALL_EXPR_BY_DESCRIPTOR on indirect
+ calls if the type can use an internal representation.
+
+2016-10-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ * system-aix.ads (Always_Compatible_Rep): Change to False.
+ * system-aix64.ads (Always_Compatible_Rep): Likewise.
+ * system-hpux-ia64.ads (Always_Compatible_Rep): Likewise.
+ * system-hpux.ads (Always_Compatible_Rep): Likewise.
+ * system-linux-alpha.ads (Always_Compatible_Rep): Likewise.
+ * system-linux-hppa.ads (Always_Compatible_Rep): Likewise.
+ * system-linux-ia64.ads (Always_Compatible_Rep): Likewise.
+ * system-linux-mips.ads (Always_Compatible_Rep): Likewise.
+ * system-linux-mips64el.ads (Always_Compatible_Rep): Likewise.
+ * system-linux-mipsel.ads (Always_Compatible_Rep): Likewise.
+ * system-linux-s390.ads (Always_Compatible_Rep): Likewise.
+ * system-linux-s390x.ads (Always_Compatible_Rep): Likewise.
+ * system-linux-sh4.ads (Always_Compatible_Rep): Likewise.
+ * system-linux-sparc.ads (Always_Compatible_Rep): Likewise.
+ * system-linux-sparcv9.ads (Always_Compatible_Rep): Likewise.
+ * system-rtems.ads (Always_Compatible_Rep): Likewise.
+
+2016-10-14 Eric Botcazou <ebotcazou@adacore.com>
+
+ PR ada/77968
+ * gcc-interface/utils.c (create_var_decl): Do not clear TREE_READONLY
+ in LTO mode for an external variable.
+ (can_materialize_object_renaming_p): Move up.
+
+2016-10-13 Thomas Preud'homme <thomas.preudhomme@arm.com>
+
+ * gcc-interface/utils2.c: Include memmodel.h.
+
+2016-10-13 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch6.adb (Analyze_Expression_Function):
+ Remove the aspects of the original expression function has been
+ rewritten into a subprogram declaration or a body. Reinsert the
+ aspects once they have been analyzed.
+
+2016-10-13 Tristan Gingold <gingold@adacore.com>
+
+ * exp_ch9.adb (Expand_N_Asynchronous_Select): Return immediately
+ on restricted profile.
+
+2016-10-13 Javier Miranda <miranda@adacore.com>
+
+ * sem_prag.adb (Process_Compile_Time_Warning_Or_Error): Register the
+ pragma for its validation after the backend has been called only if
+ its expression has some occurrence of attributes 'size or 'alignment
+ * table.ads (Release_Threshold): New formal.
+ (Release): Adding documentation of its new functionality.
+ * table.adb (Release): Extend its functionality with a
+ Release_Threshold.
+ * nlists.adb (Next_Node table): Set its Release_Threshold.
+ * atree.adb (Orig_Nodes table): Set its Release_Threshold.
+ * atree.ads (Nodes table): Set its Release_Threshold.
+ (Flags table): Set its Release_Threshold.
+ * alloc.ads (Nodes_Release_Threshold): New constant declaration.
+ (Orig_Nodes_Release_Threshold): New constant declaration.
+ * debug.adb (switch d.9): Left free.
+ * gnat1drv.adb (Post_Compilation_Validation_Checks): Enable
+ validation of pragmas Compile_Time_Error and Compile_Time_Warning.
+
+2016-10-13 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch6.adb (Create_Extra_Formals): Generate
+ an Itype reference for the object extra formal in case the
+ subprogram is called within the same or nested scope.
+
+2016-10-13 Claire Dross <dross@adacore.com>
+
+ * sem_ch5.adb (Analyze_Iterator_Specification):
+ Also create a renaming in GNATprove mode.
+
+2016-10-13 Ed Schonberg <schonberg@adacore.com>
+
+ * freeze.adb (Freeze_Fixed_Point_Type): in SPARK mode, the
+ given bounds of the type must be strictly representable, and the
+ range reduction by one delta ("shaving") allowed by the Ada RM,
+ is not applicable in SPARK.
+
+2016-10-13 Javier Miranda <miranda@adacore.com>
+
+ * debug.adb (switch d.9): Used to temporarily disable the support
+ needed for this enhancement since it causes regressions with
+ large sources.
+ * gnat1drv.adb (Post_Compilation_Validation_Checks): Temporarily
+ leave the validation of pragmas Compile_Time_Warning and
+ Compile_Time_Error under control of -gnatd.9/
+
+2016-10-13 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch10.adb (Entity_Needs_Body): A generic
+ subprogram renaming needs a body if the renamed unit is declared
+ outside the current compilation unit.
+
+2016-10-13 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sinfo.ads, sem_ch12.adb, sem.adb, expander.adb, sem_res.ads,
+ sem_ch4.adb, sem_ch8.adb, s-memory.adb: Minor reformatting.
+
+2016-10-13 Vincent Celier <celier@adacore.com>
+
+ * gnatcmd.adb: Delete all temporary files when invoked as gnat
+ list -V -P ...
+
+2016-10-13 Ed Falis <falis@adacore.com>
+
+ * i-vxinco.adb, i-vxinco.ads: New files.
+ * impunit.adb: add i-vxinco.ads.
+ * s-interr-vxworks.adb: add hook for user interrupt connection routine.
+
+2016-10-13 Ed Falis <falis@adacore.com>
+
+ * s-interr-hwint.adb, s-interr-vxworks.adb: Rename s-interr-hwint.adb
+ to s-interr-vxworks.adb.
+
+2016-10-13 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_ch7.adb, einfo.ads, sem_prag.adb, sem_prag.ads, sem.ads,
+ sem_attr.adb, sem_case.adb, sem_ch13.ads: Minor typo fixes and
+ reformatting.
+
+2016-10-13 Javier Miranda <miranda@adacore.com>
+
+ * sem_prag.ads (Process_Compile_Time_Warning_Or_Error): New
+ overloaded subprogram that factorizes code executed as part
+ of the regular processing of these pragmas and as part of its
+ validation after invoking the backend.
+ * sem_prag.adb (Process_Compile_Time_Warning_Or_Error): New
+ subprogram.
+ (Process_Compile_Time_Warning_Or_Error): If the
+ condition is known at compile time then invoke the new overloaded
+ subprogram; otherwise register the pragma in a table to validate
+ it after invoking the backend.
+ * sem.ads, sem.adb (Unlock): New subprogram.
+ * sem_attr.adb (Analyze_Attribute [Size]): If we are processing
+ pragmas Compile_Time_Warning and Compile_Time_Errors after the
+ backend has been called then evaluate this attribute if 'Size
+ is known at compile time.
+ * gnat1drv.adb (Post_Compilation_Validation_Checks): Validate
+ compile time warnings and errors.
+ * sem_ch13.ads, sem_ch13.adb (Validate_Compile_Time_Warning_Error):
+ New subprogram.
+ (Validate_Compile_Time_Warning_Errors): New subprogram.
+
+2016-10-13 Yannick Moy <moy@adacore.com>
+
+ * sem_prag.adb (Analyze_Refined_Depends_In_Decl_Part): Adapt to
+ optional refinement for abstract states with only partial refinement
+ visible.
+
+2016-10-13 Justin Squirek <squirek@adacore.com>
+
+ * sem_ch13.adb: Minor correction in comment in
+ Analyze_Aspect_Specifications
+ * sem_prag.adb: Minor reformatting.
+
+2016-10-13 Thomas Quinot <quinot@adacore.com>
+
+ * s-stratt-xdr.adb: Disable compiler unit warnings.
+
+2016-10-13 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Visible_Component): In an instance body, check
+ whether the component may be hidden in a selected component by
+ a homonym that is a primitive operation of the type of the prefix.
+
+2016-10-13 Jakub Jelinek <jakub@redhat.com>
+
+ PR target/77957
+ * gcc-interface/misc.c (LANG_HOOKS_GETDECLS): Use hook_tree_void_null
+ instead of lhd_return_null_tree_v.
+
+2016-10-12 Yannick Moy <moy@adacore.com>
+
+ * einfo.adb, einfo.ads (Partial_Refinement_Constituents): Take
+ into account constituents that are themselves abstract states
+ with full or partial refinement visible.
+ * sem_prag.adb (Find_Encapsulating_State): Move function
+ to library-level, to share between subprograms.
+ (Analyze_Refined_Global_In_Decl_Part): Use
+ Find_Encapsulating_State to get relevant encapsulating state.
+
+2016-10-12 Arnaud Charlet <charlet@adacore.com>
+
+ * gnat1drv.adb: Fix minor typo.
+
+2016-10-12 Yannick Moy <moy@adacore.com>
+
+ * sem_prag.adb (Analyze_Refined_Depends_In_Decl_Part): Adapt checking
+ for optional refinement of abstract state with partial
+ visible refinement.
+ (Analyze_Refined_Global_In_Decl_Part): Adapt checking for optional
+ refinement of abstract state with partial visible refinement. Implement
+ new rules in SPARK RM 7.2.4 related to optional refinement.
+ Also fix the missing detection of missing items.
+
+2016-10-12 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * einfo.adb Add new usage for Elist29 and Node35.
+ (Anonymous_Designated_Type): New routine.
+ (Anonymous_Master): Removed.
+ (Anonymous_Masters): New routine.
+ (Set_Anonymous_Designated_Type): New routine.
+ (Set_Anonymous_Master): Removed.
+ (Set_Anonymous_Masters): New routine.
+ (Write_Field29_Name): Add output for Anonymous_Masters.
+ (Write_Field35_Name): Remove the output for Anonymous_Master. Add
+ output for Anonymous_Designated_Type.
+ * einfo.ads Remove attribute Anonymous_Master along with
+ usage in entities. Add attributes Anonymous_Designated_Type
+ and Anonymous_Masters along with usage in entities.
+ (Anonymous_Designated_Type): New routine along with pragma Inline.
+ (Anonymous_Master): Removed along with pragma Inline.
+ (Anonymous_Masters): New routine along with pragma Inline.
+ (Set_Anonymous_Designated_Type): New routine along with pragma Inline.
+ (Set_Anonymous_Master): Removed along with pragma Inline.
+ (Set_Anonymous_Masters): New routine along with pragma Inline.
+ * exp_ch7.adb (Build_Anonymous_Master): Reuse an anonymous master
+ defined in the same unit if it services the same designated
+ type, otherwise create a new one.
+ (Create_Anonymous_Master): Reimplemented.
+ (Current_Anonymous_Master): New routine.
+ (In_Subtree): Removed.
+
+2016-10-12 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_prag.adb (Analyze_Pragma, case Dynamic_Predicate):
+ Check properly whether there is an explicit assertion policy
+ for predicate checking, even in the presence of a general Ignore
+ assertion policy.
+
+2016-10-12 Steve Baird <baird@adacore.com>
+
+ * sem.adb (Walk_Library_Items): Cope with ignored ghost units.
+
+2016-10-12 Ed Schonberg <schonberg@adacore.com>
+
+ * lib-writ.adb (Write_ALI): Removal of unused file entries from
+ dependency list must be performed before the list is sorted,
+ so that the dependency number of other files is properly set-up
+ for use in tools that relate entity information to the unit in
+ which they are declared.
+
+2016-10-12 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_aggr.adb (Initialize_Ctrl_Array_Component):
+ Create a copy of the initialization expression to avoid sharing
+ it between multiple components.
+
+2016-10-12 Yannick Moy <moy@adacore.com>
+
+ * einfo.adb, einfo.ads (Has_Partial_Visible_Refinement): New flag
+ in abtract states.
+ (Has_Non_Null_Visible_Refinement): Return true for patial refinement.
+ (Partial_Refinement_Constituents): New function returns the full or
+ partial refinement constituents depending on scope.
+ * sem_ch3.adb (Analyze_Declarations): Remove partial visible
+ refinements when exiting the scope of a package spec or body
+ and those partial refinements are not in scope afterwards.
+ * sem_ch7.adb, sem_ch7.ads (Install_Partial_Declarations): Mark
+ abstract states of parent units with partial refinement so that
+ it is visible.
+ * sem_prag.adb (Analyze_Part_Of_In_Decl_Part): Mark enclosing
+ abstract state if any as having partial refinement in that scope.
+ (Analyze_Refined_Global_In_Decl_Part): Check constituent usage
+ based on full or partial refinement depending on scope.
+
+2016-10-12 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Type_Conversion): If the target type
+ has an invariant aspect, insert invariant call at the proper
+ place in the code rather than rewriting the expression as an
+ expression with actions, to prevent spurious semantic errors on
+ the rewritten conversion when it is the object in a renaming.
+
+2016-10-12 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch5.adb, sem_ch3.adb, exp_ch9.adb, a-tags.adb, sem_prag.adb,
+ sem_ch12.adb, xref_lib.adb, a-strunb-shared.adb, rtsfind.adb,
+ freeze.adb, sem_attr.adb, sem_case.adb, exp_ch4.adb, ghost.adb,
+ exp_ch6.adb, sem_ch4.adb, restrict.adb, s-os_lib.adb: Minor
+ reformatting.
+
+2016-10-12 Justin Squirek <squirek@adacore.com>
+
+ * sem_ch10.adb (Remove_Limited_With_Clause): Add a check to
+ detect accidental visibility.
+
+2016-10-12 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch4.adb (Expand_Allocator): If the expression is a qualified
+ expression, add a predicate check after the constraint check.
+ * sem_res.adb (Resolve_Qualified_Expression): If context is an
+ allocator, do not apply predicate check, as it will be done when
+ allocator is expanded.
+
+2016-10-12 Bob Duff <duff@adacore.com>
+
+ * xref_lib.adb: Use renamings-of-slices to ensure
+ that all references to Tables are properly bounds checked (when
+ checks are turned on).
+ * g-dyntab.ads, g-dyntab.adb: Default-initialize the array
+ components, so we don't get uninitialized pointers in case
+ of Tables containing access types. Misc cleanup of the code
+ and comments.
+
+2016-10-12 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute, case 'Type_Key): Implement
+ functionality of attribute, to provide a reasonably unique key
+ for a given type and detect any changes in the semantics of the
+ type or any of its subcomponents from version to version.
+
+2016-10-12 Bob Duff <duff@adacore.com>
+
+ * sem_case.adb (Check_Choice_Set): Separate
+ checking for duplicates out into a separate pass from checking
+ full coverage, because the check for duplicates does not depend
+ on predicates. Therefore, we shouldn't do it separately for the
+ predicate vs. no-predicate case; we should share code. The code
+ for the predicate case was wrong.
+
+2016-10-12 Jerome Lambourg <lambourg@adacore.com>
+
+ * init.c: Make sure to call finit on x86_64-vx7 to reinitialize
+ the FPU unit.
+
+2016-10-12 Arnaud Charlet <charlet@adacore.com>
+
+ * lib-load.adb (Load_Unit): Generate an error message even when
+ Error_Node is null.
+
+2016-10-12 Ed Schonberg <schonberg@adacore.com>
+
+ * lib-writ.adb (Write_ALI): Disable optimization related to transitive
+ limited_with clauses for now.
+
+2016-10-12 Javier Miranda <miranda@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute_Old_Result): Generating C
+ code handle 'old located in inlined _postconditions procedures.
+ (Analyze_Attribute [Attribute_Result]): Handle 'result when
+ rewriting the attribute as a reference to the formal parameter
+ _Result of inlined _postconditions procedures.
+
+2016-10-12 Tristan Gingold <gingold@adacore.com>
+
+ * s-rident.ads (Profile_Info): Remove
+ Max_Protected_Entries restriction from GNAT_Extended_Ravenscar
+ * sem_ch9.adb (Analyze_Protected_Type_Declaration):
+ Not a controlled type on restricted runtimes.
+
+2016-10-12 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_ch3.adb (Derive_Subprogram): Add test
+ for Is_Controlled of Parent_Type when determining whether an
+ inherited subprogram with one of the special names Initialize,
+ Adjust, or Finalize should be derived with its normal name even
+ when inherited as a private operation (which would normally
+ result in the inherited operation having a special "hidden" name).
+
+2016-10-12 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_res.adb (Resolve_Call): If a function call returns a
+ limited view of a type replace it with the non-limited view,
+ which must be available when compiling call. This was already
+ done elsewhere for non-overloaded calls, but needs to be done
+ after resolution if function name is overloaded.
+
+2016-10-12 Javier Miranda <miranda@adacore.com>
+
+ * a-tags.adb (IW_Membership [private]): new overloaded
+ subprogram that factorizes the code needed to check if a
+ given type implements an interface type.
+ (IW_Membership
+ [public]): invoke the new internal IW_Membership function.
+ (Is_Descendant_At_Same_Level): Fix this routine to implement RM
+ 3.9 (12.3/3)
+
+2016-10-12 Tristan Gingold <gingold@adacore.com>
+
+ * exp_ch9.adb (Expand_N_Delay_Relative_Statement): Add support
+ for a secondary procedure in case of missing Ada.Calendar.Delays
+ * rtsfind.ads (RTU_Id): Add System_Relative_Delays.
+ (RE_Id): Add RO_RD_Delay_For.
+ * rtsfind.adb (Output_Entity_Name): Handle correctly units RO_XX.
+ * s-rident.ads: Remove No_Relative_Delays
+ restriction for GNAT_Extended_Ravenscar.
+
+2016-10-12 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_elab.adb (Within_Initial_Condition): When deternining
+ the context of the expression, use the original node if it is
+ a pragma, because Check pragmas are rewritten as conditionals
+ when assertions are not enabled.
+
+2016-10-12 Bob Duff <duff@adacore.com>
+
+ * spitbol_table.ads, spitbol_table.adb (Adjust, Finalize): Add
+ "overriding".
+
+2016-10-12 Bob Duff <duff@adacore.com>
+
+ * a-strunb-shared.ads, a-strunb-shared.adb (Finalize):
+ Make sure Finalize is idempotent.
+ (Unreference): Check for
+ Empty_Shared_String, in case the reference count of the empty
+ string wraps around.
+ Also add "not null" in various places that can't be null.
+
+2016-10-12 Jerome Lambourg <lambourg@adacore.com>
+
+ * init.c: Fix sigtramp with the x86_64-vx7-vxsim target on
+ Windows host.
+
+2016-10-12 Vadim Godunko <godunko@adacore.com>
+
+ * s-os_lib.ads (Is_Owner_Readable_File): Renamed from
+ Is_Readable_File.
+ (Is_Owner_Writable_File): Renamed from Is_Writable_File.
+ (Is_Readable_File): Renames Is_Read_Accessible_File.
+ (Is_Writable_File): Renames Is_Write_Accessible_File.
+
+2016-10-12 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb (Check_Formal_Package_Instance): Skip an internal
+ formal entity without a parent only if the corresponding actual
+ entity has a different kind.
+ * exp_ch9.adb (Build_Class_Wide_Master): If the master is
+ declared locally, insert the renaming declaration after the
+ master declaration, to prevent access before elaboration in gigi.
+
+2016-10-12 Ed Schonberg <schonberg@adacore.com>
+
+ * contracts.adb (Analyze_Contracts): For a type declaration, analyze
+ an iterable aspect when present.
+
+2016-10-12 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb (Check_Formal_Package_Instance): Handle properly
+ an instance of a formal package with defaults, when defaulted
+ parameters include tagged private types and array types.
+
+2016-10-12 Eric Botcazou <ebotcazou@adacore.com>
+
+ PR ada/64057.
+ * exp_ch5.adb (Is_Non_Local_Array): Return true for every array
+ that is not a component or slice of an entity in the current
+ scope.
+
+2016-10-12 Tristan Gingold <gingold@adacore.com>
+
+ * restrict.ads, restrict.adb (Restricted_Profile): Adjust
+ comment, use Restricted_Tasking to compare restrictions.
+ * s-rident.ads (Profile_Name): Add Restricted_Tasking and
+ reorder literals.
+ (Profile_Info): Set restrictions for Restricted_Tasking.
+
+2016-10-12 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Analyze_Full_Type_Declaration): Set Ghost status
+ of type before elaborating inherited operations, so that the
+ Ghost status is set properly for them.
+ * ghost.adb (Check_Ghost_Overriding): A ghost subprogram can
+ override an abstract subprogram coming from an interface
+ operation.
+
+2016-10-11 Eric Botcazou <ebotcazou@adacore.com>
+
+ * system-linux-armeb.ads (Backend_Overflow_Checks): Change to True.
+ * system-linux-mips.ads (Backend_Overflow_Checks): Likewise.
+ * system-linux-mips64el.ads (Backend_Overflow_Checks): Likewise.
+ * system-linux-mipsel.ads (Backend_Overflow_Checks): Likewise.
+ * system-linux-sparcv9.ads (Backend_Overflow_Checks): Likewise.
+ * system-rtems.ads (Backend_Overflow_Checks): Likewise.
+
+2016-10-11 Andris Pavenis <andris.pavenis@iki.fi>
+
+ * adaint.c: Include process.h, signal.h, dir.h and utime.h for DJGPP.
+ ISALPHA: include <ctype.h> and define to isalpha for DJGPP when IN_RTS
+ is defined.
+ (DIR_SEPARATOR) define to '\\' for DJGPP.
+ (__gnat_get_file_names_case_sensitive): Return 0 for DJGPP unless
+ overriden in environment.
+ (__gnat_is_absolute_path): Support MS-DOS absolute paths for DJGPP.
+ (__gnat_portable_spawn): Use spewnvp for DJGPP.
+ (__gnat_portable_no_block_spawn): Use spawnvp for DJGPP.
+ (__gnat_portable_wait): Return 0 for DJGPP.
+
+2016-10-11 Andris Pavenis <andris.pavenis@iki.fi>
+
+ * gcc-interface/Makefile.in (LIBGNAT_TARGET_PAIRS): Define for DJGPP.
+ (EH_MECHANISM): Define to -gcc for DJGPP.
+ * system-djgpp.ads: New file.
+
+2016-10-11 Andris Pavenis <andris.pavenis@iki.fi>
+
+ * ctrl_c.c: Do not use macro SA_RESTART for DJGPP.
+ * gsocket.h: Do not support sockets for DJGPP.
+ * init.c (__gnat_install_handler): Implememt for DJGPP.
+ * sysdep.c: Include <io.h> for DJGPP.
+ (_setmode): Define to setmode for DJGPP.
+ (__gnat_set_mode): Add implementation for DJGPP.
+ (__gnat_localtime_tzoff): Use localtime_r for DJGPP.
+ * terminals.c: Add DJGPP to list of unsupported platforms.
+ * env.c (__gnat_clearenv): Use _gnat_unsetenv on all entries for DJGPP.
+
+2016-10-11 Pierre-Marie de Rodat <derodat@adacore.com>
+
+ * exp_dbug.adb (Debug_Renaming_Declaration): Process underlying types.
+ Emit GNAT encodings for object renamings involving record components
+ whose normalized bit offset is not null.
+ * uintp.h (UI_No_Uint): Declare.
+ * gcc-interface/gigi.h (can_materialize_object_renaming_p): Likewise.
+ * gcc-interface/utils.c (can_materialize_object_renaming_p): New
+ function.
+ * gcc-interface/trans.c (gnat_to_gnu) <N_Object_Renaming_Declaration>:
+ In code generation mode, materialize all renamings as long as they need
+ debug info and we are not optimizing.
+
+2016-10-11 Pierre-Marie de Rodat <derodat@adacore.com>
+
+ * gcc-interface/utils2.c (build_binary_op): Add a NO_FOLD argument.
+ Disable folding when it is true.
+ * gcc-interface/gigi.h (choices_to_gnu): Remove declaration.
+ (build_binary_op): Update signature and comment.
+ * gcc-interface/decl.c (choices_to_gnu): Make static. Disable
+ folding in calls to build_binary_op.
+
+2016-10-11 Tristan Gingold <gingold@adacore.com>
+
+ * fe.h (Constant_Value): Declare.
+ * gcc-interface/decl.c (compile_time_known_address_p): Also consider
+ references to constants.
+
+2016-10-11 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.c (gnat_to_gnu) <N_Op_Add>: Adjust comment.
+ <N_Op_Minus>: Add comment and missing guard.
+ * gcc-interface/trans.c (build_binary_op_trapv): Use an explicit test.
+
+2016-10-11 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/utils.c (type_unsigned_for_rm): New predicate.
+ (make_type_from_size): Use it.
+ (unchecked_convert): Likewise. Do not skip the extension step if the
+ source type is not integral.
+
+2016-10-11 Eric Botcazou <ebotcazou@adacore.com>
+ Tristan Gingold <gingold@adacore.com>
+
+ * system-linux-ppc64.ads: Delete.
+ * system-linux-ppc.ads: Make 32-bit/64-bit neutral.
+ * gcc-interface/Makefile.in (PowerPC/Linux): Simplify.
+
+2016-10-10 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity): Put volatile qualifier
+ on types at the very end of the processing.
+ (gnat_to_gnu_param): Remove redundant test.
+ (change_qualified_type): Do nothing for unconstrained array types.
+
+2016-10-10 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/utils2.c (find_common_type): Do not return the LHS type
+ if it's an array with non-constant lower bound and the RHS type is an
+ array with a constant one.
+
+2016-10-10 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/utils.c (convert): For a biased input type, convert the
+ bias itself to the base type before adding it.
+
+2016-10-08 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/utils.c (convert) <VECTOR_CST>: Add missing break.
+
+ Revert
+ 2016-09-26 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
+
+ * gcc-interface/decl.c: Fix fall through comment formatting.
+ * gcc-interface/misc.c: Likewise.
+ * gcc-interface/trans.c: Likewise.
+ * gcc-interface/utils.c: Likewise.
+ * gcc-interface/utils2.c: Likewise.
+
+2016-09-29 James Greenhalgh <james.greenhalgh@arm.com>
+
+ * gcc-interface/misc.c (gnat_post_options): Remove special case for
+ TARGET_FLT_EVAL_METHOD_NON_DEFAULT with -fexcess-precision=standard.
+
+2016-09-27 Jakub Jelinek <jakub@redhat.com>
+
+ * terminals.c (is_gui_app): Remove break after return.
+
+2016-09-26 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
+
+ * gcc-interface/decl.c: Fix fall through comment formatting.
+ * gcc-interface/misc.c: Likewise.
+ * gcc-interface/trans.c: Likewise.
+ * gcc-interface/utils.c: Likewise.
+ * gcc-interface/utils2.c: Likewise.
+
+2016-09-23 Jakub Jelinek <jakub@redhat.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity): Use
+ CONSTRUCTOR_NELTS (...) instead of
+ vec_safe_length (CONSTRUCTOR_ELTS (...)).
+
+2016-07-14 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Access_Type>: Also use
+ the void pointer type if the designated type is incomplete and has no
+ full view in LTO mode.
+ <E_Access_Protected_Subprogram_Type>: Adjust comment.
+ <E_Incomplete_Type>: Likewise.
+ * gcc-interface/trans.c (Call_to_gnu): Do not convert to the type of
+ the actual if it is a dummy type.
+
+2016-07-11 Bernd Edlinger <bernd.edlinger@hotmail.de>
+
+ * gcc-interface/ada-tree.h (TYPE_ALIGN_OK): Define.
+ * gcc-interface/trans.c (Attribute_to_gnu): Adjust call to
+ get_inner_reference.
+ * gcc-interface/utils2.c (build_unary_op): Likewise.
+
+2016-07-11 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.c (add_decl_expr): Minor tweak.
+ * gcc-interface/utils.c (create_var_decl): For an external variable,
+ also clear TREE_READONLY in LTO mode if the initializer is not a valid
+ constant and set DECL_READONLY_ONCE_ELAB instead.
+
+2016-07-11 Eric Botcazou <ebotcazou@adacore.com>
+
+ PR ada/71817
+ * adaint.c (__gnat_is_read_accessible_file): Add parentheses.
+ (__gnat_is_write_accessible_file): Likewise.
+
+2016-07-07 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch6.adb (Expand_Internal_Init_Call): Subsidiary procedure
+ to Expand_Protected_ Subprogram_Call, to handle properly a
+ call to a protected function that provides the initialization
+ expression for a private component of the same protected type.
+ * sem_ch9.adb (Analyze_Protected_Definition): Layout must be
+ applied to itypes generated for a private operation of a protected
+ type that has a formal of an anonymous access to subprogram,
+ because these itypes have no freeze nodes and are frozen in place.
+ * sem_ch4.adb (Analyze_Selected_Component): If prefix is a
+ protected type and it is not a current instance, do not examine
+ the first private component of the type.
+
+2016-07-07 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_imgv.adb, g-dynhta.adb, s-regexp.adb, s-fatgen.adb, s-poosiz.adb:
+ Minor removal of extra whitespace.
+ * einfo.ads: minor removal of repeated "as" in comment
+
+2016-07-07 Vadim Godunko <godunko@adacore.com>
+
+ * adaint.c: Complete previous change.
+
+2016-07-07 Vadim Godunko <godunko@adacore.com>
+
+ * adainit.h, adainit.c (__gnat_is_read_accessible_file): New
+ subprogram.
+ (__gnat_is_write_accessible_file): New subprogram.
+ * s-os_lib.ads, s-os_lib.adb (Is_Read_Accessible_File): New subprogram.
+ (Is_Write_Accessible_File): New subprogram.
+
+2016-07-07 Justin Squirek <squirek@adacore.com>
+
+ * sem_ch12.adb (Install_Body): Minor refactoring in the order
+ of local functions.
+ (In_Same_Scope): Change loop condition to be more expressive.
+
+2016-07-07 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_ch3.adb, sem_prag.adb, sem_prag.ads, prj-ext.adb, freeze.adb,
+ sem_attr.adb: Minor reformatting, fix typos.
+
+2016-07-07 Justin Squirek <squirek@adacore.com>
+
+ * sem_ch12.adb (In_Same_Scope): Created this function to check
+ a generic package definition against an instantiation for scope
+ dependancies.
+ (Install_Body): Add function In_Same_Scope and
+ amend conditional in charge of delaying the package instance.
+ (Is_In_Main_Unit): Add guard to check if parent is present in
+ assignment of Current_Unit.
+
+2016-07-07 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Remove redundant test,
+ adjust comments and formatting.
+ * sem_prag.adb (Inlining_Not_Possible): Do not test Front_End_Inlining
+ here but...
+ (Make_Inline): ...here before calling Inlining_Not_Possible instead.
+ (Set_Inline_Flags): Remove useless test.
+ (Analyze_Pragma) <Pragma_Inline>: Add comment about -gnatn switch.
+
+2016-07-07 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_prag.ads, sem_prag.adb (Build_Classwide_Expression): Include
+ overridden operation as parameter, in order to map formals of
+ the overridden and overring operation properly prior to rewriting
+ the inherited condition.
+ * freeze.adb (Check_Inherited_Cnonditions): Change call to
+ Build_Class_Wide_Expression accordingly. In Spark_Mode, add
+ call to analyze the contract of the parent operation, prior to
+ mapping formals between operations.
+
+2016-07-07 Arnaud Charlet <charlet@adacore.com>
+
+ * adabkend.adb (Scan_Back_End_Switches): Ignore -o/-G switches
+ as done in back_end.adb.
+ (Scan_Compiler_Args): Remove special case for CodePeer/SPARK, no longer
+ needed, and prevents proper handling of multi-unit sources.
+
+2016-07-07 Thomas Quinot <quinot@adacore.com>
+
+ * g-sechas.adb, g-sechas.ads (GNAT.Secure_Hashes.H): Add Hash_Stream
+ type with Write primitive calling Update on the underlying context
+ (and dummy Read primitive raising P_E).
+
+2016-07-07 Thomas Quinot <quinot@adacore.com>
+
+ * sem_ch13.adb: Minor reformatting.
+
+2016-07-07 Thomas Quinot <quinot@adacore.com>
+
+ * g-socket.ads: Document performance consideration for stream
+ wrapper.
+
+2016-07-07 Arnaud Charlet <charlet@adacore.com>
+
+ * osint-c.ads (Set_File_Name): Clarify spec.
+
+2016-07-07 Eric Botcazou <ebotcazou@adacore.com>
+
+ * freeze.adb: Reenable code.
+
+2016-07-07 Yannick Moy <moy@adacore.com>
+
+ * sem_ch6.adb (Process_Formals): Set ghost flag
+ on formal entities of ghost subprograms.
+ * ghost.adb (Check_Ghost_Context.Is_OK_Ghost_Context): Accept ghost
+ entities in use type clauses.
+
+2016-07-06 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch6.adb (Check_Inline_Pragma): if the subprogram has no spec
+ then move its aspects to the internally built subprogram spec.
+
+2016-07-06 Yannick Moy <moy@adacore.com>
+
+ * sem_ch6.adb (Analyze_Expression_Function): Mark body of
+ expression function as ghost if needed when created.
+ * sem_prag.adb (Analyze_Pragma.Process_Inline.Set_Inline_Flags):
+ Remove special case.
+
+2016-07-06 Arnaud Charlet <charlet@adacore.com>
+
+ * lib.adb (Check_Same_Extended_Unit): Complete previous change.
+ * sem_intr.adb (Errint): New parameter Relaxed. Refine previous
+ change to only disable errors selectively.
+ * sem_util.adb: minor style fix in object declaration
+
+2016-07-06 Yannick Moy <moy@adacore.com>
+
+ * sem_warn.adb (Check_Infinite_Loop_Warning.Find_Var): Special case a
+ call to a volatile function, so that it does not lead to a warning in
+ that case.
+
+2016-07-06 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch12.adb, sem_ch4.adb, sem_ch6.adb: Minor reformatting.
+
+2016-07-06 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * gnat1drv.adb: Code clean up. Do not emit any
+ code generation errors when the unit is ignored Ghost.
+
+2016-07-06 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_eval.adb (Check_Non_Static_Context): If the expression
+ is a real literal of a floating point type that is part of a
+ larger expression and is not a static expression, transform it
+ into a machine number now so that the rest of the computation,
+ even if other components are static, is not evaluated with
+ extra precision.
+
+2016-07-06 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch13.adb (Freeze_Entity_Checks): Undo previous patch and move the
+ needed functionality to Analyze_Freeze_Generic_Entity.
+ (Analyze_Freeze_Generic_Entity): If the entity is not already frozen
+ and has delayed aspects then analyze them.
+
+2016-07-06 Yannick Moy <moy@adacore.com>
+
+ * sem_prag.adb (Analyze_Pragma.Process_Inline.Set_Inline_Flags):
+ Special case for unanalyzed body entity of ghost expression function.
+
+2016-07-06 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch7.adb (Analyze_Package_Specification): Insert its
+ freezing nodes after the last declaration. Needed to ensure
+ that global entities referenced in aspects of frozen types are
+ properly handled.
+ * freeze.adb (Freeze_Entity): Minor code reorganization to ensure
+ that freezing nodes of generic packages are handled.
+ * sem_ch13.adb (Freeze_Entity_Checks): Handle N_Freeze_Generic nodes.
+ * sem_ch12.adb (Save_References_In_Identifier): Handle selected
+ components which denote a named number that is constant folded
+ in the analyzed copy of the tree.
+
+2016-07-06 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_aggr.adb Remove with and use clauses for Exp_Ch11 and Inline.
+ (Initialize_Array_Component): Protect the initialization
+ statements in an abort defer / undefer block when the associated
+ component is controlled.
+ (Initialize_Record_Component): Protect the initialization statements
+ in an abort defer / undefer block when the associated component is
+ controlled.
+ (Process_Transient_Component_Completion): Use Build_Abort_Undefer_Block
+ to create an abort defer / undefer block.
+ * exp_ch3.adb Remove with and use clauses for Exp_ch11 and Inline.
+ (Default_Initialize_Object): Use Build_Abort_Undefer_Block to
+ create an abort defer / undefer block.
+ * exp_ch5.adb (Expand_N_Assignment_Statement): Mark an abort
+ defer / undefer block as such.
+ * exp_ch9.adb (Find_Enclosing_Context): Do not consider an abort
+ defer / undefer block as a suitable context for an activation
+ chain or a master.
+ * exp_util.adb Add with and use clauses for Exp_Ch11.
+ (Build_Abort_Undefer_Block): New routine.
+ * exp_util.ads (Build_Abort_Undefer_Block): New routine.
+ * sinfo.adb (Is_Abort_Block): New routine.
+ (Set_Is_Abort_Block): New routine.
+ * sinfo.ads New attribute Is_Abort_Block along with occurrences
+ in nodes.
+ (Is_Abort_Block): New routine along with pragma Inline.
+ (Set_Is_Abort_Block): New routine along with pragma Inline.
+
+2016-07-06 Justin Squirek <squirek@adacore.com>
+
+ * sem_ch4.adb (Analyze_One_Call): Add a conditional to handle
+ disambiguation.
+
+2016-07-06 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * einfo.adb Flag252 is now used as Is_Finalized_Transient. Flag295
+ is now used as Is_Ignored_Transient.
+ (Is_Finalized_Transient): New routine.
+ (Is_Ignored_Transient): New routine.
+ (Is_Processed_Transient): Removed.
+ (Set_Is_Finalized_Transient): New routine.
+ (Set_Is_Ignored_Transient): New routine.
+ (Set_Is_Processed_Transient): Removed.
+ (Write_Entity_Flags): Output Flag252 and Flag295.
+ * einfo.ads: New attributes Is_Finalized_Transient
+ and Is_Ignored_Transient along with occurrences in
+ entities. Remove attribute Is_Processed_Transient.
+ (Is_Finalized_Transient): New routine along with pragma Inline.
+ (Is_Ignored_Transient): New routine along with pragma Inline.
+ (Is_Processed_Transient): Removed along with pragma Inline.
+ (Set_Is_Finalized_Transient): New routine along with pragma Inline.
+ (Set_Is_Ignored_Transient): New routine along with pragma Inline.
+ (Set_Is_Processed_Transient): Removed along with pragma Inline.
+ * exp_aggr.adb Add with and use clauses for Exp_Ch11 and Inline.
+ (Build_Record_Aggr_Code): Change the handling
+ of controlled record components.
+ (Ctrl_Init_Expression): Removed.
+ (Gen_Assign): Add new formal parameter In_Loop
+ along with comment on usage. Remove local variables Stmt and
+ Stmt_Expr. Change the handling of controlled array components.
+ (Gen_Loop): Update the call to Gen_Assign.
+ (Gen_While): Update the call to Gen_Assign.
+ (Initialize_Array_Component): New routine.
+ (Initialize_Ctrl_Array_Component): New routine.
+ (Initialize_Ctrl_Record_Component): New routine.
+ (Initialize_Record_Component): New routine.
+ (Process_Transient_Component): New routine.
+ (Process_Transient_Component_Completion): New routine.
+ * exp_ch4.adb (Process_Transient_In_Expression): New routine.
+ (Process_Transient_Object): Removed. Replace all existing calls
+ to this routine with calls to Process_Transient_In_Expression.
+ * exp_ch6.adb (Expand_Ctrl_Function_Call): Remove local constant
+ Is_Elem_Ref. Update the comment on ignoring transients.
+ * exp_ch7.adb (Process_Declarations): Do not process ignored
+ or finalized transient objects.
+ (Process_Transient_In_Scope): New routine.
+ (Process_Transients_In_Scope): New routine.
+ (Process_Transient_Objects): Removed. Replace all existing calls
+ to this routine with calls to Process_Transients_In_Scope.
+ * exp_util.adb (Build_Transient_Object_Statements): New routine.
+ (Is_Finalizable_Transient): Do not consider a transient object
+ which has been finalized.
+ (Requires_Cleanup_Actions): Do not consider ignored or finalized
+ transient objects.
+ * exp_util.ads (Build_Transient_Object_Statements): New routine.
+ * sem_aggr.adb: Major code clean up.
+ * sem_res.adb: Update documentation.
+
+2016-07-06 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Analyze_Subtype_Declaration): For generated
+ subtypes, such as actual subtypes of unconstrained formals,
+ inherit predicate functions, if any, from the parent type rather
+ than creating redundant new ones.
+
+2016-07-06 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_attr.adb, sem_attr.adb, sem_ch13.adb: Minor reformatting.
+
+2016-07-06 Arnaud Charlet <charlet@adacore.com>
+
+ * lib.adb (Check_Same_Extended_Unit): Prevent looping forever.
+ * gnatbind.adb: Disable some consistency checks in codepeer mode,
+ which are not needed.
+
+2016-07-06 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb (Check_Fixed_Point_Actual): Add a warning when
+ a formal fixed point type is instantiated with a type that has
+ a user-defined arithmetic operations, but the generic has no
+ corresponding formal functions. This is worth a warning because
+ of the special semantics of fixed-point operators.
+
+2016-07-06 Bob Duff <duff@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): Allow any expression of
+ discrete type.
+ * exp_attr.adb (Expand_N_Attribute_Reference): Change the
+ constant-folding code to correctly handle cases newly allowed
+ by Analyze_Attribute.
+
+2016-07-05 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity): Invoke global_bindings_p
+ last when possible. Do not call elaborate_expression_2 on offsets in
+ local record types and avoid useless processing for constant offsets.
+
+2016-07-04 Arnaud Charlet <charlet@adacore.com>
+
+ * gnat_rm.texi, gnat_ugn.texi,
+ doc/gnat_ugn/gnat_project_manager.rst,
+ doc/gnat_ugn/building_executable_programs_with_gnat.rst,
+ doc/gnat_ugn/elaboration_order_handling_in_gnat.rst,
+ doc/gnat_ugn/about_this_guide.rst,
+ doc/gnat_ugn/platform_specific_information.rst,
+ doc/gnat_ugn/tools_supporting_project_files.rst,
+ doc/gnat_ugn/gnat_and_program_execution.rst,
+ doc/gnat_ugn/gnat_utility_programs.rst,
+ doc/gnat_ugn/the_gnat_compilation_model.rst,
+ doc/gnat_rm/implementation_defined_attributes.rst,
+ doc/gnat_rm/implementation_defined_pragmas.rst,
+ doc/gnat_rm/representation_clauses_and_pragmas.rst,
+ doc/gnat_rm/standard_and_implementation_defined_restrictions.rst,
+ doc/gnat_ugn.rst: Update documentation.
+
+2016-07-04 Arnaud Charlet <charlet@adacore.com>
+
+ * gcc-interface/Makefile.in: Cleanups.
+
+2016-07-04 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute_Old_Result): The attributes can
+ appear in the postcondition of a subprogram renaming declaration,
+ when the renamed entity is an attribute reference that is a
+ function (such as 'Value).
+ * sem_attr.adb (Eval_Attribute): It doesn't
+ need to be static, just known at compile time, so use
+ Compile_Time_Known_Value instead of Is_Static_Expression.
+ This is an efficiency improvement over the previous bug fix.
+ * sem_ch13.adb (Analyze_One_Aspect): Use Original_Node to detect
+ illegal aspects on subprogram renaming declarations that may
+ have been rewritten as bodies.
+
+2016-07-04 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_intr.adb (Errint): Do not emit error message in
+ Relaxed_RM_Semantics mode.
+
+2016-07-04 Bob Duff <duff@adacore.com>
+
+ * sem_attr.adb (Eval_Attribute): The code was assuming
+ that X'Enum_Rep, where X denotes a constant, can be constant
+ folded. Fix it so it makes that assumption only when X denotes
+ a STATIC constant.
+
+2016-07-04 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch4.adb (Compatible_Types_In_Predicate): New function
+ to handle cases where a formal of a predicate function and the
+ corresponding actual have different views of the same type.
+
+2016-07-04 Philippe Gil <gil@adacore.com>
+
+ * g-debpoo.adb (Free_Blocks) free blocks also until
+ Logically_Deallocated less than Maximum_Logically_Freed_Memory
+ (Dump) add dump of number of traceback & validity elements
+ already allocated.
+
+2016-07-04 Justin Squirek <squirek@adacore.com>
+
+ * sem_ch12.adb (Instantiate_Package_Body): Add
+ a guard to ignore Itypes which fail when installing primitives.
+
+2016-07-04 Bob Duff <duff@adacore.com>
+
+ * sem_eval.adb (Decompose_Expr): Set 'out' parameters
+ Kind and Cons to valid values, to avoid use of uninit vars.
+ (Extract_Length): Reorder the check to make it clearer that
+ we're depending on BOTH Ent1 and Ent2 to be Present.
+ * sem_aggr.adb (Resolve_Aggregate): Remove dead code.
+ (Check_Misspelled_Component): Remove exit statement, because
+ it's covered by the 'while' condition.
+ * checks.adb (Apply_Selected_Range_Checks): Remove useless
+ condition "or else not Checks_On".
+ (Selected_Range_Checks):
+ Initialize Known_LB and Known_HB to False, because they are
+ tested unconditionally; avoid use of uninit vars.
+ * frontend.adb (Frontend): Removed useless condition
+ "Operating_Mode = Check_Semantics and then", and added an Assert
+ to clarify why it was useless.
+ * prep.adb (Preprocess): Remove redundant condition. Add an
+ assertion.
+ * sem_ch10.adb (Analyze_Proper_Body): Moved redundant condition
+ "Original_Operating_Mode = Generate_Code" to an Assert.
+ (Process_Spec_Clauses, Process_Body_Clauses): Change parameters
+ from 'in out' to 'out', and don't initialize actuals.
+ * sem_ch12.adb (Is_In_Main_Unit): Removed useless condition
+ "Unum = Main_Unit or else".
+ (Save_Global_Descendant): Moved
+ redundant condition "D = Union_Id (No_List)" to an Assert.
+ * sem_ch4.adb (Check_Misspelled_Selector): Remove exit
+ statement, because it's covered by the 'while' condition.
+ (Analyze_Case_Expression): Initialize Wrong_Alt to Empty,
+ because it looks like it is used uninitialized otherwise.
+ * sem_ch6.adb (Check_Return_Subtype_Indication): Moved redundant
+ condition "not R_Type_Is_Anon_Access" to an Assert.
+ * sem_elim.adb (Line_Num_Match): Moved redundant condition
+ "Sloc_Trace (Idx) = '['" to an Assert.
+ * sem_util.adb (Compile_Time_Constraint_Error): Change "J" to
+ "J - 1". This code is trying to replace "?" with "<", but not if
+ the "?" is quoted, as in "'?", so we want to check the PREVIOUS
+ character for '''.
+ * snames.adb-tmpl (Is_Pragma_Name): Remove useless condition
+ "or else N = Name_Relative_Deadline". It's useless because
+ Name_Relative_Deadline is in the range First_Pragma_Name
+ .. Last_Pragma_Name.
+ * treepr.adb (Visit_Node): Moved redundant condition "D =
+ Union_Id (No_List)" to an Assert.
+ * sem_ch3.adb (Derive_Subprogram, Derive_Subprograms): Change
+ parameters from 'in out' to 'out'.
+ * errout.adb (Error_Msg_Internal): Replace redundant test with Assert.
+ * inline.adb (Add_Inlined_Body): Code cleanup.
+
+2016-07-04 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * g-sercom-mingw.adb, sem_ch6.adb: Minor reformatting.
+
+2016-07-04 Olivier Hainque <hainque@adacore.com>
+
+ * g-sercom-mingw.adb (Set): Fix port configuration for the
+ non-blocking + null-timeout case, request of immediate return.
+
+2016-07-04 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Is_Non_Overriding_Operation): Add guard to test
+ of generic parent type when operation is a parameterless function
+ that may dispatch on result.
+
+2016-07-04 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * freeze.adb, ghost.adb, sem_ch13.adb: Minor reformatting.
+
+2016-07-04 Pascal Obry <obry@adacore.com>
+
+ * g-forstr.ads: More documentation for the Formatted_String
+ support.
+
+2016-07-04 Justin Squirek <squirek@adacore.com>
+
+ * sem_ch7.adb (Install_Parent_Private_Declarations): When
+ instantiating a child unit, do not install private declaration of
+ a non-generic ancestor of the generic that is also an ancestor
+ of the current unit: its private part will be installed when
+ private part of ancestor itself is analyzed.
+
+2016-07-04 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb (Instantiate_Object): In SPARK mode add a guard
+ to verify that the actual is an object reference before checking
+ for volatility.
+ (Check_Generic_Child_Unit): Prevent cascaded errors when prefix
+ is illegal.
+
+2016-07-04 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_ch12.ads, freeze.adb: Minor reformatting and typo fixes.
+
+2016-07-04 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch13.adb (New_Stream_Subprogram): If the attribute
+ definition clause comes from an aspect specification, place the
+ generated subprogram renaming in the freeze actions of the type.
+
+2016-07-04 Philippe Gil <gil@adacore.com>
+
+ * g-debpoo.adb (Dump.Do_Report) - add space prefix to backtrace
+ address dump - avoid new line sent directly to stdout.
+
+2016-07-04 Arnaud Charlet <charlet@adacore.com>
+
+ * gnat1drv.adb, sem_ch12.adb, sem_elab.adb, sem_prag.adb, sem_res.adb:
+ Relax elaboration checks in SPARK_Mode so that we rely on the
+ static elaboration model (if used). We'll have a more precise
+ check performed in flow analysis of gnat2why.
+
+2016-07-04 Ed Schonberg <schonberg@adacore.com>
+
+ * ghost.adb (Prune_Node): A freeze node for an ignored ghost
+ entity must be pruned as well.
+
+2016-07-04 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_type.adb, einfo.ads, freeze.adb, exp_ch6.adb: Minor reformatting
+ and typo fix.
+
+2016-07-04 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch3.adb, sem_type.adb, sem_ch12.adb, xref_lib.adb,
+ freeze.adb, sinput-l.adb, sinput-l.ads, sem_ch4.adb, sem_ch8.adb:
+ Minor reformatting.
+
+2016-07-04 Justin Squirek <squirek@adacore.com>
+
+ * sem_prag.adb (Analyze_Unmodified_Or_Unused and
+ Analyze_Unreferenced_Or_Unused): Change warning message to be
+ more clear about pragma duplicates.
+
+2016-07-04 Yannick Moy <moy@adacore.com>
+
+ * sinput-l.adb (Create_Instantiation_Source): Set component
+ Inlined_Call for inherited pragma case.
+ * sinput.adb, sinput.ads (Instantiation): Return component
+ Inlined_Call for inherited pragma case.
+
+2016-07-04 Bob Duff <duff@adacore.com>
+
+ * sem_type.adb (Remove_Conversions): Protect
+ the call to Left_Opnd by checking for Nkind in N_Unary_Op --
+ unary operators do not have a left operand.
+
+2016-07-04 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Analyze_Object_Declaration): A declaration of a
+ constant in a protected operation may be a homonym of a private
+ component of the enclosing protected type. This declaration hides
+ the component renaming constructed within the protected operation.
+
+2016-07-04 Bob Duff <duff@adacore.com>
+
+ * xref_lib.adb (Parse_X_Filename, Parse_Identifier_Info): Ignore
+ unknown files. Check that File_Nr is in the range of files we
+ know about. The previous code was checking the lower bound,
+ but not the upper bound.
+
+2016-07-04 Arnaud Charlet <charlet@adacore.com>
+
+ * tracebak.c: Minor reformatting.
+
+2016-07-04 Yannick Moy <moy@adacore.com>
+
+ * sem_ch12.adb, sem_ch12.ads Update calls to
+ Create_Instantiation_Source to use default argument.
+ (Adjust_Inherited_Pragma_Sloc): New function to adjust sloc
+ of inherited pragma.
+ (Set_Copied_Sloc_For_Inherited_Pragma):
+ New function that wraps call to Create_Instantiation_Source for
+ copying an inherited pragma.
+ (Set_Copied_Sloc_For_Inlined_Body): Update call to
+ Create_Instantiation_Source with new arguments.
+ * sem_prag.adb (Build_Pragma_Check_Equivalent): In the case
+ of inherited pragmas, use the generic machinery to get chained
+ locations for the pragma and its sub-expressions.
+ * sinput-c.adb: Adapt to new type Source_File_Record.
+ * sinput-l.adb, sinput-l.ads (Create_Instantiation_Source):
+ Add parameter Inherited_Pragma and make parameter Inlined_Body
+ optional.
+ * sinput.adb, sinput.ads (Comes_From_Inherited_Pragma): New
+ function to return when a location comes from an inherited pragma.
+ (Inherited_Pragma): New function to detect when a location comes
+ from an inherited pragma.
+ (Source_File_Record): New component Inherited_Pragma.
+
+2016-07-04 Yannick Moy <moy@adacore.com>
+
+ * sem_elab.adb: Register existence of quickfix for error message.
+
+2016-07-04 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch4.adb (Resolve_One_Call): In the context of a predicate
+ function the formal and the actual in a call may have different
+ views of the same type, because of the delayed analysis of
+ predicates aspects. Extend the patch that handles this potential
+ discrepancy to handle private and full views as well.
+ * sem_ch8.adb (Find_Selected_Component): Refine predicate that
+ produces additional error when an illegal selected component
+ looks like a prefixed call whose first formal is untagged.
+
+2016-07-04 Justin Squirek <squirek@adacore.com>
+
+ * einfo.adb (Has_Pragma_Unused): Create this function as a setter
+ for a new flag294 (Set_Has_Pragma_Unused): Create this procedure
+ as a getter for flag294 (Write_Entity_Flags): Register the new
+ flag with an alias
+ * einfo.ads Add comment documenting Has_Pragma_Unused (flag294)
+ and subsequent getter and setter declarations.
+ * lib-xref.adb (Generate_Reference): Recognize Has_Pragma_Unused
+ flag to print appropriate warning messages.
+ * par-prag.adb (Prag): Classify Pragma_Unused into "All Other
+ Pragmas."
+ * snames.ads-tmpl Add a new name to the name constants and a
+ new pramga to Pragma_Id for pramga Unused.
+ * sem_prag.adb (Analyze_Pragma): Create case for Pragma_Unused
+ and move the block for Pragma_Unmodified and Pragma_Unreferenced
+ out and into local subprograms.
+ (Analyze_Unmodified, Analyze_Unreferenced): From the old pragma blocks
+ that have been separated in to local subprograms add a parameter to
+ indicate the if they are being called in the context of Pragma_Unused
+ and handle it accordingly.
+ (Is_Non_Significant_Pragma_Reference): Add an entry for Pragma_Unused
+ and correct the position of Pragma_Unevaluated_Use_Of_Old.
+ * sem_util.adb (Note_Possible_Modification): Recognize
+ Has_Pragma_Unused flag to print appropriate warning messages.
+
+2016-07-04 Ed Schonberg <schonberg@adacore.com>
+
+ * freeze.adb (Check_Inherited_Conditions): Perform two passes over
+ the primitive operations of the type: one over source overridings
+ to build the primitives mapping, and one over inherited operations
+ to check for the need to create wrappers, and to check legality
+ of inherited condition in SPARK.
+ * sem_prag.ads (Update_Primitive_Mapping): Make public, for use
+ in freeze actions.
+ * sem_prag.adb (Build_Pragma_Check_Equivalent): Refine error
+ message in the case of an inherited condition in SPARK that
+ includes a call to some other overriding primitive.
+
+2016-07-04 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_aggr.adb (Ctrl_Init_Expression): New routine.
+ (Gen_Assign): Code cleanup. Perform in-place side effect removal when
+ the expression denotes a controlled function call.
+ * exp_util.adb (Remove_Side_Effects): Do not remove side effects
+ on a function call which has this behavior suppressed.
+ * sem_aggr.adb Code cleanup.
+ * sinfo.adb (No_Side_Effect_Removal): New routine.
+ (Set_Side_Effect_Removal): New routine.
+ * sinfo.ads New attribute No_Side_Effect_Removal along with
+ occurences in nodes.
+ (No_Side_Effect_Removal): New routine along with pragma Inline.
+ (Set_Side_Effect_Removal): New routine along with pragma Inline.
+
+2016-07-04 Arnaud Charlet <charlet@adacore.com>
+
+ * opt.ads, sem_prag.adb (Universal_Addressing_On_AAMP): Removed.
+ Remove support for pragma No_Run_Time. Update comments.
+
+2016-07-04 Pascal Obry <obry@adacore.com>
+
+ * g-forstr.ads: More documentation for the Formatted_String
+ support.
+
+2016-07-04 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch13.adb (Expand_N_Attribute_Definition_Clause, case
+ 'Address): If the address comes from an aspect specification
+ and not a source attribute definition clause, do not remove
+ side effects from the expression, because the expression must
+ be elaborated at the freeze point of the object and not at the
+ object declaration, because of the delayed analysis of aspect
+ specifications.
+
+2016-06-29 Eric Botcazou <ebotcazou@adacore.com>
+
+ PR ada/48835
+ PR ada/61954
+ * gcc-interface/gigi.h (enum standard_datatypes): Add ADT_realloc_decl
+ (realloc_decl): New macro.
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Variable>: Use local
+ variable for the entity type and translate it as void pointer if the
+ entity has convention C.
+ (gnat_to_gnu_entity) <E_Function>: If this is not a definition and the
+ external name matches that of malloc_decl or realloc_decl, return the
+ correspoding node directly.
+ (gnat_to_gnu_subprog_type): Likewise for parameter and return types.
+ * gcc-interface/trans.c (gigi): Initialize void_list_node here, not...
+ Initialize realloc_decl.
+ * gcc-interface/utils.c (install_builtin_elementary_types): ...here.
+ (build_void_list_node): Delete.
+ * gcc-interface/utils2.c (known_alignment) <CALL_EXPR>: Return the
+ alignment of the system allocator for malloc_decl and realloc_decl.
+ Do not take alignment from void pointer types either.
+
+2016-06-29 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/misc.c (LANG_HOOKS_WARN_UNUSED_GLOBAL_DECL): Reorder.
+ (LANG_HOOKS_INIT_TS): Likewise.
+
+2016-06-22 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_prag.adb: Revert unwanted change in previous commit,
+ only keep message fix.
+
+2016-06-22 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_prag.ads (Build_Classwide_Expression): new procedure to
+ build the expression for an inherited classwide condition, and
+ to validate such expressions when they apply to an inherited
+ operation that is not overridden.
+ * sem_prag.adb (Primitives_Mapping): new data structure to
+ handle the mapping between operations of a root type and the
+ corresponding overriding operations of a type extension. Used
+ to construct the expression for an inherited classwide condition.
+ (Update_Primitives_Mapping): add to Primitives_Mapping the links
+ between primitive operations of a root type and those of a given
+ type extension.
+ (Build_Pragma_Check_Equivalent): use Primitives_Mapping.
+ * sem_ch6.adb (New_Overloaded_Entity): Remove call to
+ Collect_Iherited_Class_Wide_Conditions in GNATprove_Mode. This
+ needs to be done at freeze point of the type.
+ * freeze.adb (Check_Inherited_Conditions): new procedure to
+ verify the legality of inherited classwide conditions. In normal
+ compilation mode the procedure determines whether an inherited
+ operation needs a wrapper to handle an inherited condition that
+ differs from the condition of the root type. In SPARK mode
+ the routine invokes Collect_Inherited_Class_Wide_Conditions to
+ produce the SPARK version of these inherited conditions.
+ (Freeze_Record_Type): For a type extension, call
+ Check_Inherited_Conditions.
+
+2016-06-22 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch3.adb, sem_type.adb, sem.adb, freeze.adb, sem_util.adb,
+ s-htable.adb, exp_ch11.adb, s-secsta.adb, restrict.adb, exp_disp.adb,
+ sem_ch8.adb, s-tpobop.adb, exp_aggr.ads, sem_ch13.adb: Minor
+ reformatting.
+
+2016-06-22 Yannick Moy <moy@adacore.com>
+
+ * lib-xref-spark_specific.adb (Collect_SPARK_Xrefs): Inverse order of
+ treatments so that files without compilation unit are simply skipped
+ before more elaborate treatments.
+
+2016-06-22 Bob Duff <duff@adacore.com>
+
+ * s-memory.ads: Minor typo fixes in comments.
+ * s-memory.adb: Code cleanup.
+
+2016-05-22 Olivier Hainque <hainque@adacore.com>
+
+ * vxworks-crtbe-link.spec: Removed, no longer used.
+
+2016-06-22 Justin Squirek <squirek@adacore.com>
+
+ * sem_ch8.adb (Push_Scope): Add a check for when the
+ scope table is empty to assign the global variable
+ Configuration_Component_Alignment.
+ * sem.adb (Do_Analyze): Add Configuration_Component_Alignment
+ to be assigned when the environment is cleaned instead of the
+ default.
+ * sem.ads Add a global variable Configuration_Component_Alignment
+ to store the value given by pragma Component_Alignment in the
+ context of a configuration file.
+ * sem_prag.adb (Analyze_Pragma): Correct the case for
+ Component_Alignment so that the pragma is verified and add
+ comments to explain how it is applied to the scope stack.
+
+2016-06-22 Justin Squirek <squirek@adacore.com>
+
+ * sprint.adb (Sprint_Node_Actual): Add check in
+ the case of an N_Object_Declaration when evaluating an expression
+ to properly ignore errors.
+
+2016-06-22 Bob Duff <duff@adacore.com>
+
+ * g-comlin.ads (Parameter_Type): Change subtype of Last to
+ Natural.
+ * g-comlin.adb (Set_Parameter): Change subtype of Last to
+ Natural.
+ (Getopt): Check for Arg = "", and Switches /= "".
+ (Internal_Initialize_Option_Scan): Check for Argument (Parser,
+ Index) /= "".
+
+2016-06-22 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_prag.adb, sem_ch8.adb: Minor reformatting.
+
+2016-06-22 Ed Schonberg <schonberg@adacore.com>
+
+ * einfo.ads, einfo.adb (Is_Actual_Subtype): New flag, defined
+ on subtypes that are created within subprogram bodies to handle
+ unconstrained composite formals.
+ * checks.adb (Apply_Predicate_Check): Do not generate a check on
+ an object whose type is an actual subtype.
+ * sem_ch6.adb (Set_Actual_Subtypes): Do not generate an
+ actual subtype for a formal whose base type is private.
+ Set Is_Actual_Subtype on corresponding entity after analyzing
+ its declaration.
+
+2016-06-22 Justin Squirek <squirek@adacore.com>
+
+ * sem_prag.adb (Check_Expr_Is_OK_Static_Expression): Fix ordering
+ of if-block and add in a condition to test for errors during
+ resolution.
+ * sem_res.adb (Resolution_Failed): Add comment to explain why
+ the type of a node which failed to resolve is set to the desired
+ type instead of Any_Type.
+ * sem_ch8.adb (Analyze_Object_Renaming): Add a check for Any_Type
+ to prevent crashes on Is_Access_Constant.
+
+2016-06-22 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * lib-xref-spark_specific.adb, checks.adb, sem_ch13.adb: Minor
+ reformatting.
+ * exp_ch7.adb: Minor typo fix.
+ * lib.ads (Get_Top_Level_Code_Unit): Add comment.
+
+2016-06-22 Bob Duff <duff@adacore.com>
+
+ * s-tassta.adb (Task_Wrapper): Fix handling of Fall_Back_Handler
+ wrt independent tasks.
+
+2016-06-22 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_dim.adb (Analyze_Dimension): Propagate dimension for
+ explicit_dereference nodes when they do not come from source,
+ to handle correctly dimensional analysis on iterators over
+ containers whose elements have declared dimensions.
+
+2016-06-22 Arnaud Charlet <charlet@adacore.com>
+
+ * spark_xrefs.ads (Scope_Num): type refined to positive integers.
+ * lib-xref-spark_specific.adb (Detect_And_Add_SPARK_Scope):
+ moved into scope of Collect_SPARK_Xrefs.
+ (Add_SPARK_Scope): moved into scope of Collect_SPARK_Xrefs;
+ now uses Dspec and Scope_Id from Collect_SPARK_Xrefs.
+ (Collect_SPARK_Xrefs): refactored to avoid retraversing the list
+ of scopes.
+ (Traverse_Compilation_Unit): refactored as a generic procedure.
+ * types.ads (Unit_Number_Type): range refined.
+
+2016-06-22 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * lib-xref-spark_specific.adb, a-cuprqu.ads, sem_ch6.adb: Minor
+ reformatting.
+
+2016-06-22 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_util.ads (Address_Value): Declare new function.
+ * sem_util.adb (Address_Value): New function extracted
+ unmodified from Apply_Address_Clause_Check, which returns the
+ underlying value of the expression of an address clause.
+ * checks.adb (Compile_Time_Bad_Alignment): Delete.
+ (Apply_Address_Clause_Check): Call Address_Value on
+ the expression. Do not issue the main warning here and
+ issue the secondary warning only when the value of the
+ expression is not known at compile time.
+ * sem_ch13.adb (Address_Clause_Check_Record): Add A component and
+ adjust the description.
+ (Analyze_Attribute_Definition_Clause): In the case
+ of an address, move up the code creating an entry in the table of
+ address clauses. Also create an entry for an absolute address.
+ (Validate_Address_Clauses): Issue the warning for absolute
+ addresses here too. Tweak condition associated with overlays
+ for consistency.
+
+2016-06-22 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch13.adb (Is_Predicate_Static): An inherited predicate
+ can be static only if it applies to a scalar type.
+
+2016-06-22 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_util.adb (Adjust_Result_Type): Convert operand to base
+ type to prevent spurious constraint checks on subtypes of Boolean.
+
+2016-06-22 Bob Duff <duff@adacore.com>
+
+ * debug.adb: Document debug switch -gnatd.o.
+ * sem_elab.adb (Check_Internal_Call): Debug switch -gnatd.o
+ now causes a more conservative treatment of indirect calls,
+ treating P'Access as a call to P in more cases. We Can't make
+ this the default, because it breaks common idioms, for example
+ the soft links.
+ * sem_util.adb: Add an Assert.
+
+2016-06-22 Bob Duff <duff@adacore.com>
+
+ * a-cuprqu.ads, a-cuprqu.adb: Completely rewrite this package. Use
+ red-black trees, which gives O(lg N) worst-case performance on
+ Enqueue and Dequeue. The previous version had O(N) Enqueue in
+ the worst case.
+
+2016-06-22 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_warn.adb: minor style fix in comment.
+ * spark_xrefs.ads (Scope_Num): type refined to positive integers.
+ * lib-xref-spark_specific.adb (Detect_And_Add_SPARK_Scope):
+ moved into scope of Collect_SPARK_Xrefs.
+ (Add_SPARK_Scope): moved into scope of Collect_SPARK_Xrefs;
+ now uses Dspec and Scope_Id from Collect_SPARK_Xrefs.
+ (Collect_SPARK_Xrefs): refactored to avoid retraversing the list
+ of scopes.
+ * sem_ch3.adb (Build_Discriminal): Set Parent of the discriminal.
+
+2016-06-22 Arnaud Charlet <charlet@adacore.com>
+
+ * lib-xref-spark_specific.adb (Generate_Dereference): Assignment to not
+ commented local variables replaced with direct uses of their values.
+
+2016-06-22 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch7.adb (Add_Invariant): Replace the
+ current type instance with the _object parameter even in ASIS mode.
+ (Build_Invariant_Procedure_Body): Do not insert the
+ invariant procedure body into the tree for ASIS and GNATprove.
+ (Build_Invariant_Procedure_Declaration): Do not insert the
+ invariant procedure declaration into the tree for ASIS and
+ GNATprove.
+ * lib-xref-spark_specific.adb (Add_SPARK_Scope): Update comment.
+
+2016-06-22 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Set_Actual_Subtypes): If the type of the actual
+ has predicates, the actual subtype must be frozen properly
+ because of the generated tests that may follow. The predicate
+ may be specified by an explicit aspect, or may be inherited in
+ a derivation.
+
+2016-06-22 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch4.adb (In_Range_Chec)): New predicate, subsidiary of
+ Expand_N_In: within an expanded range check that might raise
+ Constraint_Error do not generate a predicate check as well. It
+ is redundant because the context will add an explicit predicate
+ check, and it will raise the wrong exception if it fails.
+ * lib-xref-spark_specific.adb (Add_SPARK_File): Remove useless checks
+ since dependency units always have an associated compilation unit.
+
+2016-06-22 Arnaud Charlet <charlet@adacore.com>
+
+ * lib.ads: Code cleanup.
+ * inline.adb: Type refinement for a counter variable.
+ * lib-xref-spark_specific.adb (Add_SPARK_File): removal of no-op code.
+ Code cleanup.
+
+2016-06-21 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (set_nonaliased_component_on_array_type): New
+ function.
+ (set_reverse_storage_order_on_array_type): Likewise.
+ (gnat_to_gnu_entity) <E_Array_Type>: Call them to set the flags.
+ <E_Array_Subtype>: Likewise.
+ <E_String_Literal_Subtype>: Likewise.
+ (substitute_in_type) <ARRAY_TYPE>: Likewise.
+ * gcc-interface/utils.c (gnat_pushdecl): Always create a variant for
+ the DECL_ORIGINAL_TYPE of a type.
+
+2016-06-20 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * make.adb, gnatbind.adb, g-socket.adb, sem_ch13.adb: Minor
+ reformatting.
+ * lib.ads, sem_util.adb: Minor typo in comment.
+
+2016-06-20 Yannick Moy <moy@adacore.com>
+
+ * sem_prag.adb, sem_prag.ads (Build_Pragma_Check_Equivalent):
+ Add parameter Keep_Pragma_Id to optionally keep
+ the identifier of the pragma instead of converting
+ to pragma Check. Also set type of new function call
+ appropriately. (Collect_Inherited_Class_Wide_Conditions):
+ Call Build_Pragma_Check_Equivalent with the new parameter
+ Keep_Pragma_Id set to True to keep the identifier of the copied
+ pragma.
+ * sinfo.ads: Add comment.
+
+2016-06-20 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch7.adb (Build_Invariant_Procedure_Body):
+ Always install the scope of the invariant procedure
+ in order to produce better error messages. Do not
+ insert the body when the context is a generic unit.
+ (Build_Invariant_Procedure_Declaration): Perform minimal
+ decoration of the invariant procedure and its formal parameter
+ in case they are not analyzed. Do not insert the declaration
+ when the context is a generic unit.
+
+2016-06-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch13.adb (Visible_Component): New procedure, subsidiary
+ of Replace_Type_References_ Generic, to determine whether an
+ identifier in a predicate or invariant expression is a visible
+ component of the type to which the predicate or invariant
+ applies. Implements the visibility rule stated in RM 13.1.1
+ (12/3).
+
+2016-06-20 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * s-regpat.adb, sem_prag.adb, pprint.adb, sem_ch13.adb: Minor
+ reformatting.
+
+2016-06-20 Tristan Gingold <gingold@adacore.com>
+
+ * make.adb (Check_Standard_Library): Consider system.ads
+ if s-stalib.adb is not available.
+ * gnatbind.adb (Add_Artificial_ALI_File): New procedure extracted from
+ gnatbind.
+
+2016-06-20 Thomas Quinot <quinot@adacore.com>
+
+ * g-socket.adb (Is_IP_Address): A string consisting in digits only is
+ not a dotted quad.
+
+2016-06-20 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch7.adb (Build_Invariant_Procedure_Body):
+ decorate invariant procedure body with typical properties of
+ procedure entityes.
+
+2016-06-20 Arnaud Charlet <charlet@adacore.com>
+
+ * a-exetim-darwin.adb: New file.
+
+2016-06-16 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * atree.ads, atree.adb (Elist29): New routine.
+ (Set_Elist29): New routine.
+ * atree.h New definition for Elist29.
+ * einfo.adb Subprograms_For_Type is now an Elist rather than
+ a node. Has_Invariants is now a synthesized attribute
+ and does not require a flag. Has_Own_Invariants
+ is now Flag232. Has_Inherited_Invariants is
+ Flag291. Is_Partial_Invariant_Procedure is Flag292.
+ (Default_Init_Cond_Procedure): Reimplemented.
+ (Has_Inherited_Invariants): New routine.
+ (Has_Invariants): Reimplemented.
+ (Has_Own_Invariants): New routine.
+ (Invariant_Procedure): Reimplemented.
+ (Is_Partial_Invariant_Procedure): New routine.
+ (Partial_Invariant_Procedure): Reimplemented.
+ (Predicate_Function): Reimplemented.
+ (Predicate_Function_M): Reimplemented.
+ (Set_Default_Init_Cond_Procedure): Reimplemented.
+ (Set_Has_Inherited_Invariants): New routine.
+ (Set_Has_Invariants): Removed.
+ (Set_Has_Own_Invariants): New routine.
+ (Set_Invariant_Procedure): Reimplemented.
+ (Set_Is_Partial_Invariant_Procedure): New routine.
+ (Set_Partial_Invariant_Procedure): Reimplemented.
+ (Set_Predicate_Function): Reimplemented.
+ (Set_Predicate_Function_M): Reimplemented.
+ (Set_Subprograms_For_Type): Reimplemented.
+ (Subprograms_For_Type): Reimplemented.
+ (Write_Entity_Flags): Output Flag232 and Flag291.
+ * einfo.ads Add new attributes Has_Inherited_Invariants
+ Has_Own_Invariants Is_Partial_Invariant_Procedure
+ Partial_Invariant_Procedure Change the documentation
+ of attributes Has_Inheritable_Invariants Has_Invariants
+ Invariant_Procedure Is_Invariant_Procedure Subprograms_For_Type
+ (Has_Inherited_Invariants): New routine along with pragma Inline.
+ (Has_Own_Invariants): New routine along with pragma Inline.
+ (Is_Partial_Invariant_Procedure): New routine along with pragma Inline.
+ (Partial_Invariant_Procedure): New routine.
+ (Set_Has_Inherited_Invariants): New routine along with pragma Inline.
+ (Set_Has_Invariants): Removed along with pragma Inline.
+ (Set_Has_Own_Invariants): New routine along with pragma Inline.
+ (Set_Is_Partial_Invariant_Procedure): New routine
+ along with pragma Inline.
+ (Set_Partial_Invariant_Procedure): New routine.
+ (Set_Subprograms_For_Type): Update the signature.
+ (Subprograms_For_Type): Update the signature.
+ * exp_ch3.adb Remove with and use clauses for Sem_Ch13.
+ (Build_Array_Invariant_Proc): Removed.
+ (Build_Record_Invariant_Proc): Removed.
+ (Freeze_Type): Build the body of the invariant procedure.
+ (Insert_Component_Invariant_Checks): Removed.
+ * exp_ch7.adb Add with and use clauses for Sem_Ch6, Sem_Ch13,
+ and Stringt.
+ (Build_Invariant_Procedure_Body): New routine.
+ (Build_Invariant_Procedure_Declaration): New routine.
+ * exp_ch7.ads (Build_Invariant_Procedure_Body): New routine.
+ (Build_Invariant_Procedure_Declaration): New routine.
+ * exp_ch9.adb (Build_Corresponding_Record): Do not propagate
+ attributes related to invariants to the corresponding record
+ when building the corresponding record. This is done by
+ Build_Invariant_Procedure_Declaration.
+ * exp_util.adb (Make_Invariant_Call): Reimplemented.
+ * freeze.adb (Freeze_Array_Type): An array type requires an
+ invariant procedure when its component type has invariants.
+ (Freeze_Record_Type): A record type requires an invariant
+ procedure when at least one of its components has an invariant.
+ * sem_ch3.adb (Analyze_Private_Extension_Declaration): Inherit
+ invariant-related attributes.
+ (Analyze_Subtype_Declaration):
+ Inherit invariant-related attributes.
+ (Build_Derived_Record_Type): Inherit invariant-related attributes.
+ (Check_Duplicate_Aspects): Reimplemented.
+ (Get_Partial_View_Aspect): New routine.
+ (Process_Full_View): Inherit invariant-related attributes. Reimplement
+ the check on hidden inheritance of class-wide invariants.
+ (Remove_Default_Init_Cond_Procedure): Reimplemented.
+ * sem_ch6.adb (Analyze_Subprogram_Specification): Do not modify
+ the controlling type for an invariant procedure declaration
+ or body.
+ (Is_Invariant_Procedure_Or_Body): New routine.
+ * sem_ch7.adb (Analyze_Package_Specification): Build the partial
+ invariant body in order to preanalyze and resolve all invariants
+ of a private type at the end of the visible declarations. Build
+ the full invariant body in order to preanalyze and resolve
+ all invariants of a private type's full view at the end of
+ the private declarations.
+ (Preserve_Full_Attributes): Inherit invariant-related attributes.
+ * sem_ch9.adb (Analyze_Protected_Type_Declaration): Ensure that
+ aspects are analyzed with the proper view when the protected type
+ is a completion of a private type. Inherit invariant-related attributes.
+ (Analyze_Task_Type_Declaration): Ensure that
+ aspects are analyzed with the proper view when the task type
+ is a completion of a private type. Inherit invariant-related
+ attributes.
+ * sem_ch13.adb Remove with and use clauses for Stringt.
+ (Build_Invariant_Procedure_Declaration): Removed.
+ (Build_Invariant_Procedure): Removed.
+ (Freeze_Entity_Checks): Do not build the body of the invariant
+ procedure here.
+ The body is built when the type is frozen in Freeze_Type.
+ (Inherit_Aspects_At_Freeze_Point): Do not inherit any attributes
+ related to invariants here because this leads to erroneous
+ inheritance.
+ (Replace_Node): Rename to Replace_Type_Ref.
+ * sem_ch13.ads (Build_Invariant_Procedure_Declaration): Removed.
+ (Build_Invariant_Procedure): Removed.
+ * sem_prag.adb Add with and use clauses for Exp_Ch7.
+ (Analyze_Pragma): Reimplement the analysis of pragma Invariant.
+ * sem_res.adb (Resolve_Actuals): Emit a specialized error when
+ the context is an invariant.
+ * sem_util.adb (Get_Views): New routine.
+ (Incomplete_Or_Partial_View): Consider generic packages when
+ examining declarations.
+ (Inspect_Decls): Consider full type
+ declarations because they may denote a derivation from a
+ private type.
+ (Propagate_Invariant_Attributes): New routine.
+ * sem_util.ads (Get_Views): New routine.
+ (Propagate_Invariant_Attributes): New routine.
+
+2016-06-16 Arnaud Charlet <charlet@adacore.com>
+
+ * pprint.adb (Expression_Image): Add better handling of UCs,
+ we don't want to strip them all for clarity.
+
+
+2016-06-20 Kyrylo Tkachov <kyrylo.tkachov@arm.com>
+
+ * exp_util.adb (Safe_Unchecked_Type_Conversion): Use "alignment"
+ instead of "alignement".
+
+2016-06-16 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_util.adb: Minor typo fix.
+
+2016-06-16 Emmanuel Briot <briot@adacore.com>
+
+ * s-regpat.adb: Further fix for invalid index in GNAT.Regexp.
+
+2016-06-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch13.adb (Validate_Address_Clauses): Use the same logic to
+ issue the warning on the offset for the size as for the alignment
+ and tweak the wording for the sake of consistency.
+
+2016-06-16 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_prag.adb (Check_Class_Wide_COndition): New procedure,
+ subsidiary of Analyze_Pre_Post_ Condition_In_Decl_Part, to
+ check legality rules that follow from the revised semantics of
+ class-wide pre/postconditions described in AI12-0113.
+ (Build_Pragma_Check_Equivalent): Abstract subprogram declarations
+ must be included in list of overriding primitives of a derived
+ type.
+
+2016-06-16 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_util.adb (May_Be_Lvalue): An actual in an unexpanded
+ attribute reference 'Read is an assignment and must be considered
+ a modification of the object.
+
+2016-06-16 Gary Dismukes <dismukes@adacore.com>
+
+ * einfo.adb: Minor editorial.
+
+2016-06-16 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_prag.adb (Overridden_Ancestor): Clean up code to use
+ controlling type of desired primitive rather than its scope,
+ because the primitive that inherits the classwide condition may
+ comes from several derivation steps.
+
+2016-06-16 Javier Miranda <miranda@adacore.com>
+
+ * einfo.adb (Set_Default_Init_Cond_Procedure): Allow calls setting
+ this attribute to Empty (only if the attribute has not been set).
+ * sem_util.adb (Build_Default_Init_Cond_Procedure_Body):
+ No action needed if the spec was not built.
+ (Build_Default_Init_Cond_Procedure_Declaration): The spec is
+ not built if DIC is set to NULL or no condition was specified.
+ * exp_ch3.adb (Expand_N_Object_Declaration): Check availability
+ of the Init_Cond procedure before generating code to call it.
+
+2016-06-16 Emmanuel Briot <briot@adacore.com>
+
+ * s-regpat.adb: Fix invalid index check when matching end-of-line
+ on substrings.
+
+2016-06-16 Arnaud Charlet <charlet@adacore.com>
+
+ * gnat1drv.adb: Minor reformatting.
+
+2016-06-16 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Check_Entry_Contracts): New procedure, subsidiary
+ of Analyze_Declarations, that performs pre-analysis of
+ pre/postconditions on entry declarations before full analysis
+ is performed after entries have been converted into procedures.
+ Done solely to capture semantic errors.
+ * sem_attr.adb (Analyze_Attribute, case 'Result): Add guard to
+ call to Denote_Same_Function.
+
+2016-06-16 Emmanuel Briot <briot@adacore.com>
+
+ * g-comlin.adb: Fix minor memory leak in GNAT.Command_Line.
+
+2016-06-16 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch7.adb (Find_Last_Init): Remove obsolete code. The
+ logic is now performed by Process_Object_Declaration.
+ (Process_Declarations): Recognize a controlled deferred
+ constant which is in fact initialized by means of a
+ build-in-place function call as needing finalization actions.
+ (Process_Object_Declaration): Insert the counter after the
+ build-in-place initialization call for a controlled object. This
+ was previously done in Find_Last_Init.
+ * exp_util.adb (Requires_Cleanup_Actions): Recognize a controlled
+ deferred constant which is in fact initialized by means of a
+ build-in-place function call as needing finalization actions.
+
+2016-06-16 Justin Squirek <squirek@adacore.com>
+
+ * exp_aggr.adb (Expand_Array_Aggregate): Minor comment changes and
+ additional style fixes.
+ * exp_ch7.adb: Minor typo fixes and reformatting.
+
+2016-06-16 Justin Squirek <squirek@adacore.com>
+
+ * sem_ch3.adb (Analyze_Object_Declaration): Add a missing check
+ for optimized aggregate arrays with qualified expressions.
+ * exp_aggr.adb (Expand_Array_Aggregate): Fix block and
+ conditional statement in charge of deciding whether to perform
+ in-place expansion. Specifically, use Parent_Node to jump over
+ the qualified expression to the object declaration node. Also,
+ a check has been inserted to skip the optimization if SPARK 2005
+ is being used in strict adherence to RM 4.3(5).
+
+2016-06-16 Tristan Gingold <gingold@adacore.com>
+
+ * sem_prag.adb (Analyze_Pragma): Simplify code
+ for Pragma_Priority.
+
+2016-06-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_util.ads (Indexed_Component_Bit_Offset): Declare.
+ * sem_util.adb (Indexed_Component_Bit_Offset): New
+ function returning the offset of an indexed component.
+ (Has_Compatible_Alignment_Internal): Call it.
+ * sem_ch13.adb (Offset_Value): New function returning the offset of an
+ Address attribute reference from the underlying entity.
+ (Validate_Address_Clauses): Call it and take the offset into
+ account for the size warning.
+
+2016-06-16 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * bindgen.adb, exp_util.adb, sem_ch9.adb, sem_util.adb: Minor
+ reformatting.
+
+2016-06-16 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_ch9.adb, sem_util.ads, sem_res.adb: Minor reformatting and typo
+ fixes.
+
+2016-06-16 Javier Miranda <miranda@adacore.com>
+
+ * sem_res.adb (Resolve): Under relaxed RM semantics silently
+ replace occurrences of null by System.Null_Address.
+ * sem_ch4.adb (Analyze_One_Call, Operator_Check): Under
+ relaxed RM semantics silently replace occurrences of null by
+ System.Null_Address.
+ * sem_util.ad[sb] (Null_To_Null_Address_Convert_OK): New subprogram.
+ (Replace_Null_By_Null_Address): New subprogram.
+
+2016-06-16 Bob Duff <duff@adacore.com>
+
+ * exp_util.adb (Is_Controlled_Function_Call):
+ This was missing the case where the call is in prefix format,
+ with named notation, as in Obj.Func (Formal => Actual).
+
+2016-06-16 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_attr.adb, inline.adb, sem_attr.adb, sem_elab.adb: Minor
+ reformatting.
+
+2016-06-16 Bob Duff <duff@adacore.com>
+
+ * sem_util.adb (Collect): Avoid Empty Full_T. Otherwise Etype
+ (Full_T) crashes when assertions are on.
+ * sem_ch12.adb (Matching_Actual): Correctly handle the case where
+ "others => <>" appears in a generic formal package, other than
+ by itself.
+
+2016-06-16 Arnaud Charlet <charlet@adacore.com>
+
+ * usage.adb: Remove confusing comment in usage line.
+ * bindgen.adb: Fix binder generated file in codepeer mode wrt
+ recent additions.
+
+2016-06-16 Javier Miranda <miranda@adacore.com>
+
+ * restrict.adb (Check_Restriction_No_Use_Of_Entity): Avoid
+ never-ending loop, code cleanup; adding also support for Text_IO.
+ * sem_ch8.adb (Find_Expanded_Name): Invoke
+ Check_Restriction_No_Use_Entity.
+
+2016-06-16 Tristan Gingold <gingold@adacore.com>
+
+ * exp_ch9.adb: Minor comment fix.
+ * einfo.ads (Has_Protected): Clarify comment.
+ * sem_ch9.adb (Analyze_Protected_Type_Declaration): Do not
+ consider private protected types declared in the runtime for
+ the No_Local_Protected_Types restriction.
+
+2016-06-14 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Set_Actual_Subtypes): Do not generate actual
+ subtypes for unconstrained formals when analyzing the generated
+ body of an expression function, because it may lead to premature
+ and misplaced freezing of the types of formals.
+
+2016-06-14 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_elab.adb, sem_ch4.adb: Minor reformatting and typo fix.
+
+2016-06-14 Tristan Gingold <gingold@adacore.com>
+
+ * einfo.adb (Set_Has_Timing_Event): Add assertion.
+ * sem_util.ads, sem_util.adb (Propagate_Concurrent_Flags): New
+ name for Propagate_Type_Has_Flags.
+ * exp_ch3.adb, sem_ch3.adb, sem_ch7.adb, sem_ch9.adb: Adjust after
+ renaming.
+
+2016-06-14 Bob Duff <duff@adacore.com>
+
+ * sem_elab.adb (Check_A_Call): Do nothing if the callee is
+ (or is in) an instance, and the caller is outside. Misc cleanup.
+
+2016-06-14 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch4.adb (Analyze_Quantified_Expression):
+ Generating C code avoid spurious warning on loop variable of
+ inlinined postconditions.
+
+2016-06-14 Javier Miranda <miranda@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute_Old_Result): Adding assertion.
+ (Analyze_Attribute [Attribute_Old]): Generating C handle
+ analysis of 'old in inlined postconditions.
+ (Analyze_Attribute [Attribute_Result]): Generating C handle analysis
+ of 'result in inlined postconditions.
+ * exp_attr.adb (Expand_N_Attribute_Reference [Attribute_Old]):
+ Generating C handle expansion of 'old in inlined postconditions.
+ * inline.adb (Declare_Postconditions_Result): New subprogram.
+ * sem_ch12.adb (Copy_Generic_Node): Copy pragmas generated from
+ aspects when generating C code since pre/post conditions are
+ inlined and the frontend inlining relies on this routine to
+ perform inlining.
+ * exp_ch6.adb (Inlined_Subprogram): Replace Generate_C_Code
+ by Modify_Tree_For_C.
+ * exp_unst.adb (Visit_Node): Searching for up-level references
+ skip entities defined in inlined subprograms.
+
+2016-06-14 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch7.adb, sem_ch12.adb, freeze.adb, lib-xref.ads, exp_ch3.adb:
+ Minor reformatting.
+
+2016-06-14 Bob Duff <duff@adacore.com>
+
+ * sem_elab.adb: Do nothing if the callee is intrinsic.
+ * sinfo.ads, einfo.ads: Minor comment fixes.
+
+2016-06-14 Ed Schonberg <schonberg@adacore.com>
+
+ * contracts.adb (Has_Null_Body): Move to sem_util, for general
+ availability.
+ * sem_util.ads, sem_util.adb (Has_Null_Body): Predicate to
+ determine when an internal procedure created for some assertion
+ checking (e.g. type invariant) is a null procedure. Used to
+ eliminate redundant calls to such procedures when they apply to
+ components of composite types.
+ * exp_ch3.adb (Build_Component_Invariant_Call): Do not add call
+ if invariant procedure has a null body.
+
+2016-06-14 Thomas Quinot <quinot@adacore.com>
+
+ * g-socket.ads (Check_Selector): Clarify effect on IN OUT socket
+ set parameters.
+
+2016-06-14 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch4.adb (Process_Action): Pass the action
+ list to Process_Transient_Object.
+ (Process_If_Case_Statements): Pass the action list to
+ Process_Transient_Object.
+ (Process_Transient_Object): Add new parameter Stmts and update the
+ comment on usage. When the context is a Boolean evaluation, insert
+ any finalization calls after the last statement of the construct.
+
+2016-06-14 Tristan Gingold <gingold@adacore.com>
+
+ * einfo.adb, einfo.ads (Has_Timing_Event,
+ Set_Has_Timing_Event): Add Has_Timing_Event flag.
+ (Write_Entity_Flags): Display * sem_util.ads, sem_util.adb:
+ (Propagate_Type_Has_Flags): New procedure to factorize code.
+ * exp_ch3.adb (Expand_Freeze_Array_Type,
+ Expand_Freeze_Record_Type): Call Propagate_Type_Has_Flags.
+ * sem_ch3.adb (Access_Type_Decalaration): Initialize
+ Has_Timing_Event flag. (Analyze_Object_Declaration):
+ Move code that check No_Local_Timing_Events near
+ the code that check No_Local_Protected_Objects.
+ (Analyze_Private_Extension_Declaration, Array_Type_Declaration)
+ (Build_Derived_Type, Copy_Array_Base_Type_Attributes,
+ Process_Full_View) (Record_Type_Definition): Call
+ Propagate_Type_Has_Flags.
+ * sem_ch4.adb (Analyze_Allocator): Check No_Local_Timing_Events.
+ * sem_ch7.adb (New_Private_Type): Set Has_Timing_Event on the
+ Timing_Event type.
+ (Uninstall_Declaration): Call Propagate_Type_Has_Flags.
+ * sem_ch9.adb (Analyze_Protected_Definition): Call
+ Propagate_Type_Has_Flags.
+
+2016-06-14 Arnaud Charlet <charlet@adacore.com>
+
+ * sem.ads: Minor style fix.
+
+2016-06-14 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb (Analyze_Associations): An actual parameter
+ with a box must be included in the count of actuals, to detect
+ possible superfluous named actuals that do not match any of the
+ formals of the generic unit in a formal package declaration.
+
+2016-06-14 Justin Squirek <squirek@adacore.com>
+
+ * sem_ch3.adb (Analyze_Object_Declaration): Fix formatting
+ of error output related to SPARK RM 6.1.7(3) and pragma
+ Extensions_Visible.
+ * sem_ch4.adb (Analyze_Type_Conversion): Fix formatting of error
+ output related to SPARK RM 6.1.7(3) and pragma Extensions_Visible.
+ * sem_prag.adb (Analyze_Pragma): Fix formatting of error output
+ related to SPARK RM 7.1.2(15) and pragma Volatile_Function
+ so that the values True and False are no longer surrounded by
+ double quotes.
+ * sem_res.adb (Resolve_Actuals): Fix formatting of error output
+ related to SPARK RM 6.1.7(3) and pragma Extensions_Visible.
+
+2016-06-14 Arnaud Charlet <charlet@adacore.com>
+
+ * gnat1drv.adb (Adjust_Global_Switches): Enable access checks
+ in codepeer mode.
+ * freeze.adb: Minor grammar fix in comment.
+2016-06-14 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * lib.adb: Minor reformatting.
+ * sem_util.adb (Is_OK_Volatile_Context): Do
+ include Address in the supported attributes.
+
+2016-06-14 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Case_Expression):
+ Code cleanup. Finalize any transient controlled
+ objects on exit from a case expression alternative.
+ (Expand_N_If_Expression): Code cleanup.
+ (Process_Actions): Removed.
+ (Process_If_Case_Statements): New routine.
+ (Process_Transient_Object): Change the name of formal Rel_Node to
+ N and update all occurrences. Update the comment on usage. When
+ the type of the context is Boolean, the proper insertion point
+ for the finalization call is after the last declaration.
+
+2016-06-14 Ed Schonberg <schonberg@adacore.com>
+
+ * lib-xref.ads, lib-xref.adb (Has_Deferred_Reference): new
+ predicate to determine whether an entity appears in a context
+ for which a Deferred_Reference was created, because it is not
+ possible to determine when reference is analyzed whether it
+ appears in a context in which the entity is modified.
+ * sem_ch5.adb (Analyze_Statement): Do not emit a useless warning
+ on assignment for an entity that has a deferred_reference.
+
+2016-06-14 Javier Miranda <miranda@adacore.com>
+
+ * sem_res.adb (Resolve_Actuals): Generate a reference to actuals that
+ come from source. Previously the reference was generated only if the
+ call comes from source but the call may be rewritten by the expander
+ thus causing the notification of spurious warnings.
+
+2016-06-14 Arnaud Charlet <charlet@adacore.com>
+
+ * gnat1drv.adb: Remove further references to AAMP.
+ * checks.adb (Apply_Scalar_Range_Check): Take
+ Check_Float_Overflow info account.
+ * live.ads, live.adb Added subprogram headers and
+ start-of-processing-for comments.
+ * sem_ch12.adb (Instantiate_Package_Body): Do not suppress
+ checks when instantiating runtime units in CodePeer mode.
+
+2016-06-14 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch3.adb (Expand_N_Object_Declaration): Only consider
+ nodes from sources.
+
+2016-06-14 Arnaud Charlet <charlet@adacore.com>
+
+ * switch-c.adb, gnat1drv.adb (Adjust_Global_Switches): Only disable
+ simple value propagation in CodePeer mode when warnings are disabled.
+ (Scan_Front_End_Switches): Enable relevant front-end switches
+ when using -gnateC.
+
+2016-06-14 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_util.adb (Is_OK_Volatile_Context): A
+ reference to a volatile object is considered OK if appears as
+ the prefix of attributes Address, Alignment, Component_Size,
+ First_Bit, Last_Bit, Position, Size, Storage_Size.
+
+2016-06-14 Yannick Moy <moy@adacore.com>
+
+ * lib-xref-spark_specific.adb (Add_SPARK_File): Do not traverse
+ subunits directly, as they are already traversed as part of the
+ top-level unit to which they belong.
+ (Add_SPARK_Xrefs): Add assertions to ensure correct sorting.
+ (Generate_Dereference): Use unique definition place for special
+ variable __HEAP, to ensure correct sorting of references.
+ * lib-xref.adb (Generate_Reference): Use top-level unit in case
+ of subunits.
+ * lib.adb, lib.ads (Get_Top_Level_Code_Unit): New functions that
+ compute the top-level code unit for a source location of AST node,
+ that go past subunits.
+
+2016-06-13 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_subprog_type): Build only a minimal
+ PARM_DECL when the parameter type is dummy.
+ * gcc-interface/trans.c (Call_to_gnu): Translate formal types before
+ formal objects.
+
+2016-06-13 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Variable>: Deal with
+ PLUS_EXPR in the expression of a renaming.
+
+2016-06-13 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/utils2.c (known_alignment) <CALL_EXPR>: Deal specially
+ with calls to malloc.
+
+2016-06-11 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.c (build_binary_op_trapv): If no operand is a
+ constant, use the generic implementation of the middle-end; otherwise
+ turn the dynamic conditions into static conditions and simplify.
+
+2016-06-11 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.c (Case_Statement_to_gnu): Deal with characters.
+
+2016-06-11 Pierre-Marie de Rodat <derodat@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity): Do not clobber
+ gnat_entity_name with temporary names for XUP and XUT types.
+
+2016-06-10 Martin Sebor <msebor@redhat.com>
+
+ PR c/71392
+ * gcc/ada/gcc-interface/utils.c (handle_nonnull_attribute): Accept
+ the nonnull attribute in type-generic builtins.
+
+2016-06-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (Gigi_Equivalent_Type): Make sure equivalent
+ types are present before returning them. Remove final assertion.
+ (gnat_to_gnu_entity) <E_Access_Protected_Subprogram_Type>: Adjust to
+ above change.
+ <E_Protected_Type>: Likewise.
+
+2016-06-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.c (elaborate_all_entities_for_package): Also do
+ not elaborate Itypes.
+
+2016-06-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/utils.c (gnat_internal_attribute_table): Add support
+ for noinline and noclone attributes.
+ (handle_noinline_attribute): New handler.
+ (handle_noclone_attribute): Likewise.
+
+2016-06-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.c (process_type): Beef up comment.
+
+2016-06-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/utils2.c (build_call_alloc_dealloc): Do not substitute
+ placeholder expressions here but...
+ * gcc-interface/trans.c (gnat_to_gnu) <N_Free_Statement>: ...here.
+ Make an exception to the protection of a CALL_EXPR result with an
+ unconstrained type only in the same cases as Call_to_gnu.
+
+2016-06-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.c (gnat_to_gnu): Rework special code dealing
+ with boolean rvalues and set the location directly. Do not set the
+ location in the other cases for a simple name.
+ (gnat_to_gnu_external): Clear the location on the expression.
+
+2016-06-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Component>: Remove
+ useless 'else' statements and tidy up.
+ <E_Array_Subtype>: Fully deal with the declaration here.
+ <E_Incomplete_Type>: Use properly-typed constant.
+ Assert that we don't apply the special type treatment to dummy types.
+ Separate this treatment from the final back-annotation and simplify
+ the condition for the RM size.
+ (gnat_to_gnu_param): Add GNU_PARAM_TYPE parameter and adjust.
+ (gnat_to_gnu_subprog_type): Ajust call to gnat_to_gnu_param.
+ * gcc-interface/trans.c (gnat_to_gnu) <N_Subprogram_Declaration>: Add
+ comment.
+ (process_freeze_entity): Remove obsolete code.
+ (process_type): Minor tweaks.
+
+2016-06-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * einfo.ads (Returns_Limited_View): Remove.
+ (Set_Returns_Limited_View ): Likewise.
+ * einfo.adb (Returns_Limited_View): Likewise.
+ (Set_Returns_Limited_View ): Likewise.
+ * freeze.adb (Late_Freeze_Subprogram): Remove.
+ (Freeze_Entity): Do not defer the freezing of functions returning an
+ incomplete type coming from a limited context.
+
+2016-06-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/gigi.h (finish_subprog_decl): Add ASM_NAME parameter.
+ * gcc-interface/decl.c (gnu_ext_name_for_subprog): New function.
+ (gnat_to_gnu_entity) <E_Subprogram_Type>: Do not check compatibility
+ of profiles for builtins here... Call gnu_ext_name_for_subprog.
+ Also update profiles if pointers to limited_with'ed types are
+ updated.
+ (gnat_to_gnu_param): Restore the correct source location information
+ for vector ABI warnings.
+ (associate_subprog_with_dummy_type): Add comment about AI05-019.
+ Set TYPE_DUMMY_IN_PROFILE_P flag unconditionally.
+ (update_profile): Deal with builtin declarations.
+ Call gnu_ext_name_for_subprog. Adjust call to finish_subprog_decl.
+ (update_profiles_with): Add comment.
+ (gnat_to_gnu_subprog_type): Reuse the return type if it is complete.
+ Likewise for parameter declarations in most cases. Do not change
+ the return type for the CICO mechanism if the profile is incomplete.
+ ...but here instead. Always reset the slot for the parameters.
+ * gcc-interface/utils.c (create_subprog_decl): Call
+ gnu_ext_name_for_subprog. Do not set the assembler name here but...
+ (finish_subprog_decl): ...but here instead. Add ASM_NAME parameter.
+
+2016-06-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch9.adb (Expand_N_Protected_Type_Declaration): Insert the
+ declaration of the corresponding record type before that of the
+ unprotected version of the subprograms that operate on it.
+ (Expand_Access_Protected_Subprogram_Type): Declare the Equivalent_Type
+ just before the original type.
+ * sem_ch3.adb (Handle_Late_Controlled_Primitive): Point the current
+ declaration to the newly created declaration for the primitive.
+ (Analyze_Subtype_Declaration): Remove obsolete code forcing the
+ freezing of the subtype before its declaration.
+ (Replace_Anonymous_Access_To_Protected_Subprogram): Insert the new
+ declaration in the nearest enclosing scope for formal parameters too.
+ (Build_Derived_Access_Type): Restore the status of the created Itype
+ after it is erased by Copy_Node.
+ * sem_ch6.adb (Exchange_Limited_Views): Remove guard on entry.
+ (Analyze_Subprogram_Body_Helper): Call Exchange_Limited_Views only if
+ the specification is present.
+ Move around the code changing the designated view of the return type
+ and save the original view. Restore it on exit.
+ * sem_ch13.adb (Build_Predicate_Function_Declaration): Always insert
+ the declaration right after that of the type.
+
+2016-06-01 Simon Wright <simon@pushface.org>
+
+ PR ada/71358
+ * g-comlin.adb (Display_Section_Help): Do not dereference
+ Config.Switches if it's null.
+ (Getopt): Likewise.
+
+2016-05-31 Eric Botcazou <ebotcazou@adacore.com>
+
+ * s-osinte-kfreebsd-gnu.ads (clock_getres): Define.
+ (Get_Page_Size): Remove duplicate and return int.
+
+2016-05-31 Jan Sommer <soja-lists@aries.uberspace.de>
+
+ PR ada/71317
+ * s-osinte-rtems.ads (clock_getres): Define.
+ (Get_Page_Size): Remove duplicate and return int.
+
+2016-05-20 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Signed_Integer_Subtype>:
+ Make same-sized subtypes of signed base types signed.
+ * gcc-interface/utils.c (make_type_from_size): Adjust to above change.
+ (unchecked_convert): Likewise.
+
+2016-05-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Variable>: Do not build
+ a specific type for the object if it is deemed a constant.
+
+2016-05-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ * freeze.adb (Freeze_Record_Type): Extend pragma Implicit_Packing to
+ components of any elementary types and of composite types.
+
+2016-05-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ * freeze.adb (Freeze_Array_Type): Call Addressable predicate instead
+ of testing for individual sizes.
+ (Freeze_Entity): Rework implementation of pragma Implicit_Packing for
+ array types, in particular test for suitable sizes upfront and do not
+ mimic the processing that will be redone later in Freeze_Array_Type.
+
+2016-05-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.c (elaborate_all_entities_for_package): Also skip
+ formal objects.
+
+2016-05-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ * doc/gnat_rm/implementation_defined_attributes.rst
+ (Scalar_Storage_Order): Adjust restriction for packed array types.
+ * einfo.ads (Is_Bit_Packed_Array): Adjust description.
+ (Is_Packed): Likewise.
+ (Is_Packed_Array_Impl_Type): Likewise.
+ (Packed_Array_Impl_Type): Likewise.
+ * exp_ch4.adb (Expand_N_Indexed_Component): Do not do anything special
+ if the prefix is not a packed array implemented specially.
+ * exp_ch6.adb (Expand_Actuals): Expand indexed components only for
+ bit-packed array types.
+ * exp_pakd.adb (Install_PAT): Set Is_Packed_Array_Impl_Type flag on
+ the PAT before analyzing its declaration.
+ (Create_Packed_Array_Impl_Type): Remove redundant statements.
+ * freeze.adb (Check_Component_Storage_Order): Reject packed array
+ components only if they are bit packed.
+ (Freeze_Array_Type): Fix logic detecting bit packing and do not bit
+ pack for composite types whose size is multiple of a byte.
+ Create the implementation type for packed array types only when it is
+ needed, i.e. bit packing or packing because of holes in index types.
+ Make sure the Has_Non_Standard_Rep and Is_Packed flags agree.
+ * gcc-interface/gigi.h (make_packable_type): Add MAX_ALIGN parameter.
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Signed_Integer_Subtype>:
+ Call maybe_pad_type instead of building the padding type manually.
+ (gnat_to_gnu_entity) <E_Array_Subtype>: Do not assert that
+ Packed_Array_Impl_Type is present for packed arrays.
+ (gnat_to_gnu_component_type): Also handle known alignment for packed
+ types by passing it to make_packable_type.
+ * gcc-interface/utils.c (make_packable_type): Add MAX_ALIGN parameter
+ and deal with it in the array case. Adjust recursive call. Simplify
+ computation of new size and cap the alignment to BIGGEST_ALIGNMENT.
+
+2016-05-16 Thomas Quinot <quinot@adacore.com>
+
+ * freeze.adb (Check_Component_Storage_Order): Also get full view of
+ enclosing type.
+
+2016-05-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_util.adb (Remove_Side_Effects): Also make a constant if we need
+ to capture the value for a small not by-reference record type.
+ * freeze.ads (Check_Compile_Time_Size): Adjust comment.
+ * freeze.adb (Set_Small_Size): Likewise. Accept a size in the range
+ of 33 .. 64 bits.
+ (Check_Compile_Time_Size): Merge scalar and access type cases. Change
+ variable name in array type case. For the computation of the packed
+ size, deal with record components and remove redundant test.
+ (Freeze_Array_Type): Also adjust packing status when the size of the
+ component type is in the range 33 .. 64 bits.
+ * doc/gnat_rm/representation_clauses_and_pragmas.rst: Turn primitive
+ into elementary type throughout. Minor tweaks.
+ (Alignment Clauses): Document actual alignment of packed array types.
+ (Pragma Pack for Arrays): List only the 3 main cases and adjust. Add
+ "simple" to the record case. Document effect on non packable types.
+ (Pragma Pack for Records): Likewise. Add record case and adjust.
+
+2016-05-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/Make-lang.in (GNATMAKE_FOR_HOST): In the canadian
+ cross case, use host_noncanonical instead of host as prefix.
+ (GNATBIND_FOR_HOST): Likewise.
+ (GNATLINK_FOR_HOST): Likewise.
+ (GNATLS_FOR_HOST): Likewise.
+
+2016-05-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ PR ada/70969
+ * system-darwin-ppc64.ads: Add pragma No_Elaboration_Code_All.
+ * system-linux-armeb.ads: Likewise.
+ * system-linux-mips64el.ads: Likewise.
+ * system-linux-mips.ads: Likewise.
+ * system-linux-mipsel.ads: Likewise.
+ * system-linux-ppc64.ads: Likewise.
+ * system-linux-sparcv9.ads: Likewise.
+ * system-rtems.ads: Likewise.
+
+2016-05-04 Samuel Thibault <samuel.thibault@ens-lyon.org>
+
+ * s-osinte-gnu.ads (Get_Page_Size): Return int and use getpagesize
+ instead of __getpagesize.
+
+2016-05-02 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
+
+ * gcc-interface/Makefile.in (install-gcc-specs): Use foreach.
+ Honor DESTDIR.
+
+2016-05-02 Tristan Gingold <gingold@adacore.com>
+
+ * fname.adb (Is_Predefined_File_Name): Also consider non-krunched
+ i-* names.
+
+2016-05-02 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_util.adb (Aggregate_Constraint_Checks): Separate
+ accessibility checks and non-null checks for aggregate components,
+ to prevent spurious accessibility errors.
+
+2016-05-02 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (OK_For_Limited_Init): A type conversion is not
+ always legal in the in-place initialization of a limited entity
+ (e.g. an allocator).
+ * sem_res.adb (Resolve_Allocator): Improve error message with RM
+ reference when allocator expression is illegal.
+
+2016-05-02 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch6.adb (Expand_Call): When inlining a call to a function
+ declared in a package instance, locate the instance node of the
+ package after the actual package declaration. skipping over
+ pragmas that may have been introduced when the generic unit
+ carries aspects that are transformed into pragmas.
+
+2016-05-02 Bob Duff <duff@adacore.com>
+
+ * s-memory.adb (Alloc, Realloc): Move checks
+ for Size = 0 or size_t'Last into the Result = System.Null_Address
+ path for efficiency. Improve comments (based on actual C language
+ requirements for malloc).
+ * exp_util.adb (Build_Allocate_Deallocate_Proc): Optimize the
+ case where we are using the default Global_Pool_Object, and we
+ don't need the heavy finalization machinery.
+
+2016-05-02 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_util.ads, sem_ch12.adb: Minor reformatting.
+
+2016-05-02 Javier Miranda <miranda@adacore.com>
+
+ * exp_util.ads, exp_util.adb (Force_Evaluation): Adding new formal.
+ (Remove_Side_Effects): Adding a new formal.
+ * exp_ch6.adb (Expand_Simple_Function_Return): Generating the
+ call to the _Postconditions procedure ensure that side-effects
+ are unconditionally removed.
+
+2016-05-02 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb (Check_Formal_Package_Instance, Check_Mismatch):
+ Use original node to determine whether the declaration is for
+ a formal type declaration, to take into account that formwl
+ private types are rewritten as private extension declarations
+ to simplify semantic analysis.
+
+2016-05-02 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_ch9.adb, sem_ch6.adb, sem_ch6.ads: Minor reformatting and typo
+ fixes.
+
+2016-05-02 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch3.adb, exp_ch9.adb, einfo.adb, sem_ch4.adb, sem_ch6.adb: Minor
+ reformatting.
+
+2016-05-02 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Allocator): If the designated type
+ is a private derived type with no discriminants, examine its
+ underlying_full_view to determine whether the full view has
+ defaulted discriminants, so their defaults can be used in the
+ call to the initialization procedure for the designated object.
+
+2016-05-02 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_prag.adb, comperr.adb: Minor reformatting.
+
+2016-05-02 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_pakd.adb (Rj_Unchecked_Convert_To): Do not perform an
+ unchecked conversion if the source size is 0 (indicating that
+ its RM size is unknown). This will happen with packed arrays of
+ non-discrete types, in which case the component type is known
+ to match.
+
+2016-05-02 Arnaud Charlet <charlet@adacore.com>
+
+ * debug.adb: Reserve -gnatd.V.
+
+2016-05-02 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch3.adb (Process_Full_View): Remove from visibility
+ wrappers of synchronized types to avoid spurious errors with
+ their wrapped entity.
+ * exp_ch9.adb (Build_Wrapper_Spec): Do not generate the wrapper
+ if no interface primitive is covered by the subprogram and this is
+ not a primitive declared between two views; see Process_Full_View.
+ (Build_Protected_Sub_Specification): Link the dispatching
+ subprogram with its original non-dispatching protected subprogram
+ since their names differ.
+ (Expand_N_Protected_Type_Declaration):
+ If a protected subprogram overrides an interface primitive then
+ do not build a wrapper if it was already built.
+ * einfo.ads, einfo.adb (Original_Protected_Subprogram): New attribute.
+ * sem_ch4.adb (Names_Match): New subprogram.
+ * sem_ch6.adb (Check_Synchronized_Overriding): Moved
+ to library level and defined in the public part of the
+ package to invoke it from Exp_Ch9.Build_Wrapper_Spec
+ (Has_Matching_Entry_Or_Subprogram): New subprogram.
+ (Report_Conflict): New subprogram.
+
+2016-05-02 Jerome Lambourg <lambourg@adacore.com>
+
+ * s-unstyp.ads: Code cleanups.
+
+2016-05-02 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch13.adb (Size_Too_Small_Error): Fix the error message format.
+
+2016-05-02 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_prag.adb (Expand_attributes_In_Consequence,
+ Expand_Attributes): If the prefix of'Old is an unconstrained type,
+ for example an unconstrained formal of the enclosing subprogram,
+ create an object declaration with an expression to obtain the
+ actual subtype of the temporary.
+
+2016-05-02 Arnaud Charlet <charlet@adacore.com>
+
+ * comperr.adb (Delete_SCIL_Files): Add missing handling of
+ N_Subprogram_Declaration.
+
+2016-05-02 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_ch5.adb, exp_ch7.adb, exp_ch7.ads, checks.adb, sem_attr.adb,
+ gnat1drv.adb, sem_ch4.adb, sem_ch13.adb: Minor reformatting and typo
+ fixes.
+ * sem_prag.adb, sem_ch12.adb: Minor typo fixes.
+
+2016-05-02 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch6.adb (Make_Build_In_Place_Call_In_Allocator): The
+ function call may be wrapped in an explicit type conversion.
+
+2016-05-02 Jerome Lambourg <lambourg@adacore.com>
+
+ * interfac.ads: use pragma No_Elaboration_Code_All.
+ * s-unstyp.ads: s-unstyp.ads: use pragma No_Elaboration_Code_All.
+
+2016-05-02 Ed Schonberg <schonberg@adacore.com>
+
+ * sem.adb (Analyze: If node is an error node previously created
+ by the parser, disable expansion to prevent subsequent glitches
+ in error recovery.
+
+2016-05-02 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch13.adb (Alignment_Error): Removed.
+ (Get_Alignment_Value): Code cleanup.
+
+2016-05-02 Tristan Gingold <gingold@adacore.com>
+
+ * sem_ch3.adb (Analyze_Object_Declaration): Use Has_Protected
+ to check for the no local protected objects restriction.
+
+2016-05-02 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * einfo.adb Anonymous_Master now uses Node35.
+ (Anonymous_Master): Update the assertion and node reference.
+ (Set_Anonymous_Master): Update the assertion and node reference.
+ (Write_Field35_Name): Add output for Anonymous_Master.
+ (Write_Field36_Name): The output is now undefined.
+ * einfo.ads Update the node and description of attribute
+ Anonymous_Master. Remove prior occurrences in entities as this
+ is now a type attribute.
+ * exp_ch3.adb (Expand_Freeze_Array_Type): Remove local variable
+ Ins_Node. Anonymous access- to-controlled component types no
+ longer need finalization masters. The master is now built when
+ a related allocator is expanded.
+ (Expand_Freeze_Record_Type): Remove local variable Has_AACC. Do not
+ detect whether the record type has at least one component of anonymous
+ access-to- controlled type. These types no longer need finalization
+ masters. The master is now built when a related allocator is expanded.
+ * exp_ch4.adb Remove with and use clauses for Lib and Sem_Ch8.
+ (Current_Anonymous_Master): Removed.
+ (Expand_N_Allocator): Call Build_Anonymous_Master to create a
+ finalization master for an anonymous access-to-controlled type.
+ * exp_ch6.adb (Add_Finalization_Master_Actual_To_Build_In_Place_Call):
+ Call routine Build_Anonymous_Master to create a finalization master
+ for an anonymous access-to-controlled type.
+ * exp_ch7.adb (Allows_Finalization_Master): New routine.
+ (Build_Anonymous_Master): New routine.
+ (Build_Finalization_Master): Remove formal parameter
+ For_Anonymous. Use Allows_Finalization_Master to determine whether
+ circumstances warrant a finalization master. This routine no
+ longer creates masters for anonymous access-to-controlled types.
+ (In_Deallocation_Instance): Removed.
+ * exp_ch7.ads (Build_Anonymous_Master): New routine.
+ (Build_Finalization_Master): Remove formal parameter For_Anonymous
+ and update the comment on usage.
+ * sem_util.adb (Get_Qualified_Name): New routines.
+ (Output_Name): Reimplemented.
+ (Output_Scope): Removed.
+ * sem_util.ads (Get_Qualified_Name): New routines.
+
+2016-05-02 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * debug.adb: Document the use of switch -gnatd.H.
+ * gnat1drv.adb (Adjust_Global_Switches): Set ASIS_GNSA mode when
+ -gnatd.H is present.
+ (Gnat1drv): Suppress the call to gigi when ASIS_GNSA mode is active.
+ * opt.ads: Add new option ASIS_GNSA_Mode.
+ * sem_ch13.adb (Alignment_Error): New routine.
+ (Analyze_Attribute_Definition_Clause): Suppress certain errors in
+ ASIS mode for attribute clause Alignment, Machine_Radix, Size, and
+ Stream_Size.
+ (Check_Size): Use routine Size_Too_Small_Error to
+ suppress certain errors in ASIS mode.
+ (Get_Alignment_Value): Use routine Alignment_Error to suppress certain
+ errors in ASIS mode.
+ (Size_Too_Small_Error): New routine.
+
+2016-05-02 Arnaud Charlet <charlet@adacore.com>
+
+ * spark_xrefs.ads Description of the spark cross-references
+ clarified; small style fixes.
+ * lib-xref-spark_specific.adb (Add_SPARK_Scope,
+ Detect_And_Add_SPARK_Scope): consider protected types and bodies
+ as yet another scopes.
+ (Enclosing_Subprogram_Or_Library_Package): refactored using
+ Hristian's suggestions; added support for scopes of protected
+ types and bodies; fix for entries to return the scope of the
+ enclosing concurrent type, which is consistent with what is
+ returned for protected subprograms.
+ * sem_intr.adb: Minor style fix in comment.
+
+2016-05-02 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * lib-xref.ads, lib-xref-spark_specific.adb, get_spark_xrefs.adb,
+ put_spark_xrefs.adb: Minor reformatting.
+
+2016-05-02 Doug Rupp <rupp@adacore.com>
+
+ * g-traceb.ads: Document traceback for ARM.
+
+2016-05-02 Javier Miranda <miranda@adacore.com>
+
+ * exp_disp.adb (Make_Tags): Do not generate the
+ external name of interface tags adding the suffix counter since
+ it causes problems at link time when the IP routines are inlined
+ across units with optimization.
+
+2016-05-02 Ed Schonberg <schonberg@adacore.com>
+
+ * einfo.ads, einfo.adb (Predicates_Ignared): new flag to indicate
+ that predicate checking is disabled for predicated subtypes in
+ the context of an Assertion_Policy pragma.
+ * checks.adb (Apply_Predicate_Check): Do nothing if
+ Predicates_Ignored is true.
+ * exp_ch3.adb (Expand_Freeze_Enumeration_Type): If
+ Predicates_Ignores is true, the function Rep_To_Pos does raise
+ an exception for invalid data.
+ * exp_ch4.adb (Expand_N_Type_Conversion): IF target is a predicated
+ type do not apply check if Predicates_Ignored is true.
+ * exp_ch5.adb (Expand_N_Case_Statement): If Predicates_Ignored
+ is true, sem_prag.adb:
+ * sem_ch3.adb (Analyze_Object_Declaration): If Predicates_Ignored
+ is true do not emit predicate check on initializing expression.
+
+2016-05-02 Arnaud Charlet <charlet@adacore.com>
+
+ * get_spark_xrefs.adb (Get_Nat, Get_Name): Initialize variables when
+ they are declared; refine type of a counter from Integer to Natural.
+ * sem_ch5.adb, gnatcmd.adb, s-intman-posix.adb, eval_fat.adb,
+ prj.adb, sem_util.adb, s-intman-android.adb, prj-nmsc.adb, sem_ch8.adb,
+ exp_ch3.adb: Minor editing.
+
+2016-05-02 Yannick Moy <moy@adacore.com>
+
+ * a-tigeli.adb (Get_Line): Always set Last prior to returning.
+
+2016-05-02 Yannick Moy <moy@adacore.com>
+
+ * lib-xref.adb: Minor style fix in whitespace of declarations.
+ * put_spark_xrefs.adb (Put_SPARK_Xrefs): printing of strings
+ refactored without loops.
+ * put_spark_xrefs.ads (Write_Info_Str): new formal argument of
+ generic procedure.
+ * spark_xrefs.adb (Write_Info_Str): new actual in instantiation
+ of generic procedure.
+
+2016-05-02 Arnaud Charlet <charlet@adacore.com>
+
+ * lib-xref-spark_specific.adb (Add_SPARK_Scope): add task type scope.
+ (Detect_And_Add_SPARK_Scope): detect and add task type scope.
+ (Enclosing_Subprogram_Or_Package): Respect boundaries of task
+ and entry declarations.
+ * spark_xrefs.ads: minor typo in comment.
+
+2016-05-02 Arnaud Charlet <charlet@adacore.com>
+
+ * make.adb: Minor: avoid an exception when calling gnatmake with
+ no argument and gnatmake is built with checks on.
+ * lib-xref-spark_specific.adb: Minor code cleanup.
+
+2016-05-02 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_util.adb (Normalize_Actuals): Take into account extra
+ actuals that may have been introduced previously. Normally extra
+ actuals are introduced when a call is expanded, but a validity
+ check may copy and reanalyze a call that carries an extra actual
+ (e.g. an accessibility parameter) before the call itself is
+ marked Analzyed, and the analysis of the copy has to be able to
+ cope with the added actual.
+
+2016-05-02 Bob Duff <duff@adacore.com>
+
+ * sem_ch10.adb (Analyze_Compilation_Unit): Preserve
+ treeishness. Previous version had Context_Items shared between
+ the spec and body.
+
+2016-05-02 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_aggr.adb (Resolve_Aggr_Expression): For both array and
+ record cases, apply predicate check on component for expression
+ only if expression has been analyzed already. For expressions
+ that need to be duplicated when they cover multiple components,
+ resolution and predicate checking take place later.
+
+2016-05-02 Olivier Hainque <hainque@adacore.com>
+
+ * a-direct.adb (Delete_Tree): Use full names to designate subdirs
+ and files therein, instead of local names after a change of
+ current directory.
+
+2016-05-02 Thomas Quinot <quinot@adacore.com>
+
+ * freeze.adb (Check_Component_Storage_Order): Get full view of
+ component type.
+
+2016-05-02 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * checks.adb, freeze.adb, sem_res.adb, s-stposu.adb, repinfo.adb:
+ Minor reformatting.
+
+2016-05-02 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch4.adb (Find_Indexing_Operations): Use the underlying type
+ of the container base type in case the container is a subtype.
+ * sem_ch5.adb (Analyze_Iterator_Specification): Ensure that
+ the selector has an entity when checking for a component of a
+ mutable object.
+
+2016-05-02 Arnaud Charlet <charlet@adacore.com>
+
+ Remove dead code.
+ * opt.ads (Latest_Ada_Only): New flag.
+ * sem_prag.adb, par-prag.adb: Ignore pragma Ada_xx under this flag.
+ * usage.adb, switch-c.adb: Disable support for -gnatxx under this flag.
+ * einfo.ads (Has_Predicates, Predicate_Function):
+ Clarify that Has_Predicates does not imply that Predicate_Function
+ will return a non-empty entity.
+
+2016-05-02 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_res.adb (Resolve_Qualified_Expression): Generate a predicate
+ check if type requires it.
+ * checks.adb (Apply_Predicate_Check): Disable checks in the
+ object declaration created for an expression with side-effects
+ that requires a predicate check to prevent infinite recursion
+ during expansion.
+
+2016-05-02 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Process_Formals): Check properly the type of a
+ formal to determine whether a given convention applies to it.
+
+2016-05-02 Doug Rupp <rupp@adacore.com>
+
+ * tracebak.c: Add incantations for arm-vxworks[67] traceback.
+
+2016-05-02 Thomas Quinot <quinot@adacore.com>
+
+ * freeze.adb (Check_Component_Storage_Order): Make it a warning, not an
+ error, to have a component with implicit SSO within a composite type
+ that has explicit SSO.
+
+2016-05-02 Bob Duff <duff@adacore.com>
+
+ * s-stposu.adb (Allocate_Any_Controlled): Don't lock/unlock twice.
+
+2016-05-02 Ed Schonberg <schonberg@adacore.com>
+
+ * repinfo.adb (List_Entities): Make procedure recursive, to
+ provide representation information for subprograms declared
+ within subprogram bodies.
+
+2016-05-02 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch5.adb, layout.adb, gnatcmd.adb exp_attr.adb, make.adb,
+ bindgen.adb, debug.adb, exp_pakd.adb, freeze.adb, sem_util.adb,
+ gnatlink.adb, switch-m.adb, exp_ch4.adb, repinfo.adb, adabkend.adb,
+ osint.adb: Remove dead code.
+
+2016-05-02 Yannick Moy <moy@adacore.com>
+
+ * a-tigeli.adb (Get_Line): Fix bound for test to
+ decide when to compensate for character 0 added by call to fgets.
+
+2016-05-02 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch4.adb (Analyze_Allocator): If the expression does not
+ have a subtype indication and the type is an unconstrained tagged
+ type with defaulted discriminants, create an explicit constraint
+ for it during analysis to prevent out-of-order freezing actions
+ on generated classwide types.
+
+2016-05-02 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch5.adb (Expand_N_Assignment_Statement):
+ In the runtime check that ensures that the tags of source an
+ target match, add missing displacement of the pointer to the
+ objects if they cover interface types.
+
+2016-05-02 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute, case 'Old): Do not use
+ base type for attribute when type is discrete: transformation
+ is not needed for such types, and leads to spurious errors if
+ the context is a case construct.
+
+2016-05-02 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (elaborate_reference_1): Do not bother about
+ operand #2 for COMPONENT_REF.
+ * gcc-interface/utils2.c (gnat_save_expr): Likewise.
+ (gnat_protect_expr): Likewise.
+ (gnat_stabilize_reference_1): Likewise.
+ (gnat_rewrite_reference): Do not bother about operand #3 for ARRAY_REF.
+ (get_inner_constant_reference): Likewise.
+ (gnat_invariant_expr): Likewise.
+ * gcc-interface/trans.c (fold_constant_decl_in_expr): Likewise.
+
+2016-05-02 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.c (Range_to_gnu): New static function.
+ (Raise_Error_to_gnu) <N_In>: Call it to translate the range.
+ (gnat_to_gnu) <N_In>: Likewise.
+
+2016-04-30 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/Make-lang.in (ACATSCMD): New variable.
+ (check-acats): Use it.
+ (check_acats_targets): Likewise.
+
+2016-04-28 Eric Botcazou <ebotcazou@adacore.com>
+
+ PR ada/70786
+ * a-textio.adb (Get_Immediate): Add missing 'not' in expression.
+
+2016-04-27 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_aux.adb (Is_By_Reference_Type): Also return true for a tagged
+ incomplete type without full view.
+ * sem_ch6.adb (Exchange_Limited_Views): Change into a function and
+ return the list of changes.
+ (Restore_Limited_Views): New procedure to undo the transformation made
+ by Exchange_Limited_Views.
+ (Analyze_Subprogram_Body_Helper): Adjust call to Exchange_Limited_Views
+ and call Restore_Limited_Views at the end, if need be.
+ (Possible_Freeze): Do not delay freezing because of incomplete types.
+ (Process_Formals): Remove kludges for class-wide types.
+ * types.h (By_Copy_Return): Delete.
+ * gcc-interface/ada-tree.h (TYPE_MAX_ALIGN): Move around.
+ (TYPE_DUMMY_IN_PROFILE_P): New macro.
+ * gcc-interface/gigi.h (update_profiles_with): Declare.
+ (finish_subprog_decl): Likewise.
+ (get_minimal_subprog_decl): Delete.
+ (create_subprog_type): Likewise.
+ (create_param_decl): Adjust prototype.
+ (create_subprog_decl): Likewise.
+ * gcc-interface/decl.c (defer_limited_with): Rename into...
+ (defer_limited_with_list): ...this.
+ (gnat_to_gnu_entity): Adjust to above renaming.
+ (finalize_from_limited_with): Likewise.
+ (tree_entity_vec_map): New structure.
+ (gt_pch_nx): New helpers.
+ (dummy_to_subprog_map): New hash table.
+ (gnat_to_gnu_param): Set the SLOC here. Remove MECH parameter and
+ add FIRST parameter. Deal with the mechanism here instead of...
+ Do not make read-only variant of types. Simplify expressions.
+ In the by-ref case, test the mechanism before must_pass_by_ref
+ and also TYPE_IS_BY_REFERENCE_P before building the reference type.
+ (gnat_to_gnu_subprog_type): New static function extracted from...
+ Do not special-case the type_annotate_only mode. Call
+ gnat_to_gnu_profile_type instead of gnat_to_gnu_type on return type.
+ Deal with dummy return types. Likewise for parameter types. Deal
+ with by-reference types explicitly and add a kludge for null procedures
+ with untagged incomplete types. Remove assertion on the types and be
+ prepared for multiple elaboration of the declarations. Skip the whole
+ CICO processing if the profile is incomplete. Handle the completion of
+ a previously incomplete profile.
+ (gnat_to_gnu_entity) <E_Variable>: Rename local variable.
+ Adjust couple of calls to create_param_decl.
+ <E_Access_Subprogram_Type, E_Anonymous_Access_Subprogram_Type>:
+ Remove specific deferring code.
+ <E_Access_Type>: Also deal with E_Subprogram_Type designated type.
+ Simplify handling of dummy types and remove obsolete comment.
+ Constify a couple of variables. Do not set TYPE_UNIVERSAL_ALIASING_P
+ on dummy types.
+ <E_Access_Subtype>: Tweak comment and simplify condition.
+ <E_Subprogram_Type>: ...here. Call it and clean up handling. Remove
+ obsolete comment and adjust call to gnat_to_gnu_param. Adjust call to
+ create_subprog_decl.
+ <E_Incomplete_Type>: Add a couple of 'const' qualifiers and get rid of
+ inner break statements. Tidy up condition guarding direct use of the
+ full view.
+ (get_minimal_subprog_decl): Delete.
+ (finalize_from_limited_with): Call update_profiles_with on dummy types
+ with TYPE_DUMMY_IN_PROFILE_P set.
+ (is_from_limited_with_of_main): Delete.
+ (associate_subprog_with_dummy_type): New function.
+ (update_profile): Likewise.
+ (update_profiles_with): Likewise.
+ (gnat_to_gnu_profile_type): Likewise.
+ (init_gnat_decl): Initialize dummy_to_subprog_map.
+ (destroy_gnat_decl): Destroy dummy_to_subprog_map.
+ * gcc-interface/misc.c (gnat_get_alias_set): Add guard for accessing
+ TYPE_UNIVERSAL_ALIASING_P.
+ (gnat_get_array_descr_info): Minor tweak.
+ * gcc-interface/trans.c (gigi): Adjust calls to create_subprog_decl.
+ (build_raise_check): Likewise.
+ (Compilation_Unit_to_gnu): Likewise.
+ (Identifier_to_gnu): Accept mismatches coming from a limited context.
+ (Attribute_to_gnu): Remove kludge for dispatch table entities.
+ (process_freeze_entity): Do not retrieve old definition if there is an
+ address clause on the entity. Call update_profiles_with on dummy types
+ with TYPE_DUMMY_IN_PROFILE_P set.
+ * gcc-interface/utils.c (build_dummy_unc_pointer_types): Also set
+ TYPE_REFERENCE_TO to the fat pointer type.
+ (create_subprog_type): Delete.
+ (create_param_decl): Remove READONLY parameter.
+ (finish_subprog_decl): New function extracted from...
+ (create_subprog_decl): ...here. Call it. Remove CONST_FLAG and
+ VOLATILE_FLAG parameters and adjust.
+ (update_pointer_to): Also clear TYPE_REFERENCE_TO in the unconstrained
+ case.
+
+2016-04-27 Arnaud Charlet <charlet@adacore.com>
+
+ * aa_util.adb, aa_util.ads: Removed, no longer used.
+
+2016-04-27 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_prag.adb (Analyze_Pragma): An object
+ renaming declaration resulting from the expansion of an object
+ declaration is a suitable context for pragma Ghost.
+
+2016-04-27 Doug Rupp <rupp@adacore.com>
+
+ * init.c: Refine last checkin so the only requirement is the
+ signaling compilation unit is compiled with the same mode as
+ the compilation unit containing the initial landing pad.
+
+2016-04-27 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch13.adb (Valid_Default_Iterator): Better filter of illegal
+ specifications for Default_Iterator, including overloaded cases
+ where no interpretations are legal, and return types that are
+ not iterator types.
+
+2016-04-27 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch5.adb (Expand_N_Assignment_Statement): Do not install
+ an accessibility check when the left hand side of the assignment
+ denotes a container cursor.
+ * exp_util.ads, exp_util.adb (Find_Primitive_Operations): Removed.
+ * sem_ch4.adb (Find_Indexing_Operations): New routine.
+ (Try_Container_Indexing): Code cleanup.
+
+2016-04-27 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch10.adb, sem_case.adb: Mark messages udner -gnatwr when needed.
+
+2016-04-27 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * errout.adb, errutil.adb: Minor reformatting.
+
+2016-04-27 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch13.adb (Analyze_Aspect_Specifications, case Pre/Post):
+ Check that the classwide version is illegal when the prefix is
+ an operation of an untagged synchronized type.
+
+2016-04-27 Arnaud Charlet <charleT@adacore.com>
+
+ * sinput-l.ads, sem_ch13.adb: Minor editing.
+
+2016-04-27 Doug Rupp <rupp@adacore.com>
+
+ * init.c (__gnat_adjust_context_for_raise) [arm-linux thumb]:
+ Bump the pc so the lower order bit is set.
+
+2016-04-27 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_case.adb, sem_case.ads (NO_Op): If appropriate warning is
+ enabled, report an empty range in a case construct.
+
+2016-04-27 Arnaud Charlet <charlet@adacore.com>
+
+ * sinput.ads, a-cfdlli.adb, a-crbtgo.adb, a-chtgop.adb, a-cbhama.adb,
+ a-rbtgbo.adb, a-crdlli.adb, a-chtgbo.adb: Minor editing.
+
+2016-04-27 Bob Duff <duff@adacore.com>
+
+ * a-chtgop.adb (Adjust): Zero the tampering counts on assignment,
+ as is done for the other containers.
+
+2016-04-27 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * ghost.adb (In_Subprogram_Body_Profile): New routine.
+ (Is_OK_Declaration): Treat an unanalyzed expression
+ function as an OK context. Treat a reference to a Ghost entity
+ as OK when it appears within the profile of a subprogram body.
+
+2016-04-27 Bob Duff <duff@adacore.com>
+
+ * errout.ads: Document the fact that informational messages
+ don't have to be warnings.
+ * errout.adb (Error_Msg_Internal): In statistics counts, deal
+ correctly with informational messages that are not warnings.
+ (Error_Msg_NEL): Remove useless 'if' aroung Set_Posted, because
+ Set_Posted already checks for errors and ignores others.
+ * erroutc.adb (Prescan_Message): Set Is_Serious_Error to False
+ if Is_Info_Msg; the previous code was assuming that Is_Info_Msg
+ implies Is_Warning_Msg.
+ * errutil.adb (Error_Msg): In statistics counts, deal correctly
+ with informational messages that are not warnings.
+
+2016-04-27 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_util.ads, sem_util.adb (Is_Null_Record_Type): New predicate
+ to determine whether a record type is a null record.
+ * sem_ch3.adb (Analyze_Object_Declaration): If the type is a
+ null record and there is no expression in the declaration,
+ no predicate check applies to the object.
+
+2016-04-27 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch7.adb (Analyze_Package_Body_Helper): The body of an
+ instantiated package should not cause freezing of previous contracts.
+
+2016-04-27 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_dim.adb (Analyze_Dimension): Handle subtype declarations
+ that do not come from source.
+ (Analyze_Dimension_Subtype_Declaration): Allow confirming
+ dimensions on subtype entity, either inherited from base type
+ or provided by aspect specification.
+
+2016-04-27 Ed Schonberg <schonberg@adacore.com>
+
+ * s-gearop.ads (Matrix_Vector_Solution, Matrix_Matrix_Solution):
+ Add scalar formal object Zero, to allow detection and report
+ when the matrix is singular.
+ * s-gearop.adb (Matrix_Vector_Solution, Matrix_Matrix_Solution):
+ Raise Constraint_Error if the Forward_Eliminate pass has
+ determined that determinant is Zero.o
+ * s-ngrear.adb (Solve): Add actual for Zero in corresponding
+ instantiations.
+ * s-ngcoar.adb (Solve): Ditto.
+
+2016-04-27 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch3.adb: Minor reformatting.
+
+2016-04-27 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_dim.adb (Analyze_Dimension, case N_Identifier): Check
+ that identifier has a usable type before analysis, to handle
+ properly identifiers introduced after some lexical/syntactic
+ recovery that created new identifiers.
+
+2016-04-27 Bob Duff <duff@adacore.com>
+
+ * a-coinve.adb, a-comutr.adb, a-conhel.adb, a-convec.adb,
+ exp_util.adb: Remove assertions that can fail in obscure cases when
+ assertions are turned on but tampering checks are turned off.
+
+2016-04-27 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch6.adb (Add_Call_By_Copy_Code,
+ Add_Simple_Call_By_Copy_Code, Expand_Actuals): Handle formals
+ whose type comes from the limited view.
+
+2016-04-27 Yannick Moy <moy@adacore.com>
+
+ * a-textio.adb: Complete previous patch.
+
+2016-04-27 Yannick Moy <moy@adacore.com>
+
+ * inline.adb (Expand_Inlined_Call): Use Cannot_Inline instead of
+ Error_Msg_N to issue message about impossibility to inline call,
+ with slight change of message.
+
+2016-04-27 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_spark.adb (Expand_Potential_Renaming): Removed.
+ (Expand_SPARK): Update the call to expand a potential renaming.
+ (Expand_SPARK_Potential_Renaming): New routine.
+ * exp_spark.ads (Expand_SPARK_Potential_Renaming): New routine.
+ * sem.adb Add with and use clauses for Exp_SPARK.
+ (Analyze): Expand a non-overloaded potential renaming for SPARK.
+
+2016-04-27 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Constrain_Discriminated_Type): In an instance,
+ check full view for the presence of defaulted discriminants,
+ even when the partial view of a private type has no visible and
+ no unknown discriminants.
+
+2016-04-27 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * lib-xref.adb, exp_ch3.adb: Minor reformatting.
+
+2016-04-27 Nicolas Roche <roche@adacore.com>
+
+ * rtinit.c: Add weak symbol __gnat_do_argv_expansion.
+
+2016-04-27 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_prag.adb (Process_Atomic_Independent_Shared_Volatile): Code
+ cleanup. Check the original node when trying to determine the node kind
+ of pragma Volatile's argument to account for untagged derivations
+ where the type is transformed into a constrained subtype.
+
+2016-04-27 Olivier Hainque <hainque@adacore.com>
+
+ * mkdir.c (__gnat_mkdir): Rework the vxworks section to use a
+ consistent posix interface on the caller side.
+
+2016-04-27 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch10.adb (Build_Limited_View, Decorate_Type): If this
+ is a limited view of a type, initialize the Limited_Dependents
+ field to catch misuses of the type in a client unit.
+
+2016-04-27 Thomas Quinot <quinot@adacore.com>
+
+ * a-strunb-shared.adb (Finalize): add missing Reference call.
+ * s-strhas.adb: minor grammar fix and extension of comment
+ * sem_ch8.adb: minor whitespace fixes
+
+2016-04-27 Ed Schonberg <schonberg@adacore.com>
+
+ * lib-xref.adb (Get_Type_Reference): Handle properly the case
+ of an object declaration whose type definition is a class-wide
+ subtype and whose expression is a function call that returns a
+ classwide type.
+
+2016-04-27 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_util.ads, sem_util.adb (Output_Entity): New routine.
+ (Output_Name): New routine.
+
+2016-04-27 Bob Duff <duff@adacore.com>
+
+ * exp_ch3.adb (Rewrite_As_Renaming): Disable previous change for now.
+
+2016-04-27 Vincent Celier <celier@adacore.com>
+
+ * gnatcmd.adb: For "gnat ls -V -P", recognize switch
+ --unchecked-shared-lib-imports and set the flag
+ Opt.Unchecked_Shared_Lib_Imports accordingly.
+
+2016-04-27 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_prag.adb (Analyze_Pre_Post_Condition_In_Decl_Part):
+ A generic subprogram is never a primitive operation, and thus
+ a classwide condition for it is not legal.
+
+2016-04-27 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_aggr.adb, sem_dim.adb, sem_dim.ads, einfo.adb: Minor
+ reformatting.
+
+2016-04-27 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_res.adb (Flag_Effectively_Volatile_Objects): New routine.
+ (Resolve_Actuals): Flag effectively volatile objects with enabled
+ property Async_Writers or Effective_Reads as illegal.
+ * sem_util.adb (Is_OK_Volatile_Context): Comment reformatting.
+
+2016-04-27 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch3.adb (Make_Predefined_Primitive_Specs):
+ Do not generate the profile of the equality operator if it has
+ been explicitly defined as abstract in the parent type. Required
+ to avoid reporting an spurious error.
+
+2016-04-27 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_dim.ads, sem_dim.adb (Check_Expression_Dimensions): New
+ procedure to compute the dimension vector of a scalar expression
+ and compare it with the dimensions if its expected subtype. Used
+ for the ultimate components of a multidimensional aggregate,
+ whose components typically are themselves aggregates that are
+ expanded separately. Previous to this patch, dimensionality
+ checking on such aggregates generated spurious errors.
+ * sem_aggr.adb (Resolve_Array_Aggregate): Use
+ Check_Expression_Dimensions when needed.
+
+2016-04-27 Javier Miranda <miranda@adacore.com>
+
+ * einfo.ads, einfo.adb (Corresponding_Function): New attribute
+ (applicable to E_Procedure).
+ (Corresponding_Procedure): New attribute (applicable to E_Function).
+ * exp_util.adb (Build_Procedure_Form): Link the function with
+ its internally built proc and viceversa.
+ * sem_ch6.adb (Build_Subprogram_Declaration): Propagate the
+ attribute Rewritten_For_C and Corresponding_Procedure to the body.
+ * exp_ch6.adb (Rewritten_For_C_Func_Id): Removed.
+ (Rewritten_For_C_Proc_Id): Removed.
+ * exp_unst.adb (Note_Uplevel_Ref): Use the new attribute to
+ locate the corresponding procedure.
+
+2016-04-27 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch13.adb (Analyze_Aspect_Export_Import): Signal that there is no
+ corresponding pragma.
+
+2016-04-27 Bob Duff <duff@adacore.com>
+
+ * exp_ch3.adb: Minor comment improvement.
+
+2016-04-27 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch6.adb (Make_Build_In_Place_Call_In_Object_Declaration): If the
+ return type is an untagged limited record with only access
+ discriminants and no controlled components, the return value does not
+ need to use the secondary stack.
+
+2016-04-27 Javier Miranda <miranda@adacore.com>
+
+ * exp_util.adb (Remove_Side_Effects): When
+ generating C code handle object declarations that have
+ discriminants and are initialized by means of a call to a
+ function.
+
+2016-04-27 Ed Schonberg <schonberg@adacore.com>
+
+ * a-textio.adb (Get_Line function): Handle properly the case of
+ a line that has the same length as the buffer (or a multiple
+ thereof) and there is no line terminator.
+ * a-tigeli.adb (Get_Line procedure): Do not store an end_of_file
+ in the string when there is no previous line terminator and we
+ need at most one additional character.
+
+2016-04-27 Arnaud Charlet <charlet@adacore.com>
+
+ * s-rident.ads: Make No_Implicit_Loops non partition wide.
+
+2016-04-27 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch11.adb (Analyze_Handled_Statements): check useless
+ assignments also in entries and task bodies, not only in
+ procedures and declaration blocks.
+ * sem_ch5.adb (Analyze_Block_Statement): check useless
+ assignements in declaration blocks as part of processing their
+ handled statement sequence, just like it was done for procedures
+ and now is also done for entries and task bodies.
+ * sem_warn.adb (Warn_On_Useless_Assignment): detect boundries
+ of entries and task bodies just like of procedures.
+
+2016-04-27 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_util.adb (Is_Volatile_Function): Recognize
+ a function declared within a protected type as well as the
+ protected/unprotected version of a function.
+
+2016-04-27 Bob Duff <duff@adacore.com>
+
+ * exp_ch3.adb (Expand_N_Object_Declaration): Rewrite an object
+ declaration of the form "X : T := Func (...);", where T is
+ controlled, as a renaming.
+ * a-strunb-shared.adb (Finalize): Set the Unbounded_String Object
+ to be an empty string, instead of null-ing out the Reference.
+ * exp_util.adb (Needs_Finalization): Remove redundant code.
+
+2016-04-27 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * aspects.ads Aspects Export and Import do not require delay. They
+ were classified as delayed aspects, but treated as non-delayed
+ by the analysis of aspects.
+ * freeze.adb (Copy_Import_Pragma): New routine.
+ (Wrap_Imported_Subprogram): Copy the import pragma by first
+ resetting all semantic fields to avoid an infinite loop when
+ performing the copy.
+ * sem_ch13.adb (Analyze_Aspects_At_Freeze_Point): Add
+ comment on the processing of aspects Export and Import
+ at the freeze point.
+ (Analyze_Aspect_Convention: New routine.
+ (Analyze_Aspect_Export_Import): New routine.
+ (Analyze_Aspect_External_Link_Name): New routine.
+ (Analyze_Aspect_External_Or_Link_Name): Removed.
+ (Analyze_Aspect_Specifications): Factor out the analysis of
+ aspects Convention, Export, External_Name, Import, and Link_Name
+ in their respective routines. Aspects Export and Import should
+ not generate a Boolean pragma because their corresponding pragmas
+ have a very different syntax.
+ (Build_Export_Import_Pragma): New routine.
+ (Get_Interfacing_Aspects): New routine.
+
+2016-04-27 Eric Botcazou <ebotcazou@adacore.com>
+
+ * inline.adb (Add_Inlined_Body): Overhaul implementation,
+ robustify handling of -gnatn1, add special treatment for
+ expression functions.
+
+2016-04-27 Doug Rupp <rupp@adacore.com>
+
+ * g-traceb.ads: Update comment.
+ * exp_ch2.adb: minor style fix in object declaration
+
+2016-04-27 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_elab.adb (Check_Internal_Call): Do not
+ consider a call when it appears within pragma Initial_Condition
+ since the pragma is part of the elaboration statements of a
+ package body and may only call external subprograms or subprograms
+ whose body is already available.
+ (Within_Initial_Condition): New routine.
+
+2016-04-27 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_util.adb (Build_Procedure_Form): Prevent double generation
+ of the procedure form when dealing with an expression function
+ whose return type is an array.
+ * sem_ch3.adb: Fix out-of order Has_Predicates setting.
+ * exp_ch6.adb: Proper conversion for inherited operation in C.
+ * sem_ch6.adb: Code cleanup.
+
+2016-04-27 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * lib-xref.ads, sem_ch10.adb: minor style fix in comment
+ * g-socket.adb: Minor reformatting.
+ * sinfo.ads: Minor comment correction.
+ * sem_warn.ads: minor grammar fix in comment
+
+2016-04-27 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/gigi.h (gnat_to_gnu_entity): Adjust prototype.
+ (maybe_pad_type): Adjust comment.
+ (finish_record_type): Likewise.
+ (rest_of_record_type_compilation): Likewise.
+ * gcc-interface/decl.c (gnat_to_gnu_entity): Change DEFINITION type
+ parameter from integer to boolean. Adjust recursive calls.
+ <E_Subprogram_Type>: Use copy_type and remove redundant assignments.
+ <E_Signed_Integer_Subtype>: Adjust comment. Remove call to
+ rest_of_record_type_compilation. Set TYPE_PADDING_P flag earlier.
+ Pass false to finish_record_type. Set the debug type later.
+ <E_Record_Subtype>: Remove call to rest_of_record_type_compilation.
+ (gnat_to_gnu_component_type): Fix formatting.
+ (gnat_to_gnu_field_decl): Adjust call to gnat_to_gnu_entity.
+ (gnat_to_gnu_type): Likewise.
+ * gcc-interface/trans.c (Identifier_to_gnu): Likewise.
+ (Loop_Statement_to_gnu): Likewise.
+ (Subprogram_Body_to_gnu): Likewise.
+ (Exception_Handler_to_gnu_fe_sjlj): Likewise.
+ (Exception_Handler_to_gnu_gcc): Likewise.
+ (Compilation_Unit_to_gnu): Likewise.
+ (gnat_to_gnu): Likewise.
+ (push_exception_label_stack): Likewise.
+ (elaborate_all_entities_for_package): Likewise.
+ (process_freeze_entity): Likewise.
+ (process_decls): Likewise.
+ (process_type): Likewise.
+ * gcc-interface/utils.c (struct deferred_decl_context_node): Tweak.
+ (maybe_pad_type): Adjust comments. Set the debug type later. Remove
+ call to rest_of_record_type_compilation.
+ (rest_of_record_type_compilation): Use copy_type.
+ (copy_type): Use correctly typed constants.
+ (gnat_signed_or_unsigned_type_for): Use copy_type.
+ * gcc-interface/utils2.c (nonbinary_modular_operation): Likewise.
+ (build_goto_raise): Adjust call tognat_to_gnu_entity.
+
+2016-04-27 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/misc.c (gnat_init): Do not call
+ internal_reference_types.
+
+2016-04-27 Svante Signell <svante.signell@gmail.com>
+
+ * gcc-interface/Makefile.in (x86 GNU/Hurd): Use s-osinte-gnu.adb.
+ * s-osinte-gnu.ads: Small tweaks.
+ * s-osinte-gnu.adb: New file.
+
+2016-04-21 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_prag.adb (Match_Constituent): Treat a constant as a legal
+ constituent even if it is not to prevent spurious errors.
+
+2016-04-21 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_ch4.adb: Minor typo fixes and reformatting.
+
+2016-04-21 Dmitriy Anisimkov <anisimko@adacore.com>
+
+ * g-calend.ads (No_Time): The same value in any timezone.
+ * g-socket.adb (Raise_Host_Error): Remove ending
+ dot from original error message before append colon delimited
+ host name.
+
+2016-04-21 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch3.adb: Code cleanup.
+ * sem_ch6.adb: Code cleanup.
+ (Is_Matching_Limited_View): New routine.
+ (Matches_Limited_With_View): Reimplemented.
+ * sem_ch10.adb (Decorate_Type): Code cleanup.
+
+2016-04-21 Doug Rupp <rupp@adacore.com>
+
+ * tracebak.c (PPC ELF): Add macro defs for lynxos178e.
+
+2016-04-21 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch4.adb (Try_Container_Indexing): If there are overloaded
+ indexing functions, collect all overloadings of the call firts,
+ and then transfer them to indexing node, to prevent interleaving
+ of the set of interpretations of the nodes involved.
+ * sem_res.adb (Resolve): Suppress cascaded errors that report
+ ambiguities when one of the actuals in an overloaded generatlized
+ indexing operation is illegal and has type Any_Type, as is done
+ for similar cascaded errors in subprogram calls.
+ (Valid_Tagged_Conversion): Cleanup conversion checks when one
+ of the types involved is a class-wide subtype.
+
+2016-04-21 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch12.adb (Load_Parent_Of_Generic): When looking for the
+ subprogram declaration within a wrapper package, skip pragmas
+ that may have been generated by aspect specifications on the
+ generic instance.
+
+2016-04-21 Javier Miranda <miranda@adacore.com>
+
+ * exp_aggr.adb (Component_Not_OK_For_Backend): Generating C
+ code return True for array identifiers since the backend needs
+ to initialize such component by means of memcpy().
+
+2016-04-21 Arnaud Charlet <charlet@adacore.com>
+
+ * a-tasatt.adb, a-tasatt.ads (Fast_Path): Rewritten to avoid reading
+ potentially uninitialized memory.
+ * sem_ch3.adb: Minor style fix in comment.
+
+2016-04-21 Arnaud Charlet <charlet@adacore.com>
+
+ * gnat_rm.texi, gnat_ugn.texi,
+ doc/gnat_ugn/gnat_project_manager.rst,
+ doc/gnat_ugn/building_executable_programs_with_gnat.rst,
+ doc/gnat_ugn/gnat_and_program_execution.rst,
+ doc/gnat_ugn/gnat_utility_programs.rst,
+ doc/gnat_ugn/the_gnat_compilation_model.rst,
+ doc/gnat_rm/implementation_defined_attributes.rst,
+ doc/gnat_rm/standard_and_implementation_defined_restrictions.rst,
+ doc/gnat_rm/implementation_defined_pragmas.rst,
+ doc/gnat_rm/the_gnat_library.rst,
+ doc/gnat_rm/implementation_defined_aspects.rst: Update doc.
+ * doc/Makefile: Cleanups.
+
+2016-04-21 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_pakd.adb, sem_ch13.adb: Minor reformatting.
+
+2016-04-21 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_dbug.adb, exp_dbug.ads (Qualify_Entity_Name): Add suffixes to
+ disambiguate local variables that may be hidden from inner visibility
+ by nested block declarations or loop variables.
+
+2016-04-21 Jerome Lambourg <lambourg@adacore.com>
+
+ * s-soflin.adb: Initialize the Stack_Limit global variable.
+
+2016-04-21 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * lib-writ.adb: Minor reformatting.
+
+2016-04-21 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_pakd.adb (Compute_Number_Components): New function to
+ build an expression that computes the number of a components of
+ an array that may be multidimensional.
+ (Expan_Packed_Eq): Use it.
+
+2016-04-21 Arnaud Charlet <charlet@adacore.com>
+
+ * g-traceb.ads: Update list of supported platforms.
+
+2016-04-21 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch13.adb (Add_Predicates): if the type is declared in
+ an inner package it may be frozen outside of the package, and
+ the generated pragma has not been analyzed yet, the expression
+ for the predicate must be captured and added to the predicate
+ function at this point.
+
+2016-04-21 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * contracts.adb (Analyze_Package_Body_Contract): Do not check
+ for a missing package refinement because 1) packages do not have
+ "refinement" and 2) the check for proper state refinement is
+ performed in a different place.
+ * einfo.adb (Has_Non_Null_Visible_Refinement): Reimplemented.
+ (Has_Null_Visible_Refinement): Reimplemented.
+ * sem_ch3.adb (Analyze_Declarations): Determine whether all
+ abstract states have received a refinement and if not, emit
+ errors.
+ * sem_ch7.adb (Analyze_Package_Declaration): Code
+ cleanup. Determine whether all abstract states of the
+ package and any nested packages have received a refinement
+ and if not, emit errors.
+ (Requires_Completion_In_Body): Add new formal parameter
+ Do_Abstract_States. Update the comment on usage. Propagate the
+ Do_Abstract_States flag to all Unit_Requires_Body calls.
+ (Unit_Requires_Body): Remove formal
+ parameter Ignore_Abstract_States. Add new formal paramter
+ Do_Abstract_States. Propagate the Do_Abstract_States flag to
+ all Requires_Completion_In calls.
+ * sem_ch7.ads (Unit_Requires_Body): Remove formal
+ parameter Ignore_Abstract_States. Add new formal paramter
+ Do_Abstract_States. Update the comment on usage.
+ * sem_ch9.adb (Analyze_Single_Protected_Declaration): Do
+ not initialize the constituent list as this is now done on a
+ need-to-add-element basis.
+ (Analyze_Single_Task_Declaration):
+ Do not initialize the constituent list as this is now done on
+ a need-to-add-element basis.
+ * sem_ch10.adb (Decorate_State): Do not initialize the constituent
+ lists as this is now done on a need-to-add-element basis.
+ * sem_prag.adb (Analyze_Constituent): Set the
+ refinement constituents when adding a new element.
+ (Analyze_Part_Of_In_Decl_Part): Set the Part_Of constituents when
+ adding a new element.
+ (Analyze_Part_Of_Option): Set the Part_Of
+ constituents when adding a new element.
+ (Analyze_Pragma): Set the Part_Of constituents when adding a new
+ element.
+ (Check_Constituent_Usage (all versions)): Reimplemented.
+ (Collect_Constituent): Set the refinement constituents when adding
+ a new element.
+ (Create_Abstract_State): Do not initialize the
+ constituent lists as this is now done on a need-to-add-element basis.
+ (Propagate_Part_Of): Set the Part_Of constituents when
+ adding a new element.
+ * sem_util.adb (Check_State_Refinements): New routine.
+ (Has_Non_Null_Refinement): Reimplemented.
+ (Has_Null_Refinement): Reimplemented.
+ (Requires_State_Refinement): Removed.
+ * sem_util.ads (Check_State_Refinements): New routine.
+ (Requires_State_Refinement): Removed.
+
+2016-04-21 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * lib-writ.adb, sem_ch6.adb: Minor reformatting and code cleanup.
+ * sem.adb: Fix comment.
+
+2016-04-21 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Analyze_Subtype_Declaration): A subtype
+ declaration with no aspects, whose subtype_mark is a subtype
+ with predicates, inherits the list of subprograms for the type.
+
+2016-04-21 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_aggr.adb (Has_Per_Object_Constraint): Refine previous
+ change.
+
+2016-04-21 Thomas Quinot <quinot@adacore.com>
+
+ * g-socket.adb (Raise_Host_Error): Include additional Name parameter.
+
+2016-04-21 Ed Schonberg <schonberg@adacore.com>
+
+ * lib-writ.adb (Write_ALI): Do not record in ali file units
+ that are present in the files table but not analyzed. These
+ units are present because they appear in the context of units
+ named in limited_with clauses, and the unit being compiled does
+ not depend semantically on them.
+
+2016-04-21 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Simplify code to
+ create the procedure body for an function returning an array type,
+ when generating C code. Reuse the subprogram body rather than
+ creating a new one, both as an efficiency measure and because
+ in an instance the body may contain global references that must
+ be preserved.
+
+2016-04-21 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch3.adb, exp_attr.adb, exp_ch6.adb, exp_aggr.adb: Minor
+ reformatting.
+
+2016-04-21 Javier Miranda <miranda@adacore.com>
+
+ * exp_aggr.adb (Component_Check): Extend
+ the check that verifies that the aggregate has no function
+ calls to handle transformations performed by the frontend.
+ (Ultimate_Original_Expression): New subprogram.
+
+2016-04-21 Philippe Gil <gil@adacore.com>
+
+ * krunch.adb (Krunch): Fix krunching of i-java.
+
+2016-04-21 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch8.adb (Evaluation_Required): Always return
+ True when Modify_Tree_For_C.
+
+2016-04-21 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gnatlink.adb (Gnatlink): Robustify detection of Windows target.
+ * alloc.ads: Minor comment fixes.
+ * einfo.ads: Fix typo.
+
+2016-04-21 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_aggr.adb (Component_Not_OK_For_Backend): Redo previous
+ changes to handle all cases of components depending on the
+ discriminant, not just string literals.
+
+2016-04-21 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Analyze_Subtype_Declaration): If the subtype
+ declaration is the generated declaration for a generic actual,
+ inherit predicates from the actual if it is a predicated subtype.
+
+2016-04-21 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch6.adb (Rewrite_Function_Call_For_C): If the function is
+ inherited and its result is controlling, introduce a conversion
+ on the actual for the corresponding procedure call, to avoid
+ spurious type errors.
+
+2016-04-21 Jerome Lambourg <lambourg@adacore.com>
+
+ * krunch.adb (Krunch): Fix krunching of i-vxworks.
+
+2016-04-21 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_aggr.adb: Minor reformatting and code cleanup.
+
+2016-04-21 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch13.adb (Resolve_Name): Omit quantified expressions from
+ resolution, because they introduce local names. Full resolution
+ will take place when predicate function is constructed.
+
+2016-04-21 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_aggr.adb (Component_Not_OK_For_Backend): Refine previous
+ change to take into account Per_Object_Constraint field rather
+ than special casing strings.
+ * exp_ch6.adb: Fix typo in Replace_Returns.
+
+2016-04-21 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch5.adb: Minor reformatting.
+
+2016-04-21 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_aggr.adb (Backend_Processing_Possible): Return False
+ when generating C and aggregate contains function calls.
+
+2016-04-21 Tristan Gingold <gingold@adacore.com>
+
+ * krunch.adb (Krunch): Only partially krunch children of
+ Interfaces that aren't known.
+
+2016-04-21 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_prag.adb (Make_Inline): Handle properly the instantiation
+ of a generic subpprogram that carries an Inline aspect. Place
+ inline info on the anonymous subprogram that is constructed in
+ the wrapper package.
+ (Analyze_Pragma, case Pure): Do not check placement if pragma
+ appears within an instantiation, which can be nested at any level.
+ * sem_ch12.adb (Analyze_Instance_And_Renamings): Do not copy Freeze
+ node from anonymous subprogram to its visible renaming. The
+ freeze node will be constructed if the subprogram carries
+ delayed aspects.
+ (Set_Global): Preserve dimension information if present (from
+ code reading).
+
+2016-04-21 Vasiliy Fofanov <fofanov@adacore.com>
+
+ * gnatlink.adb: Change wording of the warning message on
+ problematic filenames to be more neutral. Add a new substring
+ "patch" introduced on Windows 10.
+
+2016-04-21 Philippe Gil <gil@adacore.com>
+
+ * tracebak.c (__gnat_backtrace): handle bad RIP values (win64 only)
+
+2016-04-21 Javier Miranda <miranda@adacore.com>
+
+ * exp_aggr.adb (Component_Not_OK_For_Backend): Return true for string
+ literals.
+
+2016-04-21 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * einfo.adb (Has_Non_Null_Abstract_State): New routine.
+ * einfo.ads New synthesized attribute
+ Has_Non_Null_Abstract_State along with occurrences in entities.
+ (Has_Non_Null_Abstract_State): New routine.
+ * sem_ch7.adb (Unit_Requires_Body): Add local variable
+ Requires_Body. A package declaring an abstract state requires
+ a body only when the state is non-null and the package contains
+ at least one other construct that requires completion in a body.
+ * sem_util.adb (Mode_Is_Off): Removed.
+ (Requires_State_Refinement): Remove an obsolete check. Code
+ cleanup.
+
+2016-04-21 Bob Duff <duff@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute): In processing
+ the 'Old attribute, a warning is given for infinite recursion. Fix
+ the code to not crash when the prefix of 'Old denotes a protected
+ function.
+ * sem_ch5.adb (Analyze_Iterator_Specification):
+ Avoid calling Is_Dependent_Component_Of_Mutable_Object in cases
+ where the parameter would not be an object.
+
+2016-04-21 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_eval.adb (Compile_Time_Compare): Be prepared for an empty
+ Etype or Underlying_Type of the operands.
+
+2016-04-21 Eric Botcazou <ebotcazou@adacore.com>
+
+ * atree.adb (Print_Statistics): Protect against overflows and
+ print the memory consumption in bytes.
+ * table.adb (Reallocate): Do the intermediate calculation of the new
+ size using the Memory.size_t type.
+
+2016-04-21 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_attr.adb (Is_Inline_Floating_Point_Attribute): Suppress
+ expansion of Attribute_Machine and Attribute_Model for AAMP.
+
+2016-04-21 Ed Schonberg <schonberg@adacore.com>
+
+ * freeze.adb: Disable previous change for now.
+
+2016-04-21 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch8.adb (Find_Selected_Component): If prefix has an
+ access type and designated type is a limited view, introduce
+ an explicit dereference before continuing the analysis, and
+ set its type to the non-limited view of the designated type,
+ if we are in context where it is available.
+
+2016-04-21 Ed Schonberg <schonberg@adacore.com>
+
+ * freeze.adb: Freeze profile in ASIS mode.
+
+2016-04-21 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_aux.ads, sem_aux.adb (Has_Rep_Item): New variant.
+ * sem_util.adb (Inherit_Rep_Item_Chain): Reimplemented.
+
+2016-04-21 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch6.adb: Minor reformatting.
+
+2016-04-21 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch13.adb: Minor comment update.
+
+2016-04-21 Ed Schonberg <schonberg@adacore.com>
+
+ * freeze.ads, freeze.adb (Freeze_Entity, Freeze_Before): Add
+ boolean parameter to determine whether freezing an overloadable
+ entity freezes its profile as well. This is required by
+ AI05-019. The call to Freeze_Profile within Freeze_Entity is
+ conditioned by the value of this flag, whose default is True.
+ * sem_attr.adb (Resolve_Attribute, case 'Access): The attribute
+ reference freezes the prefix, but it the prefix is a subprogram
+ it does not freeze its profile.
+
+2016-04-21 Javier Miranda <miranda@adacore.com>
+
+ * exp_util.adb (Build_Procedure_Form): No action needed for
+ subprogram renamings since the backend can generate the call
+ using the renamed subprogram. This leaves the tree more clean
+ to the backend.
+ * exp_ch6.adb (Expand_Call): Extend previous patch for
+ rewritten-for-c entities to handle subprogram renamings.
+ (Rewrite_Function_Call_For_C): Handle subprogram renamings.
+
+2016-04-21 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch13.adb: Code cleanup.
+
+2016-04-21 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Analyze_Subprogram_Body_Helper): If the body is
+ created for SPARK_To_C, the entity must remain invisible so it
+ does not overload subsequent references to the original function.
+ * exp_ch6.adb (Build_Procedure_Body_Form, Replace_Returns):
+ Handle Extended_Return_Statements by replacing it with a block
+ with assignments and a simple return statement.
+ * exp_util.adb (Build_Procedure_Form): Make procedure entity
+ invisible after analyzing declaration, to prevent improper
+ overloading.
+
+2016-04-21 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch6.adb (Build_Subprogram_Declaration): Propagate the
+ attribute Rewritten_For_C to the body since since the expander
+ may generate calls using that entity.
+ * exp_ch6.adb (Expand_Call): For internally generated
+ calls ensure that they reference the entity of the spec
+ of the called function.
+ (Rewritten_For_C_Func_Id): New subprogram.
+ (Rewritten_For_C_Proc_Id): New subprogram.
+ (Rewrite_Function_Call_For_C): Invoke the new subprogram to
+ ensure that we skip freezing entities.
+ * exp_util.adb (Build_Procedure_Form): No action needed if the
+ procedure was already built.
+
+2016-04-21 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch3.adb, exp_util.adb, sem_ch13.adb, exp_unst.adb: Minor
+ reformatting.
+
+2016-04-21 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_util.adb (Denotes_Iterator): Use root type to determine
+ whether the ultimate ancestor is the predefined iterator
+ interface pakage.
+ * exp_ch5.adb (Expand_Iterator_Over_Container): simplify code
+ and avoid reuse of Pack local variable.
+
+2016-04-21 Olivier Hainque <hainque@adacore.com>
+
+ * system-vxworks-arm.ads, system-vxworks-sparcv9.ads,
+ system-vxworks-ppc.ads, system-vxworks-m68k.ads,
+ system-vxworks-mips.ads, system-vxworks-x86.ads: Define
+ Executable_Extension to ".out".
+
+2016-04-21 Javier Miranda <miranda@adacore.com>
+
+ * frontend.adb: Update call to Unnest_Subprograms.
+ * exp_ch6.ads, exp_ch6.adb, exp_unst.ads, exp_unst.adb
+ (Unnest_Subprograms): Moved to package exp_unst.
+ * exp_unst.ads (Unnest_Subprogram): Moved to the body of the
+ package.
+ * exp_dbug.adb (Qualify_Entity_Name): Enable qualification of
+ enumeration literals when generating C code.
+
+2016-04-21 Javier Miranda <miranda@adacore.com>
+
+ * frontend.adb: Remove call to initialize Exp_Ch6.
+ * exp_ch6.ads, exp_ch6.adb (Initialize): removed.
+ (Unest_Entry/Unest_Bodies): Removed.
+ (Unnest_Subprograms): Code cleanup.
+
+2016-04-21 Arnaud Charlet <charlet@adacore.com>
+
+ * set_targ.adb (Read_Target_Dependent_Values):
+ close target description file once its contents is read.
+ * s-os_lib.adb (Non_Blocking_Spawn, version with Stdout_File
+ and Stderr_File): Close local file descriptors before spawning
+ child process.
+ * exp_util.adb (Containing_Package_With_Ext_Axioms): Limit scope of
+ local variables to make the code easier to understand and avoid
+ duplicated calls to Parent and Generic_Parent.
+
+2016-04-20 Bob Duff <duff@adacore.com>
+
+ * s-os_lib.ads: Minor comment fix.
+
+2016-04-20 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch5.adb (Expand_N_Assignment_Statement): Do no generate
+ a discriminant check for a type whose partial view has unknown
+ discriminants when the full view has discriminants with defaults.
+
+2016-04-20 Javier Miranda <miranda@adacore.com>
+
+ * exp_util.adb (Remove_Side_Effects): When generating C code
+ remove side effect of type conversion of access to unconstrained
+ array type.
+ (Side_Effect_Free): Return false for the type
+ conversion of access to unconstrained array type when generating
+ C code.
+ * sem_res.adb (Resolved_Type_Conversion): Remove side effects
+ of access to unconstrained array type conversion when generating
+ C code.
+
+2016-04-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch13.adb (Build_Predicate_Function_Declaration): New
+ function, to construct the declaration of a predicate function
+ at the end of the current declarative part rather than at the
+ (possibly later) freeze point of the type. This also allows uses
+ of a type with predicates in instantiations elsewhere.
+ (Resolve_Aspect_Expression): New procedure to detect visiblity
+ errors in aspect expressions, at the end of the declarative part
+ that includes the type declaration.
+ * sem_ch3.adb (Complete_Private_Subtype): Propagate properly the
+ predicate function from private to full view.
+ * einfo.adb (Predicate_Function): Refine search for predicate
+ function when type has a full view and predicate function may
+ be defined on either view.
+
+2016-04-20 Javier Miranda <miranda@adacore.com>
+
+ * frontend.adb: Passing the root of the tree to
+ Unnest_Subprograms().
+ * exp_ch6.adb (Expand_N_Subprogram_Body): Remove code that
+ took care of adding subprograms to the Unest_Bodies table since
+ performing such action too early disables the ability to process
+ generic instantiations.
+ (Unnest_Subprograms): Adding parameter.
+ (Search_Unnesting_Subprograms): New subprogram.
+ * exp_ch6.ads (Unnest_Subrograms): Update documentation.
+
+2016-04-20 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_util.adb, freeze.adb, sem_util.adb: Minor reformatting.
+
+2016-04-20 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_unst.adb (Check_Static_Type): For a private type, check
+ full view.
+
+2016-04-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_attr.adb (Check_Type): Reject an attribute reference in
+ an aspect expression, when the prefix of the reference is the
+ current instance of the type to which the aspect applies.
+
+2016-04-20 Bob Duff <duff@adacore.com>
+
+ * sem_ch6.adb (Enter_Overloaded_Entity): Do not warn about
+ hiding unless we're actually hiding something. The previous
+ code would (for example) warn about a "<" on a record type
+ because it incorrectly thought it was hiding the "<" on Boolean
+ in Standard. We need to check that the homonym S is in fact a
+ homograph of a predefined operator.
+
+2016-04-20 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_util.ads, exp_util.adb (Build_Procedure_Form): Moved here
+ from exp_ch6.adb, for use in SPARK_To_C mode when creating the
+ procedure equivalent to a function returning an array, when this
+ construction is deferred to the freeze point of the function.
+ * sem_util.adb (Is_Unchecked_Conversion_Instance): Include a
+ function that renames an instance of Unchecked_Conversion.
+ * freeze.adb (Freeze_Subprogram): Generate the proper procedure
+ declaration for a function returning an array.
+ * exp_ch6.adb (Build_Procedure_Form): Moved to exp_util.
+
+2016-04-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_util.ads, sem_util.adb (Is_Expanded_Priority_Attribute):
+ New predicate to determine that in a context with full run-time,
+ a function call is an expansion of a reference to attribute
+ Priority.
+ * sem_ch5.adb (Analyze_Function_Call): use it.
+ * exp_ch5.adb (Expand_N_Subprogram_Call): use it.
+
+2016-04-20 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * einfo.adb Flag286 is now used as Is_Exception_Handler.
+ (Is_Exception_Handler): New routine.
+ (Set_Is_Exception_Handler): New routine.
+ (Write_Entity_Flags): Output the status of Is_Exception_Handler.
+ * einfo.ads New attribute Is_Exception_Handler along with
+ occurrences in entities.
+ (Is_Exception_Handler): New routine along with pragma Inline.
+ (Set_Is_Exception_Handler): New routine along with pragma Inline.
+ * exp_ch7.adb (Make_Transient_Block): Ignore blocks generated
+ for exception handlers with a choice parameter.
+ * sem_ch11.adb (Analyze_Exception_Handlers): Mark the scope
+ generated for a choice parameter as an exception handler.
+
+2016-04-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Build_Derived_Access_Type): Remove dead code.
+ (Constrain_Discriminated_Type): In an instance, if the type has
+ unknown discriminants, use its full view.
+ (Process_Subtype): Check that the base type is private before
+ adding subtype to Private_Dependents list.
+
+2016-04-20 Bob Duff <duff@adacore.com>
+
+ * sem_ch13.adb: Minor comment fix.
+
+2016-04-20 Yannick Moy <moy@adacore.com>
+
+ * sem_ch4.adb: Fix typos in comments.
+ * sem_res.adb (Resolve_Case_Expression): Fix type of case alternatives.
+
+2016-04-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch4.adb (Analyze_Selected_Component): A reference to the
+ current instance of a task type is legal if the prefix is an
+ expression of that task type and the selector is an entry or
+ entry family.
+
+2016-04-20 Arnaud Charlet <charlet@adacore.com>
+
+ * a-cfdlli.ads (List): Type is no longer tagged, not needed. Move
+ varsize field at the end for efficiency.
+
+2016-04-20 Vincent Celier <celier@adacore.com>
+
+ * gnatcmd.adb: Do not invoke gprls when the invocation of "gnat
+ ls" includes the switch -V.
+ * clean.adb: "<target>-gnatclean -P" now calls "gprclean
+ --target=<target>"
+ * make.adb: "<target>-gnatmake -P" now calls "gprbuild
+ --target=<target>"
+
+2016-04-20 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch12.adb (Qualify_Type): Do not perform
+ partial qualification when the immediate scope is a generic unit.
+
+2016-04-20 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_unst.adb: Minor reformatting.
+
+2016-04-20 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch4.adb (Expand_Allocator_Expression): Ensure that the
+ tag assignment and adjustment preceed the accessibility check.
+ * exp_ch7.adb (Is_Subprogram_Call): Reimplemented.
+
+2016-04-20 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_prag.adb (Expand_Attributes): Ensure that
+ the temporary used to capture the value of attribute 'Old's
+ prefix is properly initialized.
+
+2016-04-20 Javier Miranda <miranda@adacore.com>
+
+ * exp_unst.ads, exp_unst.adb (Get_Level, Subp_Index): Moved to library
+ level.
+
+2016-04-20 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch9.adb (Analyze_Task_Type_Declaration): Shut down warning
+ in codepeer mode.
+
+2016-04-20 Vincent Celier <celier@adacore.com>
+
+ * make.adb: Code cleanup.
+
+2016-04-20 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch4.adb (Expand_Allocator_Expression): Help C code
+ generation.
+
+2016-04-20 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch12.adb (Copy_Generic_Node): Handle the special
+ qualification installed for universal literals that act as
+ operands in binary or unary operators. (Qualify_Operand): Mark
+ the qualification to signal the instantiation mechanism how to
+ handle global reference propagation.
+ * sinfo.adb (Is_Qualified_Universal_Literal): New routine.
+ (Set_Is_Qualified_Universal_Literal): New routine.
+ * sinfo.ads New attribute Is_Qualified_Universal_Literal along
+ with occurrences in nodes.
+ (Is_Qualified_Universal_Literal):
+ New routine along with pragma Inline.
+ (Set_Is_Qualified_Universal_Literal): New routine along with
+ pragma Inline.
+
+2016-04-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem.adb (Do_Analyze): Save and restore Style_Max_Line_Length
+ so that the corresponding checks are preserved across compilations
+ that include System.Constants in their context.
+
+2016-04-20 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_type.adb: Minor typo fix and reformatting.
+ * a-conhel.ads: Update comment.
+
+2016-04-20 Bob Duff <duff@adacore.com>
+
+ * a-cihama.adb, a-cihase.adb, a-coinve.adb (Copy): Rewrite the
+ code so it doesn't trigger an "uninit var" warning.
+
+2016-04-20 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_attr.ads Add new table Universal_Type_Attribute.
+ * sem_util.adb (Yields_Universal_Type): Use a table lookup when
+ checking attributes.
+
+2016-04-20 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_aggr.adb (Init_Stored_Discriminants,
+ Init_Visible_Discriminants): New procedures, subsidiary of
+ Build_Record_Aggr_Code, to handle properly the construction
+ of aggregates for a derived type that constrains some parent
+ discriminants and renames others.
+
+2016-04-20 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch12.adb (Qualify_Universal_Operands): New routine.
+ (Save_References_In_Operator): Add explicit qualifications in
+ the generic template for all operands of universal type.
+ * sem_type.adb (Disambiguate): Update the call to Matches.
+ (Matches): Reimplemented.
+ * sem_util.ads, sem_util.adb (Yields_Universal_Type): New routine.
+
+2016-04-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch13.adb (Rep_Item_Too_Late): Better error message for
+ an illegal aspect that freezes the entity to which it applies.
+
+2016-04-20 Bob Duff <duff@adacore.com>
+
+ * a-stwibo.ads, a-stzbou.ads
+ ("="): Add overriding keyword before function to avoid crash when
+ compiler is called with -gnatyO (check overriding indicators).
+
+2016-04-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_prag.adb (Analyze_Pragma, case Check_Policy): If this
+ is a configuration pragma and it uses the ARG syntax, insert
+ the rewritten pragma after the current one rather than using
+ Insert_Actions.
+
+2016-04-20 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_aggr.adb (Backend_Processing_Possible): Add handling of
+ C back-end.
+
+2016-04-20 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * s-imgllu.adb, sem_util.adb, s-imgint.adb, s-imguns.adb,
+ s-imglli.adb: Minor reformatting.
+
+2016-04-20 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_res.adb (Rewrite_Renamed_Operator): Do not rewrite the
+ renamed operator when the associated node appears within a
+ pre/postcondition.
+ * sem_util.ads, sem_util.adb (In_Pre_Post_Condition): New routine.
+
+2016-04-20 Yannick Moy <moy@adacore.com>
+
+ * osint.adb (Relocate_Path): Fix test when Path is shorter than Prefix.
+ * einfo.adb (Set_Overridden_Operation): Add assertion.
+ * sem_util.adb (Unique_Entity): for renaming-as-body return the spec
+ entity.
+
+2016-04-20 Javier Miranda <miranda@adacore.com>
+
+ * exp_unst.adb (Append_Unique_Call): New subprogram.
+ (Unnest_Subprogram): Replace the unique occurrence
+ of Call.Append() by Append_Unique_Call() which protects us from
+ adding to the Calls table duplicated entries.
+
+2016-04-20 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_attr.adb (Is_GCC_Target): Fix for C backend.
+ * xref_lib.ads (Dependencies_Tables): instantiate
+ Table package with types that guarantee its safe use.
+ * s-imgllu.adb, s-imgint.adb, s-imguns.adb, s-imglli.adb: Avoid nested
+ procedures.
+
+2016-04-20 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_attr.adb (Expand_N_Attribute_Reference [Attribute_Valid]):
+ Disable expansion when generating C code.
+ * sinfo.ads, inline.ads: Minor editing.
+
+2016-04-20 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_util.adb, contracts.adb, ghost.adb, exp_ch6.adb: Minor
+ reformatting.
+
+2016-04-20 Javier Miranda <miranda@adacore.com>
+
+ * contracts.adb (Build_Postconditions_Procedure): Code cleanup.
+ * ghost.adb (Os_OK_Ghost_Context.Is_OK_Declaration): Handle the
+ declaration of the internally built _postcondition procedure.
+
+2016-04-20 Arnaud Charlet <charlet@adacore.com>
+
+ * snames.ads-tmpl (Internal_Attribute_Id, Attribute_Class_Array): Fix
+ indentation.
+ * sem_util.adb (Is_Unchecked_Conversion_Instance):
+ defense against library-level renamings of other functions,
+ which are never instances of Unchecked_Conversion.
+ * einfo.ads: minor fix of casing in comment
+
+2016-04-20 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch6.adb (Expand_N_Subprogram_Stub): Do not expand a body
+ that has been analyzed and expanded already. Qualify the names
+ in the proper body for use in the generation of C code.
+
+2016-04-20 Javier Miranda <miranda@adacore.com>
+
+ * contracts.adb (Build_Postconditions_Procedure): Force its
+ inlining when generating C code.
+ * sem_attr.adb (Analyze_Attribute_Old_Result): Handle inlined
+ _postconditions when generating C code.
+ * exp_ch6.adb (Inlined_Subprogram): Inline calls to
+ _postconditions when generating C code.
+ * sinfo.ads, sinfo.adb (Corresponding_Spec, Set_Corresponding_Spec):
+ types of return value and argument changed from Node_Id to
+ Entity_Id.
+
+2016-04-20 Vincent Celier <celier@adacore.com>
+
+ * make.adb, clean.adb, gnatname.adb: Revert previous change for now.
+
+2016-04-20 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch12.adb (Analyze_Instance_And_Renamings): Do not reset
+ the Has_Delayed_Freeze flag on the anonymous instance node.
+
+2016-04-20 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch5.adb (Analyze_Iterator_Specification): Remove transient
+ scope associated with the renaming object declaration.
+ * exp_util.adb (Insert_Actions): Remove handling of iterator
+ loop marked as requiring the secondary stack.
+
+2016-04-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_attr.adb (Analyze_Attribute, case 'Image): Implement
+ AI12-0124, which extends the functionality of the attribute so it
+ reflects the semantics of GNAT 'Img when applied to scalar types.
+ * lib-xref.adb: minor whitespace layout fix.
+
+2016-04-20 Vincent Celier <celier@adacore.com>
+
+ * clean.adb (Gnatclean): Fail if project file specified and
+ gprclean is not available.
+ * gnatname.adb: Fail is -P is used and gprname is not available.
+ * make.adb (Initialize): Fail if project file specified and
+ gprbuild is not available.
+
+2016-04-20 Bob Duff <duff@adacore.com>
+
+ * sem_ch5.adb (Analyze_Iterator_Specification): Do not use secondary
+ stack when possible.
+
+2016-04-20 Gary Dismukes <dismukes@adacore.com>
+
+ * par_sco.adb, sem_util.adb, sem_ch13.adb: Minor typo corrections and
+ reformatting.
+
+2016-04-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_prag.adb (Analyze_Pragma, case Default_Storage_Pool):
+ If the pragma comes from an aspect specification, verify that
+ the aspect applies to an entity with a declarative part.
+ * exp_ch5.adb: Code cleanup.
+
+2016-04-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_res.adb (Resolve_If_Expression): If first expression is
+ universal, resolve subsequent ones with the corresponding class
+ type (Any_Integer or Any_Real).
+
+2016-04-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch5.adb (Analyze_Iterator_Specification): If expansion is
+ disabled, complete the analysis of the iterator name to ensure
+ that reference for entities within are properly generated.
+
+2016-04-20 Arnaud Charlet <charlet@adacore.com>
+
+ * a-dispat.ads (Yield): add Global contract.
+ * a-calend.ads, a-reatim.ads: Added Initializes => Clock_Time.
+ * a-taside.adb: Added Initializes => Tasking_State.
+
+2016-04-20 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch13.adb (Build_Invariant_Procedure):
+ Reimplement the invariant procedure spec and body insertion.
+
+2016-04-20 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch13.adb (Add_Invariant): Do not replace
+ the saved expression of an invariatn aspect when inheriting
+ a class-wide type invariant as this clobbers the existing
+ expression. Do not use New_Copy_List as it is unnecessary
+ and leaves the parent pointers referencing the wrong part of
+ the tree. Do not replace the type references for ASIS when
+ inheriting a class-wide type invariant as this clobbers the
+ existing replacement.
+
+2016-04-20 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_util.adb (Build_Explicit_Dereference): If the designated
+ expression is an entity name, generate reference to the entity
+ because it will not be resolved again.
+
+2016-04-19 Arnaud Charlet <charlet@adacore.com>
+
+ * doc/gnat_rm/standard_and_implementation_defined_restrictions.rst,
+ gnat_rm.texi: Update documentation.
+
+2016-04-19 Olivier Hainque <hainque@adacore.com>
+
+ * par_sco.adb (Traverse_One, case N_Case_Statement):
+ Skip pragmas before the first alternative.
+ (Traverse_Handled_Statement_Sequence, Exception_Handlers): Likewise.
+
+2016-04-19 Tristan Gingold <gingold@adacore.com>
+
+ * adaint.c (__gnat_lwp_self): New function (for darwin).
+ * s-osinte-darwin.ads, s-osinte-darwin.adb (lwp_self): Import
+ of __gnat_lwp_self.
+
+2016-04-19 Olivier Hainque <hainque@adacore.com>
+
+ * sem_util.adb (Build_Elaboration_Entity): Always request an
+ elab counter when preserving control-flow.
+
+2016-04-19 Olivier Hainque <hainque@adacore.com>
+
+ * sem_ch13.adb (Build_Invariant_Procedure_Declaration): Set
+ Needs_Debug_Info when producing SCOs.
+ * par_sco.adb (Traverse_Aspects): Fix categorization of
+ Type_Invariant to match actual processing as activated depending
+ on pragma Assertion_Policy.
+ * sem_prag.adb (Analyze_Pragma): Remove special case for
+ Name_Invariant regarding SCO generation, which completely disabled
+ the production of SCOs for Invariant pragmas and aspects.
+
+2016-04-19 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * checks.adb, sem_util.adb, sem_res.adb, sem_attr.adb: Minor
+ reformatting.
+
+2016-04-19 Ed Schonberg <schonberg@adacore.com>
+
+ * freeze.adb (Freeze_Profile): Refine predicate that checks
+ whether a function that returns a limited view is declared in
+ another unit and cannot be frozen at this point.
+
+2016-04-19 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_aggr.adb (Component_Count): Handle properly superflat
+ arrays, i.e. empty arrays where Hi < Lo - 1, to ensure that the
+ return value of the function is Natural, rather than leaving
+ the handling of such arrays to the caller of this function.
+
+2016-04-19 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_prag.adb, sem_attr.adb, par-prag.adb, exp_aggr.adb, sem_type.adb
+ sem_ch12.adb, sem_ch3.adb, exp_ch7.adb, exp_ch9.adb: Code cleanup.
+ * sem_res.adb, sem_util.ads, sem_util.adb (Is_OK_Volatile_Context):
+ Promoted from being a nested subprogram in Sem_Res.Resolve_Entity_Name
+ to publicly visible routine in Sem_Util.
+
+2016-04-19 Ed Schonberg <schonberg@adacore.com>
+
+ * checks.adb (Apply_Parameter_Aliasing_Checks): Do not apply
+ the check if the type of the actual is By_Reference.
+
+2016-04-19 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_res.adb (Within_Subprogram_Call): Detect
+ also nodes that appear in entry calls.
+ (Resolve_Actuals, Insert_Default): Propagate
+ dimension information if any, from default expression to the
+ copy that appears in the list of actuals.
+ * uintp.ads: minor whitespace fix in comment.
+ * sem_prag.adb, stringt.adb, inline.adb, lib-xref-spark_specific.adb:
+ Minor code cleanup.
+ * set_targ.adb (Set_Targ): convert directly from
+ Natural to Pos, without intermediate conversion to Int.
+
+2016-04-19 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_ch6.adb (Process_Formals): Mark suspicious reference to
+ SPARK RM in comment.
+ * sem_prag.adb (Analyze_Global_Item): Fix reference to SPARK RM
+ in comment.
+ * sem_res.adb (Property_Error, Resolve_Actuals): Fix reference
+ to SPARK RM in both comment and error message.
+
+2016-04-19 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch6.adb (Possible_Freeze): If the type is an incomplete
+ CW type, then the subprogram must have a delayed freeze. This
+ ensures that the backend can properly recover the full view when
+ elaborating the access subprogram declaration.
+
+2016-04-19 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_attr.adb (Resolve_Attribute, case 'Access): Freeze
+ overloadable entity if originally overloaded.
+
+2016-04-19 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_aggr.adb, exp_ch3.adb, exp_ch7.adb, exp_ch9.adb, exp_code.adb,
+ exp_fixd.adb, namet.adb, osint.adb, osint.ads, par-ch2.adb,
+ sem_ch10.adb, sem_ch12.adb, sem_disp.adb, sem_elab.adb, sem_elim.adb
+ sem_util.adb, styleg.adb, styleg.ads, stylesw.ads: Minor code
+ clean up.
+
+2016-04-19 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_util.adb (Copy_Node_With_Replacement):
+ use Set_Comes_From_Source instead of directly manipulating
+ internals of the node table.
+ * sem_util.adb (Within_Scope): refactored to remove duplicated code.
+ * sem_aux.adb (Get_Rep_Pragma,
+ Subprogram_Body_Entity, Subprogram_Spec): declare variables that
+ do not change as constants and initialize them in the declaration.
+ (Get_Rep_Pragma, Subprogram_Body_Entity, Subprogram_Spec): declare
+ variables that do not change as constants and initialize them
+ in the declaration.
+
+2016-04-19 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_res.adb (Resolve_Entry_Call): If the entry has
+ preconditions it is rewritten by means of a wrapper that
+ incorporates the original call. Before rewriting generate a
+ reference to the entry being called to prevent spurious warnings
+ and provide correct cross-reference information.
+
+2016-04-19 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_disp.adb (Check_Dispatching_Context): Code cleanup. Add
+ local constant Scop. Ignore any internally generated loops when
+ performing the check concerning an abstract subprogram call
+ without a controlling argument.
+ * sem_util.ads, sem_util.adb (Current_Scope_No_Loops): New routine.
+
+2016-04-19 Bob Duff <duff@adacore.com>
+
+ * sem_elab.adb (Check_A_Call): There are cases where we have No
+ (Ent) after the Alias loop, even when there was no previous error,
+ so we can't assert that there was an error.
+
+2016-04-19 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_attr.adb (Analyze_Access_Attribute, OK_Self_Reference):
+ Reject use of type name as a prefix to 'access within an aggregate
+ in a context that is not the declarative region of a type.
+
+2016-04-19 Vincent Celier <celier@adacore.com>
+
+ * gnatcmd.adb: Make "gnat ls -P" invoke gprls Make "gnat bind
+ -P" invoke "gprbuild -b" Make "gnat link -P" invoke "gprbuild
+ -l" Fail if the invocation is "gnat find -P" or "gnat xref -P"
+ Remove anything related to project files
+ * g-mbdira.adb: minor whitespace cleanup
+ * g-spipat.adb: minor removal of extra spaces after closing paren
+
+2016-04-19 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch6.adb (Expand_Actuals): If post-statements are present
+ and the enclosing context is a function call or indexing, build
+ an Expression_With_Actions for the call.
+
+2016-04-19 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * lib-writ.adb (Write_With_Lines): Code cleanup. Do not generate
+ a with line for an ignored Ghost unit.
+ * sem_ch7.adb (Analyze_Package_Declaration): Add local constant
+ Par. A child package is Ghost when its parent is Ghost.
+ * sem_prag.adb (Analyze_Pragma): Pragma Ghost can now apply to
+ a subprogram declaration that acts as a compilation unit.
+
+2016-04-18 Michael Matz <matz@suse.de>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity): Use SET_TYPE_ALIGN.
+ (gnat_to_gnu_field): Ditto.
+ (components_to_record): Ditto.
+ (create_variant_part_from): Ditto.
+ (copy_and_substitute_in_size): Ditto.
+ (substitute_in_type): Ditto.
+ * gcc-interface/utils.c (make_aligning_type): Use SET_TYPE_ALIGN.
+ (make_packable_type): Ditto.
+ (maybe_pad_type): Ditto.
+ (finish_fat_pointer_type): Ditto.
+ (finish_record_type): Ditto and use SET_DECL_ALIGN.
+ (rest_of_record_type_compilation): Use SET_TYPE_ALIGN.
+ (create_field_decl): Use SET_DECL_ALIGN.
+
+2016-04-18 Arnaud Charlet <charlet@adacore.com>
+
+ * einfo.adb (Overridden_Operation): assert that
+ function is called for valid arguments.
+ * sem_aggr.adb, sem_ch3.adb, sem_ch5.adb, sem_type.adb,
+ s-osinte-vxworks.ads, a-ngcefu.adb, sem_ch10.adb, einfo.ads,
+ sem_prag.adb, sem_ch12.adb, sem.adb, i-cobol.ads, freeze.adb,
+ sem_util.adb, a-chtgop.ads, s-rannum.adb, exp_ch6.adb, s-bignum.adb,
+ s-osinte-freebsd.ads, par-ch5.adb, a-chtgbo.ads, a-cofove.adb:
+ No space after closing parenthesis except where required for
+ layout.
+ * sem_res.adb: Minor reformatting.
+
+2016-04-18 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Case_Expression): Convert into a case
+ statement when relevant.
+
+2016-04-18 Bob Duff <duff@adacore.com>
+
+ * a-cuprqu.adb (Enqueue): Properly handle the
+ case where the new element has a unique priority.
+
+2016-04-18 Tristan Gingold <gingold@adacore.com>
+
+ * adaint.h: Define stat structures and functions for iOS
+ simulator.
+
+2016-04-18 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_res.adb (Resolve_Entry_Call): reset
+ Is_Overloaded flag after resolving calls to overloaded protected
+ operations.
+ * exp_spark.adb (Expand_SPARK): call
+ Qualify_Entity_Names for tasking nodes, i.e. protected types,
+ task types and entries.
+ * exp_ch4.adb (Expand_N_If_Expression): Refine previous change
+ in case of an unconstrained type.
+
+2016-04-18 Yannick Moy <moy@adacore.com>
+
+ * sem_eval.adb, sem_eval.ads (Check_Non_Static_Context): Add
+ comment to document usage of subprogram in GNATprove.
+
+2016-04-18 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_prag.adb (Analyze_Pragma, case Test_Case): Improve error
+ message for wrong placement of aspect Test_Case.
+
+2016-04-18 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * einfo.ads: Update the documentation of attribute Renamed_Object.
+ * exp_spark.adb (Expand_Potential_Renaming): Reimplemented.
+
+2016-04-18 Gary Dismukes <dismukes@adacore.com>
+
+ * exp_ch4.adb (Optimize_Length_Comparison): Return immediately
+ in the case of AAMP (same as for use of the -gnatd.P switch) to
+ suppress this optimization, which avoids creating a dependence
+ on the 64-bit arithmetic package.
+
+2016-04-18 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch4.adb: Update comment.
+
+2016-04-18 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch6.adb (Expand_Call): Make sure instantiations are
+ registered only once as pending here.
+
+2016-04-18 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch4.adb, gnat1drv.adb, opt.ads, sem_res.adb
+ (Minimize_Expression_With_Actions): New flag.
+ (Adjust_Global_Switches): Set Minimize_Expression_With_Actions
+ when generating C.
+ (Resolve_Short_Circuit): Redo previous change
+ using Minimize_Expression_With_Actions.
+ (Expand_N_If_Expression,
+ Expand_Short_Circuit_Operator): Restore old code to avoid
+ Expression_With_Actions when Minimize_Expression_With_Actions
+ is set.
+
+2016-04-18 Vincent Celier <celier@adacore.com>
+
+ * s-os_lib.adb (Non_Blocking_Spawn, version with Stdout_File and
+ Stderr_File): Close local file descriptors when no longer needed.
+
+2016-04-18 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch5.adb (Analyze_Iterator_Specification): Remove SPARK
+ mode check that the type of the cursor in an iteration over
+ a formal container is not volatile. The proper check on the
+ element type is done elsewhere.
+
+2016-04-18 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Process_Formals): Do not set a delay freeze on
+ a subprogram that returns a class-wide type, if the subprogram
+ is a compilation unit, because otherwise gigi will treat the
+ subprogram as external, leading to link errors.
+
+2016-04-18 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_res.adb (Resolve_Short_Circuit): Do not use
+ expression-with-actions when generating C.
+
+2016-04-18 Yannick Moy <moy@adacore.com>
+
+ * sem_util.adb (Apply_Compile_Time_Constraint_Error): Do not generate
+ raise node in GNATprove mode.
+
+2016-04-18 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * s-fileio.adb: Minor reformatting.
+ * sem_prag.adb (Analyze_Input_Item): Add local
+ variable Input_OK. Do not consider mappings of generic formal
+ parameters to actuals.
+
+2016-04-18 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch5.adb (Get_Cursor_Type): If iterator type is a derived
+ type, the cursor is declared in the scope of the parent type.
+ (Analyze_Parameter_Specification): A qualified expression with an
+ iterator type indicates an iteration over a container (explicit
+ or implicit).
+
+2016-04-18 Arnaud Charlet <charlet@adacore.com>
+
+ * osint-c.ads, osint-c.adb (Delete_C_File, Delete_H_File): New.
+ * gnat1drv.adb (Gnat1drv): Delete old C files before regenerating them.
+ * debug.adb: Reserve -gnatd.4 to force generation of C files.
+
+2016-04-18 Yannick Moy <moy@adacore.com>
+
+ * sem_eval.adb (Eval_Arithmetic_Op): Do not issue error on static
+ division by zero, instead possibly issue a warning.
+ * sem_res.adb (Resolve_Arithmetic_Op): Do not issue error on
+ static division by zero, instead add check flag on original
+ expression.
+ * sem_util.adb, sem_util.ads (Compile_Time_Constraint_Error):
+ Only issue error when both SPARK_Mode is On and Warn is False.
+
+2016-04-18 Yannick Moy <moy@adacore.com>
+
+ * checks.adb (Apply_Scalar_Range_Check): Force
+ warning instead of error when SPARK_Mode is On, on index out of
+ bounds, and set check flag for GNATprove.
+
+2016-04-18 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_prag.adb (Check_In_Out_States.Check_Constituent_Usage):
+ Update the comment on usage. Reimplemented.
+ (Check_Input_States.Check_Constituent_Usage): Update the comment
+ on usage. A Proof_In constituent can now refine an Input state
+ as long as there is at least one Input constituent present.
+
+2016-04-18 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Check_Inline_Pragma): Use the Sloc of the
+ body id as the sloc of the entity in the generated subprogram
+ declaration, to avoid spurious conformance errors when style
+ checks are enabled.
+
+2016-04-18 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch4.adb (Analyze_Selected_Component, Has_Dereference):
+ Refine check on illegal calls to entities within a task body,
+ when the entity is declared in an object of the same type. In
+ a generic context there might be no explicit dereference but if
+ the prefix includes an access type the construct is legal.
+
+2016-04-18 Arnaud Charlet <charlet@adacore.com>
+
+ * rtsfind.ads, rtsfind.adb (RE_Id, RE_Unit_Table): add
+ RE_Default_Priority.
+
+2016-04-18 Bob Duff <duff@adacore.com>
+
+ * sem_prag.adb (Check_Arg_Is_Local_Name): Don't do the check
+ if the pragma came from an aspect specification.
+
+2016-04-18 Gary Dismukes <dismukes@adacore.com>
+
+ * gnat1drv.adb, contracts.adb: Minor reformatting and wording fixes.
+
+2016-04-18 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Analyze_Subprogram_Body_Helper): To suppress
+ superfluous conformance check on an inlined body with a previous
+ spec, use the fact that the generated declaration does not come
+ from source. We must treat the entity as coming from source to
+ enable some back-end inlining when pragma appears after the body.
+
+2016-04-18 Gary Dismukes <dismukes@adacore.com>
+
+ * lib-xref-spark_specific.adb, par-ch2.adb, errout.ads,
+ exp_intr.adb: Minor reformatting and typo corrections.
+
+2016-04-18 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb: Code cleanup.
+
+2016-04-18 Thomas Quinot <quinot@adacore.com>
+
+ * sem_ch13.adb: Minor reformatting and error message tweaking
+ (remove extraneous spaces).
+
+2016-04-18 Johannes Kanig <kanig@adacore.com>
+
+ * gnat1drv.adb (Gnat1drv): Force loading of System unit for SPARK.
+
+2016-04-18 Bob Duff <duff@adacore.com>
+
+ * s-fileio.adb (Fopen_Mode): If Mode = Out_File, and the file
+ exists, and it's a fifo, we use "w" as the open string instead of
+ "r+". This is necessary to make a write to the fifo block until
+ a reader is ready.
+
+2016-04-18 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_attr.adb (Denote_Same_Function): Account
+ for a special case where a primitive of a tagged type inherits
+ a class-wide postcondition from a parent type.
+
+2016-04-18 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * par-ch2.adb (P_Expression_Or_Reserved_Word): New routine.
+ (P_Pragma): Signal Scan_Pragma_Argument_Association when the use
+ of reserved words is OK.
+ (Scan_Pragma_Argument_Association):
+ Add new formal Reserved_Words_OK and update the comment on
+ usage. Code cleanup. Parse an expression or a reserved word in
+ identifier form for pragmas Restriction_Warnings and Restrictions
+ No_Use_Of_Attribute.
+ * restrict.adb (Check_Restriction_No_Use_Of_Attribute):
+ Reimplemented. (Check_Restriction_No_Use_Of_Pragma): Code cleanup.
+ (Set_Restriction_No_Specification_Of_Aspect): Properly set the warning
+ flag for an aspect.
+ (Set_Restriction_No_Use_Of_Attribute): Properly set the warning
+ flag for an attribute. (Set_Restriction_No_Use_Of_Entity):
+ Update the parameter profile.
+ (Set_Restriction_No_Use_Of_Pragma): Properly set the warning flag for
+ a pragma.
+ * restrict.ads (Check_Restriction_No_Use_Of_Attribute): Update
+ the comment on usage.
+ (Set_Restriction_No_Use_Of_Entity): Update the parameter profile.
+ * sem_attr.adb (Analyze_Attribute): Check restriction
+ No_Use_Of_Attribute.
+ * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Check
+ restriction No_Use_Of_Attribute before any rewritings have
+ taken place.
+ * sem_prag.adb (Analyze_Pragma): Check restriction
+ No_Use_Of_Pragma before any rewritings have taken place.
+
+2016-04-18 Bob Duff <duff@adacore.com>
+
+ * sem_ch6.adb (Is_Inline_Pragma): The pragma
+ argument can be a selected component, which has no Chars field,
+ so we need to deal with that case (use the Selector_Name).
+ (Check_Inline_Pragma): We need to test Is_List_Member before
+ calling In_Same_List, because in case of a library unit, they're
+ not in lists, so In_Same_List fails an assertion.
+
+2016-04-18 Bob Duff <duff@adacore.com>
+
+ * namet.ads, namet.adb: Add an Append that appends a
+ Bounded_String onto a Bounded_String. Probably a little more
+ efficient than "Append(X, +Y);". Also minor cleanup.
+ (Append_Decoded, Append_Decoded_With_Brackets, Append_Unqualified,
+ Append_Unqualified_Decoded): Make sure these work with non-empty
+ buffers.
+ * casing.ads, casing.adb (Set_Casing): Pass a Bounded_String
+ parameter, defaulting to Global_Name_Buffer.
+ * errout.ads, errout.adb (Adjust_Name_Case): Pass a
+ Bounded_String parameter, no default.
+ * exp_ch11.adb (Expand_N_Raise_Statement): Use local
+ Bounded_String instead of Global_Name_Buffer.
+ * exp_intr.ads, exp_intr.adb (Write_Entity_Name): Rename it
+ to Append_Entity_Name, and pass a Bounded_String parameter,
+ instead of using globals.
+ (Add_Source_Info): Pass a Bounded_String parameter, instead of
+ using globals.
+ (Expand_Source_Info): Use local instead of globals.
+ * stringt.ads, stringt.adb (Append): Add an Append procedure
+ for appending a String_Id onto a Bounded_String.
+ (String_To_Name_Buffer, Add_String_To_Name_Buffer): Rewrite in
+ terms of Append.
+ * sem_prag.adb (Set_Error_Msg_To_Profile_Name): Adjust for new
+ Adjust_Name_Case parameter.
+ * erroutc.adb, uname.adb: Don't pass D => Mixed_Case to
+ Set_Casing; that's the default.
+ * lib-xref-spark_specific.adb (Add_SPARK_Scope): Pretend that calls to
+ protected subprograms are entry calls; otherwise it is not possible to
+ distinguish them from regular subprogram calls.
+
+2016-04-18 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_ch13.adb (Has_Good_Profile): Improvement
+ of error message. Now indicates subtype_mark of formal parameter
+ rather than the formal's name, plus minor rewording.
+
+2016-04-18 Pascal Obry <obry@adacore.com>
+
+ * adaint.c, adaint.h, s-os_lib.ads: Add new routine Current_Process_Id.
+
+2016-04-18 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * stringt.adb, exp_ch6.adb, sem_ch13.adb: Minor reformatting.
+
+2016-04-18 Gary Dismukes <dismukes@adacore.com>
+
+ * par-ch4.adb, sem_prag.adb: Minor reformatting.
+
+2016-04-18 Bob Duff <duff@adacore.com>
+
+ * sinput.ads, sinput.adb (Build_Location_String): Take a
+ parameter instead of using a global variable. The function
+ version no longer destroys the Name_Buffer.
+ * stringt.ads, stringt.adb (String_From_Name_Buffer): Take a
+ parameter, which defaults to the Global_Name_Buffer, so some
+ calls can avoid the global.
+ * exp_ch11.adb, exp_intr.adb: Use new interfaces above
+ to avoid using globals. All but one call to Build_Location_String
+ avoids the global. Only one call to String_From_Name_Buffer
+ avoids it.
+
+2016-04-18 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * namet.adb, namet.ads, exp_unst.adb: Minor reformatting.
+
+2016-04-18 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_eval.adb (Choice_Matches): Check the expression
+ against the predicate values when the choice denotes a
+ subtype with a static predicate.
+ (Eval_Membership_Op): Code cleanup. Remove the suspicious guard which
+ tests for predicates.
+ (Is_OK_Static_Subtype): A subtype with a dynamic predicate
+ is not static. (Is_Static_Subtype): A subtype with a dynamic
+ predicate is not static.
+ * sem_eval.ads (Is_OK_Static_Subtype): Update the comment on usage.
+ (Is_Static_Subtype): Update the comment on usage.
+
+2016-04-18 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_prag.adb (Analyze_Input_Item): Allow
+ generic formals to appear as initialization items.
+
+2016-04-18 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch13.adb (Analyze_Stream_TSS_Definition,
+ Has_Good_Profile): Additional error message to indicate that
+ the second parameter of the subprogram must be a first subtype.
+
+2016-04-18 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Analyze_Subprogram_Body_Helper, Is_Inline_Pragma):
+ Use the pragma lookahead that determines whether a subprogram
+ is to be inlined, when some level of backend optimization is
+ required.
+ * sem_ch12.ads, sem_ch12.adb (Add_Pending_Instantiation): Factorize
+ code used to create an instance body when needed for inlining.
+ * exp_ch6.adb (Expand_Call): When a call is to be inlined, and the
+ call appears within an instantiation that is not a compilation
+ unit, add a pending instantiation for the enclosing instance,
+ so the backend can inline in turn the calls contained in the
+ inlined body.
+
+2016-04-18 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_prag.adb (Build_Pragma_Check_Equivalent): The mapping
+ that relates operations of the parent type to the operations of
+ the derived type has three distinct sources:
+ a) explicit operations of the derived type carry an
+ Overridden_Operation that designates the operation in the
+ ancestor.
+ b) Implicit operations that are inherited by the derived type
+ carry an alias that may be an explicit subprogram (in which case
+ it may have an Overridden_ Operation indicator) or may also be
+ inherited and carry its own alias.
+ c) If the parent type is an interface, the operation of the
+ derived type does not override, but the interface operation
+ indicates the operation that implements it.
+ * sem_prag.adb: Minor reformatting.
+ * sem_prag.adb (Check_External_Property): Update
+ the comment on usage. Reimplement.
+
+2016-04-18 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch5.adb (Expand_Assignment_Statement): In restricted
+ profiles such as ZFP, ceiling priority is not available.
+
+2016-04-18 Bob Duff <duff@adacore.com>
+
+ * namet-sp.ads: Minor typo fix, ironically in 'Spelling_Checker'.
+
+2016-04-18 Bob Duff <duff@adacore.com>
+
+ * sem_elab.adb (Output_Calls): Use
+ Get_Name_String, to clearly indicate that the global Name_Buffer
+ is being used. The previous code used Is_Internal_Name, which
+ returns a Boolean, but also has a side effect of setting the
+ Name_Buffer. Then it called the other Is_Internal_Name, which uses
+ the Name_Buffer for its input. And then it called Error_Msg_N,
+ again using the Name_Buffer. We haven't eliminated the global
+ usage here, but we've made it a bit clearer.
+ This also allows us to have a side-effect-free version of
+ Is_Internal_Name.
+ * namet.ads, namet.adb: Provide a type Bounded_String, along with
+ routines that can be used without using global variables. Provide
+ Global_Name_Buffer so existing code can continue to use the
+ global. Mark the routines that use globals as obsolete. New code
+ shouldn't call the obsolete ones, and we should clean up existing
+ code from time to time.
+ Name_Find_Str is renamed as Name_Find.
+ * namet.h: Changed as necessary to interface to the new version
+ of Namet.
+ * bindgen.adb, exp_unst.adb: Name_Find_Str is renamed as
+ Name_Find.
+
+2016-04-18 Yannick Moy <moy@adacore.com>
+
+ * sem_util.adb, sem_util.ads (Has_Full_Default_Initialization): used
+ outside of GNATprove, hence it should not be removed.
+
+2016-04-18 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_prag.adb (Analyze_Refinement_Clause):
+ The refinement of an external abstract state can now mention
+ non-external constituents.
+ (Check_External_Property): Update all SPARK RM references.
+
+2016-04-18 Bob Duff <duff@adacore.com>
+
+ * exp_intr.adb: Remove some duplicated code.
+
+2016-04-18 Yannick Moy <moy@adacore.com>
+
+ * a-nudira.adb, a-nudira.ads, a-nuflra.adb, a-nuflra.ads: Mark
+ package spec and body out of SPARK.
+
+2016-04-18 Johannes Kanig <kanig@adacore.com>
+
+ * spark_xrefs.ads: Minor comment update.
+
+2016-04-18 Johannes Kanig <kanig@adacore.com>
+
+ * gnat1drv.adb (Gnat1drv): Force loading of System
+ unit for SPARK.
+
+2016-04-18 Bob Duff <duff@adacore.com>
+
+ * a-cuprqu.adb: Correction to previous change. If a new node
+ is inserted at the front of the queue (because it is higher
+ priority than the previous front node), we need to update
+ Header.Next_Unequal -- not just in the case where the queue was
+ previously empty.
+
+2016-04-18 Bob Duff <duff@adacore.com>
+
+ * a-cuprqu.ads: Change the representation of List_Type from a
+ singly-linked list to a doubly-linked list. In addition, add a
+ pointer Next_Unequal, which points past a possibly-long chain
+ of equal-priority items. This increases efficiency, especially
+ in the case of many equal-priority items.
+ * a-cuprqu.adb (Dequeue, Enqueue): Rewrite algorithms to take
+ advantage of new data structure.
+ (Finalize): Rewrite in terms of Dequeue, for simplicity.
+
+2016-04-18 Yannick Moy <moy@adacore.com>
+
+ * contracts.adb (Analyze_Object_Contract,
+ Analyze_Protected_Contract): Remove tests performed in GNATprove.
+ * sem_util.adb, sem_util.ads (Has_Full_Default_Initialization):
+ Remove query for tests performed in GNATprove.
+
+2016-04-18 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_aggr.adb (Resolve_Record_Aggregate): If
+ Warn_On_Redundant_Constructs is enabled, report a redundant box
+ association that does not cover any components, as it done for
+ redundant others associations in case statements.
+
+2016-04-18 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_prag.adb (Collect_Inherited_Class_Wide_Conditions):
+ Analyze the generated Check pragma for an inherited condition so
+ that it does not freeze the dispatching type of the primitive
+ operation, because it is pre-analyzed at the point of the
+ subprogram declaration (and not in the subprogram body, as is
+ done during regular expansion).
+
+2016-04-18 Vincent Celier <celier@adacore.com>
+
+ * ali.ads: Increase the range of all _Id types to 100 millions.
+
+2016-04-18 Gary Dismukes <dismukes@adacore.com>
+
+ * sem_warn.adb (Check_References): Change warning to suggest
+ using pragma Export rather than saying "volatile has no effect".
+
+2016-04-18 Bob Duff <duff@adacore.com>
+
+ * g-souinf.ads (Compilation_ISO_Date): New function to return
+ the current date in ISO form.
+ * exp_intr.adb (Expand_Source_Info, Add_Source_Info): Expand
+ a call to Compilation_ISO_Date into a string literal containing
+ the current date in ISO form.
+ * exp_intr.ads (Add_Source_Info): Improve documentation.
+ * sem_intr.adb (Check_Intrinsic_Subprogram): Recognize
+ Compilation_ISO_Date.
+ * snames.ads-tmpl (Name_Compilation_ISO_Date): New Name_Id.
+
+2016-04-18 Eric Botcazou <ebotcazou@adacore.com>
+
+ * layout.adb (Set_Elem_Alignment): Extend setting of alignment
+ to subtypes that are not first subtypes.
+
+2016-04-18 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_prag.ads (Collect_Inherited_Class_Wide_Conditions):
+ Simplify interface.
+ * sem_prag.adb (Collect_Inherited_Class_Wide_Conditions): Insert
+ generated pragmas after subprogram declaration, rather than in
+ the corresponding subprogram body.
+ * sem_ch6.adb (New_Overloaded_Entity): In GNATProve
+ mode, if the operation is overridding, call
+ Collect_Inherited_Class_Wide_Conditions to generate the
+ corresponding pragmas immediately after the corresponding
+ subprogram declaration.
+
+2016-04-18 Arnaud Charlet <charlet@adacore.com>
+
+ * spark_xrefs.ads (Xref_Index, Scope_Index, File_Index): restrict
+ type to natural numbers.
+ (Stype): document code characters for concurrent entities.
+
+2016-04-18 Olivier Hainque <hainque@adacore.com>
+
+ * targparm.ads: Update the Frontend_Exceptions default internal
+ value.
+ (Frontend_Exceptions_On_Target): Change default value to True.
+
+2016-04-18 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch4.adb (Analyze_Selected_Component): Refine error
+ detection when a selected component in the body of a synchronized
+ type is a reference to an object of the same type declared
+ elsewhere. The construct is legal if the prefix of the selected
+ component includes an explicit dereference at any point.
+
+2016-04-18 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch3.adb (Analyze_Object_Declaration): Do not consider
+ internally generated expressions when trying to determine whether
+ a formal parameter of a tagged type subject to Extensions_Visible
+ False is used to initialize an object.
+ * sem_ch4.adb (Analyze_Type_Conversion): Do not consider
+ internally generated expressions when trying to determine whether
+ a formal parameter of a tagged type subject to Extensions_Visible
+ False is used in a type conversion.
+
+2016-04-18 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_res.adb (Is_Protected_Operation_Call):
+ Add guards to account for a non-decorated selected component.
+
+2016-04-18 Yannick Moy <moy@adacore.com>
+
+ * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Improve
+ implementation of Body_Has_SPARK_Mode_On.
+ * sem_prag.adb, sem_prag.ads (Get_SPARK_Mode_From_Annotation):
+ New function replacing previous Get_SPARK_Mode_From_Pragma, that
+ deals also with aspects.
+ (Get_SPARK_Mode_Type): Make function internal again.
+ * inline.adb, sem_ch7.adb, sem_util.adb: Use new
+ Get_SPARK_Mode_From_Annotation.
+
+2016-04-18 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * contracts.adb (Analyze_Object_Contract): Update references to
+ SPARK RM.
+ * freeze.adb (Freeze_Entity): Update references to SPARK RM.
+ * ghost.adb Add with and use clauses for Sem_Disp.
+ (Check_Ghost_Derivation): Removed.
+ (Check_Ghost_Overriding):
+ Reimplemented. (Check_Ghost_Policy): Update references to SPARK RM.
+ (Check_Ghost_Primitive): New routine.
+ (Check_Ghost_Refinement): New routine. (Is_OK_Ghost_Context):
+ Update references to SPARK RM. (Is_OK_Pragma): Update references
+ to SPARK RM. Predicates are now a valid context for references
+ to Ghost entities.
+ * ghost.ads (Check_Ghost_Derivation): Removed.
+ (Check_Ghost_Overriding): Update the comment on usage.
+ (Check_Ghost_Primitive): New routine.
+ (Check_Ghost_Refinement): New routine.
+ (Remove_Ignored_Ghost_Code): Update references to SPARK RM.
+ * sem_ch3.adb (Process_Full_View): Remove the now obsolete check
+ related to Ghost derivations
+ * sem_ch6.adb (Check_Conformance): Remove now obsolete check
+ related to the convention-like behavior of pragma Ghost.
+ (Check_For_Primitive_Subprogram): Verify that the Ghost policy
+ of a tagged type and its primitive agree.
+ * sem_prag.adb (Analyze_Pragma): Update references to SPARK
+ RM. Move the verification of pragma Assertion_Policy Ghost
+ to the proper place. Remove the now obsolete check related
+ to Ghost derivations.
+ (Collect_Constituent): Add a call to Check_Ghost_Refinement.
+ * sem_res.adb (Resolve_Actuals): Update references to SPARK RM.
+
+2016-04-18 Eric Botcazou <ebotcazou@adacore.com>
+
+ * layout.adb: Fix more minor typos in comments.
+
+2016-04-18 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * a-calend.ads, sem_prag.adb, sem_ch6.adb: Minor reformatting.
+
+2016-04-18 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Analyze_Subprogram_Body_Helper): In GNATprove
+ mode, collect inherited class-wide conditions to generate the
+ corresponding pragmas.
+ * sem_prag.ads (Build_Pragma_Check_Equivalent): Moved from contracts
+ * contracts.adb (Collect_Inherited_Class_Wide_Conditions): New
+ procedure for overriding subprograms, used to generate the pragmas
+ corresponding to an inherited class- wide pre- or postcondition.
+ * sem_prag.adb (Build_Pragma_Check_Equivalent): moved here
+ from contracts.adb (Replace_Condition_Entities): Subsidiary
+ Build_Pragma_Check_Equivalent, to implement the proper semantics
+ of inherited class-wide conditions, as given in AI12-0113.
+ (Process_Class_Wide_Condition): Removed.
+ (Collect_Inherited_Class_Wide_Conditions): Iterate over pragmas
+ in contract of subprogram, to collect inherited class-wide
+ conditions.
+ (Build_Pragma_Check_Equivalent): Moved to sem_prag.adb
+
+2016-04-18 Yannick Moy <moy@adacore.com>
+
+ * a-calend.adb (Ada.Calendar): Mark package body as SPARK_Mode Off.
+ * a-calend.ads (Ada.Calendar): Mark package spec as
+ SPARK_Mode and add synchronous external abstract state Clock_Time.
+
+2016-04-18 Yannick Moy <moy@adacore.com>
+
+ * sem_res.adb (Resolve_Call): Prevent inlining of
+ calls inside expression functions. Factor previous code issuing
+ errors to call Cannot_Inline instead, which does appropriate
+ processing of message for GNATprove.
+
+2016-04-18 Arnaud Charlet <charlet@adacore.com>
+
+ * einfo.ads, sem_ch3.adb, sem_ch8.adb, osint-l.adb, rtsfind.adb,
+ osint-b.adb: Cleanups.
+
+2016-04-18 Yannick Moy <moy@adacore.com>
+
+ * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Only create
+ body to inline in GNATprove mode when SPARK_Mode On applies to
+ subprogram body.
+ * sem_prag.adb, sem_prag.ads (Get_SPARK_Mode_Type): Make function
+ public.
+
+2016-04-18 Eric Botcazou <ebotcazou@adacore.com>
+
+ * layout.adb: Fix minor typo in comment.
+ * inline.adb: Fix minor pasto.
+ * sem_ch12.ads: Fix minor typos in comments.
+
+2016-04-18 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_disp.adb (Check_Dispatching_Call): Major rewriting to
+ handle some complex cases of tag indeterminate calls that are
+ actuals in other dispatching calls that are themselves tag
+ indeterminate.
+ (Check_Dispatching_Context): Add parameter to support recursive
+ check for an enclosing construct that may provide a tag for a
+ tag-indeterminate call.
+
+2016-04-18 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_prag.adb (Analyze_Depends_In_Decl_Part):
+ Add global variables Task_Input_Seen and Task_Output_Seen.
+ (Analyze_Global_Item): Detect an illegal use of the current
+ instance of a single protected/task type in a global annotation.
+ (Analyze_Input_Output): Inputs and output related to the current
+ instance of a task unit are now tracked.
+ (Check_Usage): Require
+ the presence of the current instance of a task unit only when
+ one input/output is available. (Current_Task_Instance_Seen):
+ New routine.
+ (Is_CCT_Instance): New parameter profile. Update
+ the comment on usage. The routine now properly recognizes several
+ cases related to single protected/task types.
+
+2016-04-18 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * freeze.adb (Freeze_Entity): Use New_Freeze_Node
+ to create a brand new freeze node. This handles a case where an
+ ignored Ghost context is freezing something which is not ignored
+ Ghost and whose freeze node should not be removed from the tree.
+ (New_Freeze_Node): New routine.
+
+2016-04-18 Jerome Lambourg <lambourg@adacore.com>
+
+ * sigtramp.h (__gnat_set_is_vxsim) New function to
+ tell sigtramp-vxworks to handle vxsim signal contexts. *
+ sigtramp-vxworks.c (__gnat_sigtramp) Take into account the
+ differences in the sigcontext structure between the expected
+ regular x86 or x86_64 ones and the ones received in case of
+ exexution on the vxworks simulator.
+ * init.c: also compute is_vxsim in case of x86_64-vx7 target. Provide
+ this information to sigtramp-vxworks.c. Remove the old mechanism for
+ vxsim.
+ * init-vxsim.c, sigtramp-vxworks-vxsim.c: remove, now obsolete.
+
+2016-04-18 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch3.adb (Inline_Init_Proc): New function returning
+ whether the initialization procedure of a type should be
+ inlined. Return again True for controlled type themselves.
+ (Build_Array_Init_Proc): Call it to set Set_Is_Inlined on Init_Proc.
+ (Build_Record_Init_Proc): Likewise.
+
+2016-04-18 Arnaud Charlet <charlet@adacore.com>
+
+ * gnatvsn.ads (Library_Version): Bump to 7.
+
+2016-04-18 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Analyze_Expression_Function): Set Inlined flag
+ on the entity of a subprogram declaration that is completed by
+ an expression function.
+
+2016-04-18 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_util.adb (Is_Current_Instance): A entity given by a subtype
+ declaration can appear in an aspect specification for a dynamic
+ predicate, and a pragma for aspect Predicate_Failure.
+ * exp_util.adb (Replace_Subtype_References): Replace current
+ occurrences of the subtype to which a dynamic predicate applies,
+ byt the expression that triggers a predicate check. Needed to
+ implement new aspect Predicate_Failure.
+
+2016-04-18 Arnaud Charlet <charlet@adacore.com>
+
+ * a-intsig.ads, a-intsig.adb: Removed, no longer used.
+ * Makefile.rtl: update accordingly.
+
+2016-04-18 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_type.adb (Disambiguate): Call Covers only when necessary
+ for standard operators.
+
+2016-04-18 Eric Botcazou <ebotcazou@adacore.com>
+
+ * atree.ads (Num_Extension_Nodes): Add couple of figures
+ to comment.
+ * atree.adb: Add GNAT.Heap_Sort_G dependency.
+ (Print_Statistics): New exported procedure to print statistics.
+
+2016-04-18 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch3.adb (Build_Record_Init_Proc): Do not mark the procedure
+ as to be inlined if the type needs finalization.
+
+2016-04-18 Jerome Lambourg <lambourg@adacore.com>
+
+ * sigtramp-vxworks-target.inc: sigtramp-vxworks: force the stack
+ alignment for x86_64.
+ * init.c: Better fix for guard page reset on x86_64-vx7.
+ Do not try to retrieve the page that actually raised
+ the signal as the probing mechanism used on x86_64 do not allow
+ such retrieval. We thus just test if the guard page is active,
+ and re-activate it if not.
+
+2016-04-18 Arnaud Charlet <charlet@adacore.com>
+
+ * a-sytaco.adb (Suspension_Object): Aspect Default_Initial_Condition
+ added.
+
+2016-04-18 Jerome Lambourg <lambourg@adacore.com>
+
+ * affinity.c: Use the proper type for task id.
+ * init.c (__gnat_inum_to_ivec): ivec is a pointer.
+
+2016-04-18 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_prag.adb (Process_Convention): Relax rule on exporting
+ Intrinsic types if Relaxed_RM_Semantics is True.
+
+2016-04-18 Vincent Celier <celier@adacore.com>
+
+ * sem_ch3.adb, lib.ads, sinfo.ads, sem_ch10.adb, einfo.adb, einfo.ads,
+ checks.ads, sem_ch12.adb, sem.adb, sem_util.adb, sem_util.ads,
+ sem_res.adb, sem_attr.adb, par.adb, exp_ch4.adb, errout.ads,
+ sem_ch4.adb, atree.adb, atree.ads, sem_warn.adb, treepr.adb,
+ exp_ch3.ads, exp_unst.adb: Change "descendent" to
+ "descendant" in comments, error messages and identifiers.
+ * gcc-interface/decl.c: Ditto.
+
+2016-04-18 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_type.adb (Operator_Matches_Spec): Call First_Formal on
+ New_S only once at the beginning of the function.
+
+2016-04-02 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (components_to_record): Restrict the previous
+ change to fields with variable size.
+
+2016-03-27 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (components_to_record): Add special case for
+ single field with representation clause at offset 0.
+
+2016-03-16 Svante Signell <svante.signell@gmail.com>
+
+ * gcc-interface/Makefile.in: Add support for x86 GNU/Hurd.
+ * s-osinte-gnu.ads: New file.
+
+2016-03-13 Eric Botcazou <ebotcazou@adacore.com>
+
+ * system-vxworks-m68k.ads (Stack_Check_Probes): Set to True.
+ (Stack_Check_Limits): Set to False.
+ * system-vxworks-mips.ads (Stack_Check_Probes): Set to True.
+ (Stack_Check_Limits): Set to False.
+ * system-vxworks-ppc.ads (Stack_Check_Probes): Set to True.
+ (Stack_Check_Limits): Set to False.
+ * system-vxworks-sparcv9.ads (Stack_Check_Probes): Set to True.
+ (Stack_Check_Limits): Set to False.
+ * system-vxworks-x86.ads (Stack_Check_Probes): Set to True.
+ (Stack_Check_Limits): Set to False.
+
+2016-03-07 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.c (statement_node_p): New predicate.
+ (gnat_to_gnu): Invoke it to detect statement nodes. In ASIS mode, do
+ not return dummy results for expressions attached to packed array
+ implementation types.
+
+2016-03-07 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Variable>: Always mark
+ the expression of a renaming manually in case #3.
+
+2016-03-02 Dominik Vogt <vogt@linux.vnet.ibm.com>
+
+ * system-linux-s390.ads: Enable Stack_Check_Probes.
+ * system-linux-s390.ads: Likewise.
+
+2016-02-29 Martin Liska <mliska@suse.cz>
+
+ * gcc-interface/utils.c (set_reverse_storage_order_on_pad_type):
+ Replace ENABLE_CHECKING macro with flag_checking.
+
+2016-02-29 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Access_Type>: Retrofit
+ handling of unconstrained array types as designated types into common
+ processing. Also handle array types as incomplete designated types.
+
+2016-02-29 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <Concurrent types>: In
+ ASIS mode, fully lay out the minimal record type.
+
+2016-02-29 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/trans.c (finalize_nrv_r): Remove obsolete code.
+ (build_return_expr): Likewise.
+ (Call_to_gnu): If this is a function call and there is no target,
+ create a temporary for the return value for all aggregate types,
+ but never create it for a return statement. Push a binding level
+ around the call in more cases. Remove obsolete code.
+
+2016-02-29 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/ada-tree.h (DECL_RETURN_VALUE_P): New macro.
+ * gcc-interface/gigi.h (gigi): Remove useless attribute.
+ (gnat_gimplify_expr): Likewise.
+ (gnat_to_gnu_external): Declare.
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Constant>: Factor out
+ code dealing with the expression of external constants into...
+ Invoke gnat_to_gnu_external instead.
+ <E_Variable>: Invoke gnat_to_gnu_external to translate renamed objects
+ when not for a definition. Deal with COMPOUND_EXPR and variables with
+ DECL_RETURN_VALUE_P set for renamings and with the case of a dangling
+ 'reference to a function call in a renaming. Remove obsolete test and
+ adjust associated comment.
+ * gcc-interface/trans.c (Call_to_gnu): Set DECL_RETURN_VALUE_P on the
+ temporaries created to hold the return value, if any.
+ (gnat_to_gnu_external): ...this. New function.
+ * gcc-interface/utils.c (create_var_decl): Detect a constant created
+ to hold 'reference to function call.
+ * gcc-interface/utils2.c (build_unary_op) <ADDR_EXPR>: Add folding
+ for COMPOUND_EXPR in the DECL_RETURN_VALUE_P case.
+
+2016-02-17 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch4.adb (Expand_N_Indexed_Component): Activate synchronization if
+ the prefix denotes an entity which Has_Atomic_Components.
+ * gcc-interface/trans.c (node_is_atomic): Return true if the prefix
+ denotes an entity which Has_Atomic_Components.
+
+2016-02-17 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/utils2.c (gnat_protect_expr): Make a SAVE_EXPR only
+ for fat pointer or scalar types.
+
+2016-02-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/gigi.h (maybe_debug_type): New inline function.
+ * gcc-interface/misc.c (gnat_get_array_descr_info): Use it.
+ Call maybe_character_value on the array bounds. Get to the base type
+ of the index type and call maybe_debug_type on it.
+ * gcc-interface/utils.c (finish_character_type): Add special treatment
+ for char_type_node.
+
+2016-02-16 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/misc.c (gnat_enum_underlying_base_type): New function.
+ (LANG_HOOKS_ENUM_UNDERLYING_BASE_TYPE): Define to above.
+
+2016-02-12 Jakub Jelinek <jakub@redhat.com>
+
+ * prj-tree.ads: Spelling fixes - behaviour -> behavior and
+ neighbour -> neighbor.
+ * prep.adb: Likewise.
+ * prj.ads: Likewise.
+ * prepcomp.adb: Likewise.
+ * g-socket.ads: Likewise.
+ * s-imgrea.adb: Likewise.
+ * a-calend.adb: Likewise.
+ * exp_disp.adb: Likewise.
+ * doc/gnat_ugn/gnat_utility_programs.rst: Likewise.
+ * g-socket.adb: Likewise.
+ * sem_ch12.adb: Likewise.
+ * terminals.c: Likewise.
+
+2016-02-08 Bernd Schmidt <bschmidt@redhat.com>
+
+ * gcc-interface/misc.c (gnat_init): Remove second argument in call to
+ build_common_tree_nodes.
+
+2016-02-08 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/utils.c (create_var_decl): Set again DECL_COMMON and
+ DECL_IGNORED_P last.
+
+2016-01-28 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/gigi.h (enum attr_type): Rename into...
+ (enum attrib_type): ...this.
+ (struct attrib): Adjust.
+ * gcc-interface/decl.c (prepend_one_attribute): Likewise.
+
+2016-01-20 Eric Botcazou <ebotcazou@adacore.com>
+
+ * exp_ch2.adb (Expand_Current_Value): Make an appropriate character
+ literal if the entity is of a character type.
+ * gcc-interface/lang.opt (fsigned-char): New option.
+ * gcc-interface/misc.c (gnat_handle_option): Accept it.
+ (gnat_init): Adjust comment.
+ * gcc-interface/gigi.h (finish_character_type): New prototype.
+ (maybe_character_type): New inline function.
+ (maybe_character_value): Likewise.
+ * gcc-interface/decl.c (gnat_to_gnu_entity) <E_Enumeration_Type>: For
+ a character of CHAR_TYPE_SIZE, make a signed type if flag_signed_char.
+ Set TYPE_ARTIFICIAL early and call finish_character_type on the type.
+ <E_Enumeration_Subtype>: For a subtype of character with RM_Size and
+ Esize equal to CHAR_TYPE_SIZE, make a signed type if flag_signed_char.
+ Copy TYPE_STRING_FLAG from type to subtype.
+ <E_Array_Type>: Deal with character index types.
+ <E_Array_Subtype>: Likewise.
+ * gcc-interface/trans.c (gigi): Replace unsigned_char_type_node with
+ char_type_node throughout.
+ (build_raise_check): Likewise.
+ (get_type_length): Deal with character types.
+ (Attribute_to_gnu) <Attr_Pos>: Likewise. Remove obsolete range check
+ code. Minor tweak.
+ <Attr_Pred>: Likewise.
+ (Loop_Statement_to_gnu): Likewise.
+ (Raise_Error_to_gnu): Likewise.
+ <N_Indexed_Component>: Deal with character index types. Remove
+ obsolete code.
+ <N_Slice>: Likewise.
+ <N_Type_Conversion>: Deal with character types. Minor tweak.
+ <N_Unchecked_Type_Conversion>: Likewise.
+ <N_In>: Likewise.
+ <N_Op_Eq>: Likewise.
+ (emit_index_check): Delete.
+ * gcc-interface/utils.c (finish_character_type): New function.
+ (gnat_signed_or_unsigned_type_for): Deal with built-in character types.
+ * gcc-interface/utils2.c (expand_sloc): Replace unsigned_char_type_node
+ with char_type_node.
+ (build_call_raise): Likewise.
+ (build_call_raise_column): Likewise.
+ (build_call_raise_range): Likewise.
+
+2016-01-18 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/gigi.h (build_call_raise_column): Adjust prototype.
+ (build_call_raise_range): Likewise.
+ (gnat_unsigned_type): Delete.
+ (gnat_signed_type): Likewise.
+ (gnat_signed_or_unsigned_type_for): New prototype.
+ (gnat_unsigned_type_for): New inline function.
+ (gnat_signed_type_for): Likewise.
+ * gcc-interface/cuintp.c (build_cst_from_int): Call build_int_cst.
+ * gcc-interface/decl.c (gnat_to_gnu_entity): Likewise.
+ (gnat_to_gnu_entity) <E_Array_Type>: Always translate the index types
+ and compute their base type from that.
+ <E_Array_Subtype>: Remove duplicate declaration.
+ * gcc-interface/misc.c (get_array_bit_stride): Call build_int_cst.
+ * gcc-interface/trans.c (get_type_length): Likewise.
+ (Attribute_to_gnu): Likewise.
+ (Loop_Statement_to_gnu): Likewise.
+ (Call_to_gnu): Likewise.
+ (gnat_to_gnu): Call build_real, build_int_cst, gnat_unsigned_type_for
+ and gnat_signed_type_for. Minor tweaks.
+ (build_binary_op_trapv): Likewise.
+ (emit_check): Likewise.
+ (convert_with_check): Likewise.
+ (Raise_Error_to_gnu): Adjust calls to the build_call_raise family of
+ functions. Minor tweaks.
+ (Case_Statement_to_gnu): Remove dead code.
+ (gnat_to_gnu): Call gnat_unsigned_type_for and gnat_signed_type_for.
+ (init_code_table): Minor reordering.
+ * gcc-interface/utils.c (gnat_unsigned_type): Delete.
+ (gnat_signed_type): Likewise.
+ (gnat_signed_or_unsigned_type_for): New function.
+ (unchecked_convert): Use directly the size in the test for precision
+ vs size adjustments.
+ (install_builtin_elementary_types): Call gnat_signed_type_for.
+ * gcc-interface/utils2.c (nonbinary_modular_operation): Call
+ build_int_cst.
+ (build_goto_raise): New function taken from...
+ (build_call_raise): ...here. Call it.
+ (build_call_raise_column): Add KIND parameter and call it.
+ (build_call_raise_range): Likewise.
+
+2016-01-18 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gcc-interface/ada-tree.h (TYPE_IMPLEMENTS_PACKED_ARRAY_P): Rename to
+ (TYPE_IMPL_PACKED_ARRAY_P): ...this.
+ (TYPE_CAN_HAVE_DEBUG_TYPE_P): Do not test TYPE_DEBUG_TYPE.
+ * gcc-interface/decl.c (gnat_to_gnu_entity): Simplify NULL_TREE tests
+ and tweak gnat_encodings tests throughout.
+ (initial_value_needs_conversion): Likewise.
+ (intrin_arglists_compatible_p): Likewise.
+ * gcc-interface/misc.c (gnat_print_type): Likewise.
+ (gnat_get_debug_type): Likewise.
+ (gnat_get_fixed_point_type_info): Likewise.
+ (gnat_get_array_descr_info): Likewise.
+ (get_array_bit_stride): Likewise.
+ (gnat_get_type_bias): Fix formatting.
+ (enumerate_modes): Likewise.
+ * gcc-interface/trans.c (gnat_to_gnu): Likewise.
+ (add_decl_expr): Simplify NULL_TREE test.
+ (end_stmt_group): Likewise.
+ (build_binary_op_trapv): Fix formatting.
+ (get_exception_label): Use switch statement.
+ (init_code_table): Move around.
+ * gcc-interface/utils.c (global_bindings_p): Simplify NULL_TREE test.
+ (gnat_poplevel): Likewise.
+ (gnat_set_type_context): Likewise.
+ (defer_or_set_type_context): Fix formatting.
+ (gnat_pushdecl): Simplify NULL_TREE test.
+ (maybe_pad_type): Likewise.
+ (add_parallel_type): Likewise.
+ (create_range_type): Likewise.
+ (process_deferred_decl_context): Likewise.
+ (convert): Likewise.
+ (def_builtin_1): Likewise.
+ * gcc-interface/utils2.c (find_common_type): Likewise.
+ (build_binary_op): Likewise.
+ (gnat_rewrite_reference): Likewise.
+ (get_inner_constant_reference): Likewise.
+
+2016-01-18 Eric Botcazou <ebotcazou@adacore.com>
+
+ PR ada/69219
+ * gcc-interface/trans.c (check_inlining_for_nested_subprog): Consider
+ the parent function instead of the current function in order to issue
+ the warning or the error. Add guard for ignored functions.
+
+2016-01-17 Jakub Jelinek <jakub@redhat.com>
+
+ * adaint.c (__gnat_killprocesstree): Avoid -Wparentheses warning.
+
+2016-01-15 Jakub Jelinek <jakub@redhat.com>
+
+ * adaint.c (__gnat_locate_exec_on_path): Use const char * instead
+ of char * for path_val to avoid warnings.
+
+2016-01-06 Pierre-Marie de Rodat <derodat@adacore.com>
+
+ * gcc-interface/utils.c: Bump copyright year.
+ (rest_of_record_type_compilation): Add XVE/XVU parallel types to
+ the current lexical scope.
+
+2016-01-04 Jakub Jelinek <jakub@redhat.com>
+
+ * gnat_ugn.texi: Bump @copying's copyright year.
+ * gnat_rm.texi: Likewise.
+
+2016-01-02 Eric Botcazou <ebotcazou@adacore.com>
+
+ * gnatvsn.ads: Bump copyright year.
+
+
+Copyright (C) 2016 Free Software Foundation, Inc.
+
+Copying and distribution of this file, with or without modification,
+are permitted in any medium without royalty provided the copyright
+notice and this notice are preserved.
diff --git a/gcc/ada/Makefile.rtl b/gcc/ada/Makefile.rtl
index 6bbf0d6548..63b1a95e3a 100644
--- a/gcc/ada/Makefile.rtl
+++ b/gcc/ada/Makefile.rtl
@@ -28,7 +28,6 @@ GNATRTL_TASKING_OBJS= \
a-dispat$(objext) \
a-dynpri$(objext) \
a-interr$(objext) \
- a-intsig$(objext) \
a-intnam$(objext) \
a-reatim$(objext) \
a-retide$(objext) \
@@ -494,6 +493,7 @@ GNATRTL_NONTASKING_OBJS= \
s-bignum$(objext) \
s-bitops$(objext) \
s-boarop$(objext) \
+ s-boustr$(objext) \
s-bytswa$(objext) \
s-carsi8$(objext) \
s-carun8$(objext) \
@@ -659,7 +659,6 @@ GNATRTL_NONTASKING_OBJS= \
s-stache$(objext) \
s-stalib$(objext) \
s-stausa$(objext) \
- s-stchop$(objext) \
s-stoele$(objext) \
s-stopoo$(objext) \
s-stposu$(objext) \
diff --git a/gcc/ada/a-calend.adb b/gcc/ada/a-calend.adb
index 9fcc299670..b0fba5dd14 100644
--- a/gcc/ada/a-calend.adb
+++ b/gcc/ada/a-calend.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -35,7 +35,9 @@ with Interfaces.C;
with System.OS_Primitives;
-package body Ada.Calendar is
+package body Ada.Calendar with
+ SPARK_Mode => Off
+is
--------------------------
-- Implementation Notes --
diff --git a/gcc/ada/a-calend.ads b/gcc/ada/a-calend.ads
index 55efe115f5..39e9c33c13 100644
--- a/gcc/ada/a-calend.ads
+++ b/gcc/ada/a-calend.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -33,7 +33,13 @@
-- --
------------------------------------------------------------------------------
-package Ada.Calendar is
+package Ada.Calendar with
+ SPARK_Mode,
+ Abstract_State => (Clock_Time with Synchronous,
+ External => (Async_Readers,
+ Async_Writers)),
+ Initializes => Clock_Time
+is
type Time is private;
@@ -49,7 +55,9 @@ package Ada.Calendar is
subtype Day_Duration is Duration range 0.0 .. 86_400.0;
- function Clock return Time;
+ function Clock return Time with
+ Volatile_Function,
+ Global => Clock_Time;
-- The returned time value is the number of nanoseconds since the start
-- of Ada time (1901-01-01 00:00:00.0 UTC). If leap seconds are enabled,
-- the result will contain all elapsed leap seconds since the start of
@@ -108,6 +116,11 @@ package Ada.Calendar is
Time_Error : exception;
private
+ -- Mark the private part as SPARK_Mode Off to avoid accounting for variable
+ -- Invalid_Time_Zone_Offset in abstract state.
+
+ pragma SPARK_Mode (Off);
+
pragma Inline (Clock);
pragma Inline (Year);
diff --git a/gcc/ada/a-cbhama.adb b/gcc/ada/a-cbhama.adb
index 86c57e737a..02c190198e 100644
--- a/gcc/ada/a-cbhama.adb
+++ b/gcc/ada/a-cbhama.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -35,9 +35,9 @@ pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys);
with Ada.Containers.Helpers; use Ada.Containers.Helpers;
-with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers;
+with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers;
-with System; use type System.Address;
+with System; use type System.Address;
package body Ada.Containers.Bounded_Hashed_Maps is
diff --git a/gcc/ada/a-cfdlli.adb b/gcc/ada/a-cfdlli.adb
index 6fed4cce00..a7322a1fff 100644
--- a/gcc/ada/a-cfdlli.adb
+++ b/gcc/ada/a-cfdlli.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2010-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -25,7 +25,7 @@
-- <http://www.gnu.org/licenses/>. --
------------------------------------------------------------------------------
-with System; use type System.Address;
+with System; use type System.Address;
package body Ada.Containers.Formal_Doubly_Linked_Lists with
SPARK_Mode => Off
diff --git a/gcc/ada/a-cfdlli.ads b/gcc/ada/a-cfdlli.ads
index 36e1869ebd..8e17479fc3 100644
--- a/gcc/ada/a-cfdlli.ads
+++ b/gcc/ada/a-cfdlli.ads
@@ -353,12 +353,12 @@ private
type Node_Array is array (Count_Type range <>) of Node_Type;
function "=" (L, R : Node_Array) return Boolean is abstract;
- type List (Capacity : Count_Type) is tagged record
- Nodes : Node_Array (1 .. Capacity) := (others => <>);
+ type List (Capacity : Count_Type) is record
Free : Count_Type'Base := -1;
Length : Count_Type := 0;
First : Count_Type := 0;
Last : Count_Type := 0;
+ Nodes : Node_Array (1 .. Capacity) := (others => <>);
end record;
type Cursor is record
diff --git a/gcc/ada/a-chtgbo.adb b/gcc/ada/a-chtgbo.adb
index f4f7c1c237..034b592489 100644
--- a/gcc/ada/a-chtgbo.adb
+++ b/gcc/ada/a-chtgbo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,7 +27,7 @@
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
-with System; use type System.Address;
+with System; use type System.Address;
package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is
diff --git a/gcc/ada/a-chtgbo.ads b/gcc/ada/a-chtgbo.ads
index 892bdaaf1d..184cefc4d8 100644
--- a/gcc/ada/a-chtgbo.ads
+++ b/gcc/ada/a-chtgbo.ads
@@ -81,7 +81,7 @@ package Ada.Containers.Hash_Tables.Generic_Bounded_Operations is
procedure Clear (HT : in out Hash_Table_Type'Class);
-- Deallocates each node in hash table HT. (Note that it only deallocates
- -- the nodes, not the buckets array.) Program_Error is raised if the hash
+ -- the nodes, not the buckets array.) Program_Error is raised if the hash
-- table is busy.
procedure Delete_Node_At_Index
diff --git a/gcc/ada/a-chtgop.adb b/gcc/ada/a-chtgop.adb
index 0d7f88fa3f..53b564f976 100644
--- a/gcc/ada/a-chtgop.adb
+++ b/gcc/ada/a-chtgop.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -30,7 +30,7 @@
with Ada.Containers.Prime_Numbers;
with Ada.Unchecked_Deallocation;
-with System; use type System.Address;
+with System; use type System.Address;
package body Ada.Containers.Hash_Tables.Generic_Operations is
@@ -53,6 +53,12 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is
Dst_Prev : Node_Access;
begin
+ -- If the counts are nonzero, execution is technically erroneous, but
+ -- it seems friendly to allow things like concurrent "=" on shared
+ -- constants.
+
+ Zero_Counts (HT.TC);
+
HT.Buckets := null;
HT.Length := 0;
diff --git a/gcc/ada/a-chtgop.ads b/gcc/ada/a-chtgop.ads
index 4a7fbd6c74..1b865dcbd2 100644
--- a/gcc/ada/a-chtgop.ads
+++ b/gcc/ada/a-chtgop.ads
@@ -107,7 +107,7 @@ package Ada.Containers.Hash_Tables.Generic_Operations is
procedure Clear (HT : in out Hash_Table_Type);
-- Deallocates each node in hash table HT. (Note that it only deallocates
- -- the nodes, not the buckets array.) Program_Error is raised if the hash
+ -- the nodes, not the buckets array.) Program_Error is raised if the hash
-- table is busy.
procedure Move (Target, Source : in out Hash_Table_Type);
diff --git a/gcc/ada/a-cihama.adb b/gcc/ada/a-cihama.adb
index f81bfc8a7d..3c05aac5b4 100644
--- a/gcc/ada/a-cihama.adb
+++ b/gcc/ada/a-cihama.adb
@@ -274,15 +274,15 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
C : Count_Type;
begin
- if Capacity = 0 then
- C := Source.Length;
+ if Capacity < Source.Length then
+ if Checks and then Capacity /= 0 then
+ raise Capacity_Error
+ with "Requested capacity is less than Source length";
+ end if;
- elsif Capacity >= Source.Length then
+ C := Source.Length;
+ else
C := Capacity;
-
- elsif Checks then
- raise Capacity_Error
- with "Requested capacity is less than Source length";
end if;
return Target : Map do
diff --git a/gcc/ada/a-cihase.adb b/gcc/ada/a-cihase.adb
index ea7ee2211b..6d913cbdee 100644
--- a/gcc/ada/a-cihase.adb
+++ b/gcc/ada/a-cihase.adb
@@ -264,15 +264,15 @@ package body Ada.Containers.Indefinite_Hashed_Sets is
C : Count_Type;
begin
- if Capacity = 0 then
- C := Source.Length;
+ if Capacity < Source.Length then
+ if Checks and then Capacity /= 0 then
+ raise Capacity_Error
+ with "Requested capacity is less than Source length";
+ end if;
- elsif Capacity >= Source.Length then
+ C := Source.Length;
+ else
C := Capacity;
-
- elsif Checks then
- raise Capacity_Error
- with "Requested capacity is less than Source length";
end if;
return Target : Set do
diff --git a/gcc/ada/a-cofove.adb b/gcc/ada/a-cofove.adb
index ac8208593b..529a73b9e2 100644
--- a/gcc/ada/a-cofove.adb
+++ b/gcc/ada/a-cofove.adb
@@ -95,7 +95,7 @@ is
procedure Append (Container : in out Vector; New_Item : Vector) is
begin
- for X in First_Index (New_Item) .. Last_Index (New_Item) loop
+ for X in First_Index (New_Item) .. Last_Index (New_Item) loop
Append (Container, Element (New_Item, X));
end loop;
end Append;
@@ -119,7 +119,7 @@ is
raise Constraint_Error with "vector is already at its maximum length";
end if;
- -- TODO: should check whether length > max capacity (cnt_t'last) ???
+ -- TODO: should check whether length > max capacity (cnt_t'last) ???
Container.Last := Container.Last + 1;
Elems (Container) (Length (Container)) := New_Item;
diff --git a/gcc/ada/a-coinho-shared.adb b/gcc/ada/a-coinho-shared.adb
index 81732b9f55..3373dbdfd3 100644
--- a/gcc/ada/a-coinho-shared.adb
+++ b/gcc/ada/a-coinho-shared.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2013-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2013-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -39,6 +39,10 @@ package body Ada.Containers.Indefinite_Holders is
procedure Free is
new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
+ procedure Detach (Container : Holder);
+ -- Detach data from shared copy if necessary. This is necessary to prepare
+ -- container to be modified.
+
---------
-- "=" --
---------
@@ -142,21 +146,10 @@ package body Ada.Containers.Indefinite_Holders is
begin
if Container.Reference = null then
raise Constraint_Error with "container is empty";
-
- elsif Container.Busy = 0
- and then not System.Atomic_Counters.Is_One
- (Container.Reference.Counter)
- then
- -- Container is not locked and internal shared object is used by
- -- other container, create copy of both internal shared object and
- -- element.
-
- Container'Unrestricted_Access.Reference :=
- new Shared_Holder'
- (Counter => <>,
- Element => new Element_Type'(Container.Reference.Element.all));
end if;
+ Detach (Container);
+
declare
Ref : constant Constant_Reference_Type :=
(Element => Container.Reference.Element.all'Access,
@@ -197,6 +190,34 @@ package body Ada.Containers.Indefinite_Holders is
end if;
end Copy;
+ ------------
+ -- Detach --
+ ------------
+
+ procedure Detach (Container : Holder) is
+ begin
+ if Container.Busy = 0
+ and then not System.Atomic_Counters.Is_One
+ (Container.Reference.Counter)
+ then
+ -- Container is not locked and internal shared object is used by
+ -- other container, create copy of both internal shared object and
+ -- element.
+
+ declare
+ Old : constant Shared_Holder_Access := Container.Reference;
+
+ begin
+ Container'Unrestricted_Access.Reference :=
+ new Shared_Holder'
+ (Counter => <>,
+ Element =>
+ new Element_Type'(Container.Reference.Element.all));
+ Unreference (Old);
+ end;
+ end if;
+ end Detach;
+
-------------
-- Element --
-------------
@@ -281,21 +302,10 @@ package body Ada.Containers.Indefinite_Holders is
begin
if Container.Reference = null then
raise Constraint_Error with "container is empty";
-
- elsif Container.Busy = 0
- and then
- not System.Atomic_Counters.Is_One (Container.Reference.Counter)
- then
- -- Container is not locked and internal shared object is used by
- -- other container, create copy of both internal shared object and
- -- element.
-
- Container'Unrestricted_Access.Reference :=
- new Shared_Holder'
- (Counter => <>,
- Element => new Element_Type'(Container.Reference.Element.all));
end if;
+ Detach (Container);
+
B := B + 1;
begin
@@ -359,21 +369,10 @@ package body Ada.Containers.Indefinite_Holders is
begin
if Container.Reference = null then
raise Constraint_Error with "container is empty";
-
- elsif Container.Busy = 0
- and then
- not System.Atomic_Counters.Is_One (Container.Reference.Counter)
- then
- -- Container is not locked and internal shared object is used by
- -- other container, create copy of both internal shared object and
- -- element.
-
- Container.Reference :=
- new Shared_Holder'
- (Counter => <>,
- Element => new Element_Type'(Container.Reference.Element.all));
end if;
+ Detach (Container);
+
declare
Ref : constant Reference_Type :=
(Element => Container.Reference.Element.all'Access,
@@ -477,21 +476,10 @@ package body Ada.Containers.Indefinite_Holders is
begin
if Container.Reference = null then
raise Constraint_Error with "container is empty";
-
- elsif Container.Busy = 0
- and then
- not System.Atomic_Counters.Is_One (Container.Reference.Counter)
- then
- -- Container is not locked and internal shared object is used by
- -- other container, create copy of both internal shared object and
- -- element.
-
- Container'Unrestricted_Access.Reference :=
- new Shared_Holder'
- (Counter => <>,
- Element => new Element_Type'(Container.Reference.Element.all));
end if;
+ Detach (Container);
+
B := B + 1;
begin
diff --git a/gcc/ada/a-coinve.adb b/gcc/ada/a-coinve.adb
index ba0f693247..3c1972771f 100644
--- a/gcc/ada/a-coinve.adb
+++ b/gcc/ada/a-coinve.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -376,15 +376,15 @@ package body Ada.Containers.Indefinite_Vectors is
C : Count_Type;
begin
- if Capacity = 0 then
- C := Source.Length;
+ if Capacity < Source.Length then
+ if Checks and then Capacity /= 0 then
+ raise Capacity_Error
+ with "Requested capacity is less than Source length";
+ end if;
- elsif Capacity >= Source.Length then
+ C := Source.Length;
+ else
C := Capacity;
-
- elsif Checks then
- raise Capacity_Error with
- "Requested capacity is less than Source length";
end if;
return Target : Vector do
@@ -748,9 +748,6 @@ package body Ada.Containers.Indefinite_Vectors is
end Finalize;
procedure Finalize (Object : in out Iterator) is
- pragma Warnings (Off);
- pragma Assert (T_Check); -- not called if check suppressed
- pragma Warnings (On);
begin
Unbusy (Object.Container.TC);
end Finalize;
diff --git a/gcc/ada/a-comutr.adb b/gcc/ada/a-comutr.adb
index 68d49aa4ab..7804b0f574 100644
--- a/gcc/ada/a-comutr.adb
+++ b/gcc/ada/a-comutr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -47,7 +47,8 @@ package body Ada.Containers.Multiway_Trees is
record
Container : Tree_Access;
Subtree : Tree_Node_Access;
- end record;
+ end record
+ with Disable_Controlled => not T_Check;
overriding procedure Finalize (Object : in out Root_Iterator);
@@ -71,7 +72,8 @@ package body Ada.Containers.Multiway_Trees is
---------------------
type Child_Iterator is new Root_Iterator and
- Tree_Iterator_Interfaces.Reversible_Iterator with null record;
+ Tree_Iterator_Interfaces.Reversible_Iterator with null record
+ with Disable_Controlled => not T_Check;
overriding function First (Object : Child_Iterator) return Cursor;
diff --git a/gcc/ada/a-conhel.adb b/gcc/ada/a-conhel.adb
index f433250000..864b217367 100644
--- a/gcc/ada/a-conhel.adb
+++ b/gcc/ada/a-conhel.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2015-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -36,10 +36,6 @@ package body Ada.Containers.Helpers is
------------
procedure Adjust (Control : in out Reference_Control_Type) is
- pragma Warnings (Off);
- -- GNAT warns here if checks are turned off, but assertions on
- pragma Assert (T_Check); -- not called if check suppressed
- pragma Warnings (On);
begin
if Control.T_Counts /= null then
Lock (Control.T_Counts.all);
@@ -62,9 +58,6 @@ package body Ada.Containers.Helpers is
--------------
procedure Finalize (Control : in out Reference_Control_Type) is
- pragma Warnings (Off);
- pragma Assert (T_Check); -- not called if check suppressed
- pragma Warnings (On);
begin
if Control.T_Counts /= null then
Unlock (Control.T_Counts.all);
diff --git a/gcc/ada/a-conhel.ads b/gcc/ada/a-conhel.ads
index 74e51518fb..008ef8a869 100644
--- a/gcc/ada/a-conhel.ads
+++ b/gcc/ada/a-conhel.ads
@@ -55,8 +55,6 @@ package Ada.Containers.Helpers is
package Generic_Implementation is
-- Generic package used in the implementation of containers.
- -- ???????????????????Currently used by Vectors; not yet by all other
- -- containers.
-- This needs to be generic so that the 'Enabled attribute will return
-- the value that is relevant at the point where a container generic is
diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb
index 380a10b6a1..d77e011c20 100644
--- a/gcc/ada/a-convec.adb
+++ b/gcc/ada/a-convec.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -617,9 +617,6 @@ package body Ada.Containers.Vectors is
end Finalize;
procedure Finalize (Object : in out Iterator) is
- pragma Warnings (Off);
- pragma Assert (T_Check); -- not called if check suppressed
- pragma Warnings (On);
begin
Unbusy (Object.Container.TC);
end Finalize;
diff --git a/gcc/ada/a-crbtgo.adb b/gcc/ada/a-crbtgo.adb
index 0307961879..1843b78bf1 100644
--- a/gcc/ada/a-crbtgo.adb
+++ b/gcc/ada/a-crbtgo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -34,7 +34,7 @@
-- Publisher: The MIT Press (June 18, 1990)
-- ISBN: 0262031418
-with System; use type System.Address;
+with System; use type System.Address;
package body Ada.Containers.Red_Black_Trees.Generic_Operations is
diff --git a/gcc/ada/a-crdlli.adb b/gcc/ada/a-crdlli.adb
index 0c6f5dccbb..f228ef0de4 100644
--- a/gcc/ada/a-crdlli.adb
+++ b/gcc/ada/a-crdlli.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,7 +27,7 @@
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
-with System; use type System.Address;
+with System; use type System.Address;
package body Ada.Containers.Restricted_Doubly_Linked_Lists is
diff --git a/gcc/ada/a-cuprqu.adb b/gcc/ada/a-cuprqu.adb
index e6947862a2..5d1bbacfc6 100644
--- a/gcc/ada/a-cuprqu.adb
+++ b/gcc/ada/a-cuprqu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,170 +27,8 @@
-- This unit was originally developed by Matthew J Heaney. --
------------------------------------------------------------------------------
-with Ada.Unchecked_Deallocation;
-
package body Ada.Containers.Unbounded_Priority_Queues is
- package body Implementation is
-
- -----------------------
- -- Local Subprograms --
- -----------------------
-
- procedure Free is
- new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
-
- -------------
- -- Dequeue --
- -------------
-
- procedure Dequeue
- (List : in out List_Type;
- Element : out Queue_Interfaces.Element_Type)
- is
- X : Node_Access;
-
- begin
- Element := List.First.Element;
-
- X := List.First;
- List.First := List.First.Next;
-
- if List.First = null then
- List.Last := null;
- end if;
-
- List.Length := List.Length - 1;
-
- Free (X);
- end Dequeue;
-
- procedure Dequeue
- (List : in out List_Type;
- At_Least : Queue_Priority;
- Element : in out Queue_Interfaces.Element_Type;
- Success : out Boolean)
- is
- begin
- -- This operation dequeues a high priority item if it exists in the
- -- queue. By "high priority" we mean an item whose priority is equal
- -- or greater than the value At_Least. The generic formal operation
- -- Before has the meaning "has higher priority than". To dequeue an
- -- item (meaning that we return True as our Success value), we need
- -- as our predicate the equivalent of "has equal or higher priority
- -- than", but we cannot say that directly, so we require some logical
- -- gymnastics to make it so.
-
- -- If E is the element at the head of the queue, and symbol ">"
- -- refers to the "is higher priority than" function Before, then we
- -- derive our predicate as follows:
- -- original: P(E) >= At_Least
- -- same as: not (P(E) < At_Least)
- -- same as: not (At_Least > P(E))
- -- same as: not Before (At_Least, P(E))
-
- -- But that predicate needs to be true in order to successfully
- -- dequeue an item. If it's false, it means no item is dequeued, and
- -- we return False as the Success value.
-
- if List.Length = 0
- or else Before (At_Least, Get_Priority (List.First.Element))
- then
- Success := False;
- return;
- end if;
-
- List.Dequeue (Element);
- Success := True;
- end Dequeue;
-
- -------------
- -- Enqueue --
- -------------
-
- procedure Enqueue
- (List : in out List_Type;
- New_Item : Queue_Interfaces.Element_Type)
- is
- P : constant Queue_Priority := Get_Priority (New_Item);
-
- Node : Node_Access;
- Prev : Node_Access;
-
- begin
- Node := new Node_Type'(New_Item, null);
-
- if List.First = null then
- List.First := Node;
- List.Last := List.First;
-
- else
- Prev := List.First;
-
- if Before (P, Get_Priority (Prev.Element)) then
- Node.Next := List.First;
- List.First := Node;
-
- else
- while Prev.Next /= null loop
- if Before (P, Get_Priority (Prev.Next.Element)) then
- Node.Next := Prev.Next;
- Prev.Next := Node;
-
- exit;
- end if;
-
- Prev := Prev.Next;
- end loop;
-
- if Prev.Next = null then
- List.Last.Next := Node;
- List.Last := Node;
- end if;
- end if;
- end if;
-
- List.Length := List.Length + 1;
-
- if List.Length > List.Max_Length then
- List.Max_Length := List.Length;
- end if;
- end Enqueue;
-
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize (List : in out List_Type) is
- X : Node_Access;
- begin
- while List.First /= null loop
- X := List.First;
- List.First := List.First.Next;
- Free (X);
- end loop;
- end Finalize;
-
- ------------
- -- Length --
- ------------
-
- function Length (List : List_Type) return Count_Type is
- begin
- return List.Length;
- end Length;
-
- ----------------
- -- Max_Length --
- ----------------
-
- function Max_Length (List : List_Type) return Count_Type is
- begin
- return List.Max_Length;
- end Max_Length;
-
- end Implementation;
-
protected body Queue is
-----------------
@@ -199,7 +37,7 @@ package body Ada.Containers.Unbounded_Priority_Queues is
function Current_Use return Count_Type is
begin
- return List.Length;
+ return Q_Elems.Length;
end Current_Use;
-------------
@@ -207,10 +45,14 @@ package body Ada.Containers.Unbounded_Priority_Queues is
-------------
entry Dequeue (Element : out Queue_Interfaces.Element_Type)
- when List.Length > 0
+ when Q_Elems.Length > 0
is
+ -- Grab the first item of the set, and remove it from the set
+
+ C : constant Cursor := First (Q_Elems);
begin
- List.Dequeue (Element);
+ Element := Sets.Element (C).Item;
+ Delete_First (Q_Elems);
end Dequeue;
--------------------------------
@@ -222,8 +64,19 @@ package body Ada.Containers.Unbounded_Priority_Queues is
Element : in out Queue_Interfaces.Element_Type;
Success : out Boolean)
is
+ -- Grab the first item. If it exists and has appropriate priority,
+ -- set Success to True, and remove that item. Otherwise, set Success
+ -- to False.
+
+ C : constant Cursor := First (Q_Elems);
begin
- List.Dequeue (At_Least, Element, Success);
+ Success := Has_Element (C) and then
+ not Before (At_Least, Get_Priority (Sets.Element (C).Item));
+
+ if Success then
+ Element := Sets.Element (C).Item;
+ Delete_First (Q_Elems);
+ end if;
end Dequeue_Only_High_Priority;
-------------
@@ -232,7 +85,15 @@ package body Ada.Containers.Unbounded_Priority_Queues is
entry Enqueue (New_Item : Queue_Interfaces.Element_Type) when True is
begin
- List.Enqueue (New_Item);
+ Insert (Q_Elems, (Next_Sequence_Number, New_Item));
+ Next_Sequence_Number := Next_Sequence_Number + 1;
+
+ -- If we reached a new high-water mark, increase Max_Length
+
+ if Q_Elems.Length > Max_Length then
+ pragma Assert (Max_Length + 1 = Q_Elems.Length);
+ Max_Length := Q_Elems.Length;
+ end if;
end Enqueue;
--------------
@@ -241,7 +102,7 @@ package body Ada.Containers.Unbounded_Priority_Queues is
function Peak_Use return Count_Type is
begin
- return List.Max_Length;
+ return Max_Length;
end Peak_Use;
end Queue;
diff --git a/gcc/ada/a-cuprqu.ads b/gcc/ada/a-cuprqu.ads
index 4cc000df60..591673e7d6 100644
--- a/gcc/ada/a-cuprqu.ads
+++ b/gcc/ada/a-cuprqu.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2016, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -32,8 +32,8 @@
------------------------------------------------------------------------------
with System;
+with Ada.Containers.Ordered_Sets;
with Ada.Containers.Synchronized_Queue_Interfaces;
-with Ada.Finalization;
generic
with package Queue_Interfaces is
@@ -59,46 +59,44 @@ package Ada.Containers.Unbounded_Priority_Queues is
pragma Implementation_Defined;
- type List_Type is tagged limited private;
-
- procedure Enqueue
- (List : in out List_Type;
- New_Item : Queue_Interfaces.Element_Type);
-
- procedure Dequeue
- (List : in out List_Type;
- Element : out Queue_Interfaces.Element_Type);
-
- procedure Dequeue
- (List : in out List_Type;
- At_Least : Queue_Priority;
- Element : in out Queue_Interfaces.Element_Type;
- Success : out Boolean);
-
- function Length (List : List_Type) return Count_Type;
-
- function Max_Length (List : List_Type) return Count_Type;
-
- private
+ -- We use an ordered set to hold the queue elements. This gives O(lg N)
+ -- performance in the worst case for Enqueue and Dequeue.
+ -- Sequence_Number is used to distinguish equivalent items. Each Enqueue
+ -- uses a higher Sequence_Number, so that a new item is placed after
+ -- already-enqueued equivalent items.
+ --
+ -- At any time, the first set element is the one to be dequeued next (if
+ -- the queue is not empty).
+
+ type Set_Elem is record
+ Sequence_Number : Count_Type;
+ Item : Queue_Interfaces.Element_Type;
+ end record;
- type Node_Type;
- type Node_Access is access Node_Type;
+ function "=" (X, Y : Queue_Interfaces.Element_Type) return Boolean is
+ (not Before (Get_Priority (X), Get_Priority (Y))
+ and then not Before (Get_Priority (Y), Get_Priority (X)));
+ -- Elements are equal if neither is Before the other
- type Node_Type is limited record
- Element : Queue_Interfaces.Element_Type;
- Next : Node_Access;
- end record;
+ function "=" (X, Y : Set_Elem) return Boolean is
+ (X.Sequence_Number = Y.Sequence_Number and then X.Item = Y.Item);
+ -- Set_Elems are equal if the elements are equal, and the
+ -- Sequence_Numbers are equal. This is passed to Ordered_Sets.
- type List_Type is new Ada.Finalization.Limited_Controlled with record
- First, Last : Node_Access;
- Length : Count_Type := 0;
- Max_Length : Count_Type := 0;
- end record;
+ function "<" (X, Y : Set_Elem) return Boolean is
+ (if X.Item = Y.Item
+ then X.Sequence_Number < Y.Sequence_Number
+ else Before (Get_Priority (X.Item), Get_Priority (Y.Item)));
+ -- If the items are equal, Sequence_Number breaks the tie. Otherwise,
+ -- use Before. This is passed to Ordered_Sets.
- overriding procedure Finalize (List : in out List_Type);
+ pragma Suppress (Container_Checks);
+ package Sets is new Ada.Containers.Ordered_Sets (Set_Elem);
end Implementation;
+ use Implementation, Implementation.Sets;
+
protected type Queue (Ceiling : System.Any_Priority := Default_Ceiling)
with
Priority => Ceiling
@@ -125,7 +123,15 @@ package Ada.Containers.Unbounded_Priority_Queues is
overriding function Peak_Use return Count_Type;
private
- List : Implementation.List_Type;
+ Q_Elems : Set;
+ -- Elements of the queue
+
+ Max_Length : Count_Type := 0;
+ -- The current length of the queue is the Length of Q_Elems. This is the
+ -- maximum value of that, so far. Updated by Enqueue.
+
+ Next_Sequence_Number : Count_Type := 0;
+ -- Steadily increasing counter
end Queue;
end Ada.Containers.Unbounded_Priority_Queues;
diff --git a/gcc/ada/a-direct.adb b/gcc/ada/a-direct.adb
index 7c5c4f4555..766415428e 100644
--- a/gcc/ada/a-direct.adb
+++ b/gcc/ada/a-direct.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -597,7 +597,6 @@ package body Ada.Directories is
-----------------
procedure Delete_Tree (Directory : String) is
- Current_Dir : constant String := Current_Directory;
Search : Search_Type;
Dir_Ent : Directory_Entry_Type;
begin
@@ -611,28 +610,33 @@ package body Ada.Directories is
raise Name_Error with '"' & Directory & """ not a directory";
else
- Set_Directory (Directory);
- Start_Search (Search, Directory => ".", Pattern => "");
+ -- We used to change the current directory to Directory here,
+ -- allowing the use of a local Simple_Name for all references. This
+ -- turned out unfriendly to multitasking programs, where tasks
+ -- running in parallel of this Delete_Tree could see their current
+ -- directory change unpredictably. We now resort to Full_Name
+ -- computations to reach files and subdirs instead.
+
+ Start_Search (Search, Directory => Directory, Pattern => "");
while More_Entries (Search) loop
Get_Next_Entry (Search, Dir_Ent);
declare
- File_Name : constant String := Simple_Name (Dir_Ent);
+ Fname : constant String := Full_Name (Dir_Ent);
+ Sname : constant String := Simple_Name (Dir_Ent);
begin
- if OS_Lib.Is_Directory (File_Name) then
- if File_Name /= "." and then File_Name /= ".." then
- Delete_Tree (File_Name);
+ if OS_Lib.Is_Directory (Fname) then
+ if Sname /= "." and then Sname /= ".." then
+ Delete_Tree (Fname);
end if;
-
else
- Delete_File (File_Name);
+ Delete_File (Fname);
end if;
end;
end loop;
- Set_Directory (Current_Dir);
End_Search (Search);
declare
diff --git a/gcc/ada/a-direio.adb b/gcc/ada/a-direio.adb
index b9330b0448..ba7bd70f53 100644
--- a/gcc/ada/a-direio.adb
+++ b/gcc/ada/a-direio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -108,6 +108,15 @@ package body Ada.Direct_IO is
return DIO.End_Of_File (FP (File));
end End_Of_File;
+ -----------
+ -- Flush --
+ -----------
+
+ procedure Flush (File : File_Type) is
+ begin
+ FIO.Flush (AP (File));
+ end Flush;
+
----------
-- Form --
----------
diff --git a/gcc/ada/a-direio.ads b/gcc/ada/a-direio.ads
index 1244b2dbfb..e53e9c1abb 100644
--- a/gcc/ada/a-direio.ads
+++ b/gcc/ada/a-direio.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -94,6 +94,8 @@ package Ada.Direct_IO is
function Is_Open (File : File_Type) return Boolean;
+ procedure Flush (File : File_Type);
+
---------------------------------
-- Input and Output Operations --
---------------------------------
diff --git a/gcc/ada/a-dispat.ads b/gcc/ada/a-dispat.ads
index a1939409d1..b4e4d036b1 100644
--- a/gcc/ada/a-dispat.ads
+++ b/gcc/ada/a-dispat.ads
@@ -16,7 +16,8 @@
package Ada.Dispatching is
pragma Preelaborate (Dispatching);
- procedure Yield;
+ procedure Yield with
+ Global => null;
Dispatching_Policy_Error : exception;
end Ada.Dispatching;
diff --git a/gcc/ada/a-exetim-darwin.adb b/gcc/ada/a-exetim-darwin.adb
new file mode 100644
index 0000000000..36a657cada
--- /dev/null
+++ b/gcc/ada/a-exetim-darwin.adb
@@ -0,0 +1,210 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- A D A . E X E C U T I O N _ T I M E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2007-2016, Free Software Foundation, Inc. --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This is the Darwin version of this package
+
+with Ada.Task_Identification; use Ada.Task_Identification;
+with Ada.Unchecked_Conversion;
+
+with System.Tasking;
+with System.OS_Interface; use System.OS_Interface;
+with System.Task_Primitives.Operations; use System.Task_Primitives.Operations;
+
+with Interfaces.C; use Interfaces.C;
+
+package body Ada.Execution_Time is
+
+ ---------
+ -- "+" --
+ ---------
+
+ function "+"
+ (Left : CPU_Time;
+ Right : Ada.Real_Time.Time_Span) return CPU_Time
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ return CPU_Time (Ada.Real_Time.Time (Left) + Right);
+ end "+";
+
+ function "+"
+ (Left : Ada.Real_Time.Time_Span;
+ Right : CPU_Time) return CPU_Time
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ return CPU_Time (Left + Ada.Real_Time.Time (Right));
+ end "+";
+
+ ---------
+ -- "-" --
+ ---------
+
+ function "-"
+ (Left : CPU_Time;
+ Right : Ada.Real_Time.Time_Span) return CPU_Time
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ return CPU_Time (Ada.Real_Time.Time (Left) - Right);
+ end "-";
+
+ function "-"
+ (Left : CPU_Time;
+ Right : CPU_Time) return Ada.Real_Time.Time_Span
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ return (Ada.Real_Time.Time (Left) - Ada.Real_Time.Time (Right));
+ end "-";
+
+ -----------
+ -- Clock --
+ -----------
+
+ function Clock
+ (T : Ada.Task_Identification.Task_Id :=
+ Ada.Task_Identification.Current_Task) return CPU_Time
+ is
+ function Convert_Ids is new
+ Ada.Unchecked_Conversion (Task_Id, System.Tasking.Task_Id);
+
+ function To_CPU_Time is
+ new Ada.Unchecked_Conversion (Duration, CPU_Time);
+ -- Time is equal to Duration (although it is a private type) and
+ -- CPU_Time is equal to Time.
+
+ subtype integer_t is Interfaces.C.int;
+ subtype mach_port_t is integer_t;
+ -- Type definition for Mach.
+
+ type time_value_t is record
+ seconds : integer_t;
+ microseconds : integer_t;
+ end record;
+ pragma Convention (C, time_value_t);
+ -- Mach time_value_t
+
+ type thread_basic_info_t is record
+ user_time : time_value_t;
+ system_time : time_value_t;
+ cpu_usage : integer_t;
+ policy : integer_t;
+ run_state : integer_t;
+ flags : integer_t;
+ suspend_count : integer_t;
+ sleep_time : integer_t;
+ end record;
+ pragma Convention (C, thread_basic_info_t);
+ -- Mach structure from thread_info.h
+
+ THREAD_BASIC_INFO : constant := 3;
+ THREAD_BASIC_INFO_COUNT : constant := 10;
+ -- Flavors for basic info
+
+ function thread_info (Target : mach_port_t;
+ Flavor : integer_t;
+ Thread_Info : System.Address;
+ Count : System.Address) return integer_t;
+ pragma Import (C, thread_info);
+ -- Mach call to get info on a thread
+
+ function pthread_mach_thread_np (Thread : pthread_t) return mach_port_t;
+ pragma Import (C, pthread_mach_thread_np);
+ -- Get Mach thread from posix thread
+
+ Result : Interfaces.C.int;
+ Thread : pthread_t;
+ Port : mach_port_t;
+ Ti : thread_basic_info_t;
+ Count : integer_t;
+ begin
+ if T = Ada.Task_Identification.Null_Task_Id then
+ raise Program_Error;
+ end if;
+
+ Thread := Get_Thread_Id (Convert_Ids (T));
+ Port := pthread_mach_thread_np (Thread);
+ pragma Assert (Port > 0);
+
+ Count := THREAD_BASIC_INFO_COUNT;
+ Result := thread_info (Port, THREAD_BASIC_INFO,
+ Ti'Address, Count'Address);
+ pragma Assert (Result = 0);
+ pragma Assert (Count = THREAD_BASIC_INFO_COUNT);
+
+ return To_CPU_Time
+ (Duration (Ti.user_time.seconds + Ti.system_time.seconds)
+ + Duration (Ti.user_time.microseconds
+ + Ti.system_time.microseconds) / 1E6);
+ end Clock;
+
+ --------------------------
+ -- Clock_For_Interrupts --
+ --------------------------
+
+ function Clock_For_Interrupts return CPU_Time is
+ begin
+ -- According to AI 0170-1, D.14(18.1/3), if Interrupt_Clocks_Supported
+ -- is set to False the function raises Program_Error.
+
+ raise Program_Error;
+ return CPU_Time_First;
+ end Clock_For_Interrupts;
+
+ -----------
+ -- Split --
+ -----------
+
+ procedure Split
+ (T : CPU_Time;
+ SC : out Ada.Real_Time.Seconds_Count;
+ TS : out Ada.Real_Time.Time_Span)
+ is
+ use type Ada.Real_Time.Time;
+ begin
+ Ada.Real_Time.Split (Ada.Real_Time.Time (T), SC, TS);
+ end Split;
+
+ -------------
+ -- Time_Of --
+ -------------
+
+ function Time_Of
+ (SC : Ada.Real_Time.Seconds_Count;
+ TS : Ada.Real_Time.Time_Span := Ada.Real_Time.Time_Span_Zero)
+ return CPU_Time
+ is
+ begin
+ return CPU_Time (Ada.Real_Time.Time_Of (SC, TS));
+ end Time_Of;
+
+end Ada.Execution_Time;
diff --git a/gcc/ada/a-exetim-mingw.ads b/gcc/ada/a-exetim-mingw.ads
index 5ba3e08c38..4224d66033 100644
--- a/gcc/ada/a-exetim-mingw.ads
+++ b/gcc/ada/a-exetim-mingw.ads
@@ -41,7 +41,6 @@ with Ada.Real_Time;
package Ada.Execution_Time with
SPARK_Mode
is
-
type CPU_Time is private;
CPU_Time_First : constant CPU_Time;
diff --git a/gcc/ada/a-exexpr-gcc.adb b/gcc/ada/a-exexpr-gcc.adb
index 3208027a72..91fb5f5cd6 100644
--- a/gcc/ada/a-exexpr-gcc.adb
+++ b/gcc/ada/a-exexpr-gcc.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -115,7 +115,8 @@ package body Exception_Propagation is
GCC_Exception : not null GCC_Exception_Access);
pragma Export
(C, Set_Exception_Parameter, "__gnat_set_exception_parameter");
- -- Called inserted by gigi to initialize the exception parameter
+ -- Called inserted by gigi to set the exception choice parameter from the
+ -- gcc occurrence.
procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address);
-- Utility routine to initialize occurrence Excep from a foreign exception
diff --git a/gcc/ada/a-locale.adb b/gcc/ada/a-locale.adb
index d56970c86e..60ad079d43 100644
--- a/gcc/ada/a-locale.adb
+++ b/gcc/ada/a-locale.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -33,8 +33,7 @@ with System; use System;
package body Ada.Locales is
- type Lower_4 is array (1 .. 4) of Character range 'a' .. 'z';
- type Upper_4 is array (1 .. 4) of Character range 'A' .. 'Z';
+ type Str_4 is new String (1 .. 4);
--------------
-- Language --
@@ -43,7 +42,7 @@ package body Ada.Locales is
function Language return Language_Code is
procedure C_Get_Language_Code (P : Address);
pragma Import (C, C_Get_Language_Code);
- F : Lower_4;
+ F : Str_4;
begin
C_Get_Language_Code (F'Address);
return Language_Code (F (1 .. 3));
@@ -56,7 +55,7 @@ package body Ada.Locales is
function Country return Country_Code is
procedure C_Get_Country_Code (P : Address);
pragma Import (C, C_Get_Country_Code);
- F : Upper_4;
+ F : Str_4;
begin
C_Get_Country_Code (F'Address);
return Country_Code (F (1 .. 2));
diff --git a/gcc/ada/a-locale.ads b/gcc/ada/a-locale.ads
index 629f367bb6..132c8832b7 100644
--- a/gcc/ada/a-locale.ads
+++ b/gcc/ada/a-locale.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2016, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. In accordance with the copyright of that document, you can freely --
@@ -19,8 +19,13 @@ package Ada.Locales is
pragma Preelaborate (Locales);
pragma Remote_Types (Locales);
- type Language_Code is array (1 .. 3) of Character range 'a' .. 'z';
- type Country_Code is array (1 .. 2) of Character range 'A' .. 'Z';
+ type Language_Code is new String (1 .. 3)
+ with Dynamic_Predicate =>
+ (for all E of Language_Code => E in 'a' .. 'z');
+
+ type Country_Code is new String (1 .. 2)
+ with Dynamic_Predicate =>
+ (for all E of Country_Code => E in 'A' .. 'Z');
Language_Unknown : constant Language_Code := "und";
Country_Unknown : constant Country_Code := "ZZ";
diff --git a/gcc/ada/a-ngcefu.adb b/gcc/ada/a-ngcefu.adb
index 87a1dc9e16..b241f2718a 100644
--- a/gcc/ada/a-ngcefu.adb
+++ b/gcc/ada/a-ngcefu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -37,10 +37,10 @@ package body Ada.Numerics.Generic_Complex_Elementary_Functions is
Ada.Numerics.Generic_Elementary_Functions (Real'Base);
use Elementary_Functions;
- PI : constant := 3.14159_26535_89793_23846_26433_83279_50288_41971;
- PI_2 : constant := PI / 2.0;
+ PI : constant := 3.14159_26535_89793_23846_26433_83279_50288_41971;
+ PI_2 : constant := PI / 2.0;
Sqrt_Two : constant := 1.41421_35623_73095_04880_16887_24209_69807_85696;
- Log_Two : constant := 0.69314_71805_59945_30941_72321_21458_17656_80755;
+ Log_Two : constant := 0.69314_71805_59945_30941_72321_21458_17656_80755;
subtype T is Real'Base;
@@ -78,7 +78,7 @@ package body Ada.Numerics.Generic_Complex_Elementary_Functions is
elsif Re (Left) = 0.0 and then Im (Left) = 0.0 then
return Left;
- elsif Right = (0.0, 0.0) then
+ elsif Right = (0.0, 0.0) then
return Complex_One;
elsif Re (Right) = 0.0 and then Im (Right) = 0.0 then
@@ -417,7 +417,7 @@ package body Ada.Numerics.Generic_Complex_Elementary_Functions is
begin
return
Compose_From_Cartesian
- (Cos (Re (X)) * Cosh (Im (X)),
+ (Cos (Re (X)) * Cosh (Im (X)),
-(Sin (Re (X)) * Sinh (Im (X))));
end Cos;
diff --git a/gcc/ada/a-ngcoar.adb b/gcc/ada/a-ngcoar.adb
index ca0c58c36f..e9b246574b 100644
--- a/gcc/ada/a-ngcoar.adb
+++ b/gcc/ada/a-ngcoar.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2006-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -30,7 +30,6 @@
------------------------------------------------------------------------------
with System.Generic_Array_Operations; use System.Generic_Array_Operations;
-with Ada.Numerics; use Ada.Numerics;
package body Ada.Numerics.Generic_Complex_Arrays is
@@ -694,11 +693,11 @@ package body Ada.Numerics.Generic_Complex_Arrays is
-- Solve --
-----------
- function Solve is
- new Matrix_Vector_Solution (Complex, Complex_Vector, Complex_Matrix);
+ function Solve is new Matrix_Vector_Solution
+ (Complex, (0.0, 0.0), Complex_Vector, Complex_Matrix);
- function Solve is
- new Matrix_Matrix_Solution (Complex, Complex_Matrix);
+ function Solve is new Matrix_Matrix_Solution
+ (Complex, (0.0, 0.0), Complex_Matrix);
-----------------
-- Unit_Matrix --
diff --git a/gcc/ada/a-ngrear.adb b/gcc/ada/a-ngrear.adb
index 68d536513a..c3b954ab51 100644
--- a/gcc/ada/a-ngrear.adb
+++ b/gcc/ada/a-ngrear.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2006-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -337,10 +337,11 @@ package body Ada.Numerics.Generic_Real_Arrays is
Result_Matrix => Real_Matrix,
Operation => "abs");
- function Solve is
- new Matrix_Vector_Solution (Real'Base, Real_Vector, Real_Matrix);
+ function Solve is new
+ Matrix_Vector_Solution (Real'Base, 0.0, Real_Vector, Real_Matrix);
- function Solve is new Matrix_Matrix_Solution (Real'Base, Real_Matrix);
+ function Solve is new
+ Matrix_Matrix_Solution (Real'Base, 0.0, Real_Matrix);
function Unit_Matrix is new
Generic_Array_Operations.Unit_Matrix
diff --git a/gcc/ada/a-nudira.adb b/gcc/ada/a-nudira.adb
index 251f852579..2e83600ffd 100644
--- a/gcc/ada/a-nudira.adb
+++ b/gcc/ada/a-nudira.adb
@@ -29,7 +29,9 @@
-- --
------------------------------------------------------------------------------
-package body Ada.Numerics.Discrete_Random is
+package body Ada.Numerics.Discrete_Random with
+ SPARK_Mode => Off
+is
package SRN renames System.Random_Numbers;
use SRN;
diff --git a/gcc/ada/a-nudira.ads b/gcc/ada/a-nudira.ads
index 77501ec63a..c2a7382cad 100644
--- a/gcc/ada/a-nudira.ads
+++ b/gcc/ada/a-nudira.ads
@@ -41,7 +41,9 @@ with System.Random_Numbers;
generic
type Result_Subtype is (<>);
-package Ada.Numerics.Discrete_Random is
+package Ada.Numerics.Discrete_Random with
+ SPARK_Mode => Off
+is
-- Basic facilities
diff --git a/gcc/ada/a-nuflra.adb b/gcc/ada/a-nuflra.adb
index 2c6fbc47f6..add19d453c 100644
--- a/gcc/ada/a-nuflra.adb
+++ b/gcc/ada/a-nuflra.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,7 +29,9 @@
-- --
------------------------------------------------------------------------------
-package body Ada.Numerics.Float_Random is
+package body Ada.Numerics.Float_Random with
+ SPARK_Mode => Off
+is
package SRN renames System.Random_Numbers;
use SRN;
diff --git a/gcc/ada/a-nuflra.ads b/gcc/ada/a-nuflra.ads
index 5a448a7811..ea4992c5a0 100644
--- a/gcc/ada/a-nuflra.ads
+++ b/gcc/ada/a-nuflra.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -38,7 +38,9 @@
with System.Random_Numbers;
-package Ada.Numerics.Float_Random is
+package Ada.Numerics.Float_Random with
+ SPARK_Mode => Off
+is
-- Basic facilities
diff --git a/gcc/ada/a-numaux-x86.adb b/gcc/ada/a-numaux-x86.adb
index 5f245a2c37..6f1f4624b6 100644
--- a/gcc/ada/a-numaux-x86.adb
+++ b/gcc/ada/a-numaux-x86.adb
@@ -7,7 +7,7 @@
-- B o d y --
-- (Machine Version for x86) --
-- --
--- Copyright (C) 1998-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -263,14 +263,17 @@ package body Ada.Numerics.Aux is
Asm (Template => "fcos",
Outputs => Double'Asm_Output ("=t", Result),
Inputs => Double'Asm_Input ("0", Reduced_X));
+
when 1 =>
Asm (Template => "fsin",
Outputs => Double'Asm_Output ("=t", Result),
Inputs => Double'Asm_Input ("0", -Reduced_X));
+
when 2 =>
Asm (Template => "fcos ; fchs",
Outputs => Double'Asm_Output ("=t", Result),
Inputs => Double'Asm_Input ("0", Reduced_X));
+
when 3 =>
Asm (Template => "fsin",
Outputs => Double'Asm_Output ("=t", Result),
@@ -448,14 +451,17 @@ package body Ada.Numerics.Aux is
Asm (Template => "fsin",
Outputs => Double'Asm_Output ("=t", Result),
Inputs => Double'Asm_Input ("0", Reduced_X));
+
when 1 =>
Asm (Template => "fcos",
Outputs => Double'Asm_Output ("=t", Result),
Inputs => Double'Asm_Input ("0", Reduced_X));
+
when 2 =>
Asm (Template => "fsin",
Outputs => Double'Asm_Output ("=t", Result),
Inputs => Double'Asm_Input ("0", -Reduced_X));
+
when 3 =>
Asm (Template => "fcos ; fchs",
Outputs => Double'Asm_Output ("=t", Result),
diff --git a/gcc/ada/a-rbtgbo.adb b/gcc/ada/a-rbtgbo.adb
index acf2ccb01c..8306399eb8 100644
--- a/gcc/ada/a-rbtgbo.adb
+++ b/gcc/ada/a-rbtgbo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -35,7 +35,7 @@
-- Publisher: The MIT Press (June 18, 1990)
-- ISBN: 0262031418
-with System; use type System.Address;
+with System; use type System.Address;
package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is
diff --git a/gcc/ada/a-reatim.ads b/gcc/ada/a-reatim.ads
index 8b341c0b58..cb84859df6 100644
--- a/gcc/ada/a-reatim.ads
+++ b/gcc/ada/a-reatim.ads
@@ -40,7 +40,8 @@ package Ada.Real_Time with
SPARK_Mode,
Abstract_State => (Clock_Time with Synchronous,
External => (Async_Readers,
- Async_Writers))
+ Async_Writers)),
+ Initializes => Clock_Time
is
pragma Compile_Time_Error
diff --git a/gcc/ada/a-sequio.adb b/gcc/ada/a-sequio.adb
index 31e5d757ea..f180fd68cd 100644
--- a/gcc/ada/a-sequio.adb
+++ b/gcc/ada/a-sequio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -121,6 +121,15 @@ package body Ada.Sequential_IO is
return FIO.End_Of_File (AP (File));
end End_Of_File;
+ -----------
+ -- Flush --
+ -----------
+
+ procedure Flush (File : File_Type) is
+ begin
+ FIO.Flush (AP (File));
+ end Flush;
+
----------
-- Form --
----------
diff --git a/gcc/ada/a-sequio.ads b/gcc/ada/a-sequio.ads
index a728c54035..8dbfb0fcd4 100644
--- a/gcc/ada/a-sequio.ads
+++ b/gcc/ada/a-sequio.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -90,6 +90,8 @@ package Ada.Sequential_IO is
function Is_Open (File : File_Type) return Boolean;
+ procedure Flush (File : File_Type);
+
---------------------------------
-- Input and output operations --
---------------------------------
diff --git a/gcc/ada/a-strfix.adb b/gcc/ada/a-strfix.adb
index 69c0650df8..2f140d8aa4 100644
--- a/gcc/ada/a-strfix.adb
+++ b/gcc/ada/a-strfix.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -349,7 +349,6 @@ package body Ada.Strings.Fixed is
Target := Source;
elsif Slength > Tlength then
-
case Drop is
when Left =>
Target := Source (Slast - Tlength + 1 .. Slast);
@@ -377,7 +376,6 @@ package body Ada.Strings.Fixed is
when Center =>
raise Length_Error;
end case;
-
end case;
-- Source'Length < Target'Length
diff --git a/gcc/ada/a-strunb-shared.adb b/gcc/ada/a-strunb-shared.adb
index 5cbe3602a5..2199f647b8 100644
--- a/gcc/ada/a-strunb-shared.adb
+++ b/gcc/ada/a-strunb-shared.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -499,7 +499,9 @@ package body Ada.Strings.Unbounded is
-- Allocate --
--------------
- function Allocate (Max_Length : Natural) return Shared_String_Access is
+ function Allocate
+ (Max_Length : Natural) return not null Shared_String_Access
+ is
begin
-- Empty string requested, return shared empty string
@@ -622,8 +624,9 @@ package body Ada.Strings.Unbounded is
-------------------
function Can_Be_Reused
- (Item : Shared_String_Access;
- Length : Natural) return Boolean is
+ (Item : not null Shared_String_Access;
+ Length : Natural) return Boolean
+ is
begin
return
System.Atomic_Counters.Is_One (Item.Counter)
@@ -785,17 +788,20 @@ package body Ada.Strings.Unbounded is
--------------
procedure Finalize (Object : in out Unbounded_String) is
- SR : constant Shared_String_Access := Object.Reference;
-
+ SR : constant not null Shared_String_Access := Object.Reference;
begin
- if SR /= null then
+ if SR /= Null_Unbounded_String.Reference then
-- The same controlled object can be finalized several times for
-- some reason. As per 7.6.1(24) this should have no ill effect,
-- so we need to add a guard for the case of finalizing the same
-- object twice.
- Object.Reference := null;
+ -- We set the Object to the empty string so there will be no ill
+ -- effects if a program references an already-finalized object.
+
+ Object.Reference := Null_Unbounded_String.Reference;
+ Reference (Object.Reference);
Unreference (SR);
end if;
end Finalize;
@@ -2097,11 +2103,12 @@ package body Ada.Strings.Unbounded is
begin
if System.Atomic_Counters.Decrement (Aux.Counter) then
- -- Reference counter of Empty_Shared_String must never reach zero
-
- pragma Assert (Aux /= Empty_Shared_String'Access);
+ -- Reference counter of Empty_Shared_String should never reach
+ -- zero. We check here in case it wraps around.
- Free (Aux);
+ if Aux /= Empty_Shared_String'Access then
+ Free (Aux);
+ end if;
end if;
end Unreference;
diff --git a/gcc/ada/a-strunb-shared.ads b/gcc/ada/a-strunb-shared.ads
index 1a00780fad..c5f96b38f1 100644
--- a/gcc/ada/a-strunb-shared.ads
+++ b/gcc/ada/a-strunb-shared.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -449,14 +449,15 @@ private
-- Decrement reference counter, deallocate Item when counter goes to zero
function Can_Be_Reused
- (Item : Shared_String_Access;
+ (Item : not null Shared_String_Access;
Length : Natural) return Boolean;
-- Returns True if Shared_String can be reused. There are two criteria when
-- Shared_String can be reused: its reference counter must be one (thus
-- Shared_String is owned exclusively) and its size is sufficient to
-- store string with specified length effectively.
- function Allocate (Max_Length : Natural) return Shared_String_Access;
+ function Allocate
+ (Max_Length : Natural) return not null Shared_String_Access;
-- Allocates new Shared_String with at least specified maximum length.
-- Actual maximum length of the allocated Shared_String can be slightly
-- greater. Returns reference to Empty_Shared_String when requested length
@@ -469,7 +470,7 @@ private
-- This renames are here only to be used in the pragma Stream_Convert
type Unbounded_String is new AF.Controlled with record
- Reference : Shared_String_Access := Empty_Shared_String'Access;
+ Reference : not null Shared_String_Access := Empty_Shared_String'Access;
end record;
pragma Stream_Convert (Unbounded_String, To_Unbounded, To_String);
diff --git a/gcc/ada/a-stwibo.ads b/gcc/ada/a-stwibo.ads
index c5a54d14b1..3d098b3d4d 100644
--- a/gcc/ada/a-stwibo.ads
+++ b/gcc/ada/a-stwibo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -609,7 +609,7 @@ package Ada.Strings.Wide_Bounded is
High : Natural)
renames Super_Slice;
- function "="
+ overriding function "="
(Left : Bounded_Wide_String;
Right : Bounded_Wide_String) return Boolean
renames Equal;
diff --git a/gcc/ada/a-stwifi.adb b/gcc/ada/a-stwifi.adb
index dfe961995d..c586791100 100644
--- a/gcc/ada/a-stwifi.adb
+++ b/gcc/ada/a-stwifi.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -327,7 +327,6 @@ package body Ada.Strings.Wide_Fixed is
Target := Source;
elsif Slength > Tlength then
-
case Drop is
when Left =>
Target := Source (Slast - Tlength + 1 .. Slast);
@@ -355,7 +354,6 @@ package body Ada.Strings.Wide_Fixed is
when Center =>
raise Length_Error;
end case;
-
end case;
-- Source'Length < Target'Length
diff --git a/gcc/ada/a-stzbou.ads b/gcc/ada/a-stzbou.ads
index 9574802f25..d7d3f52f2e 100644
--- a/gcc/ada/a-stzbou.ads
+++ b/gcc/ada/a-stzbou.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -618,7 +618,7 @@ package Ada.Strings.Wide_Wide_Bounded is
High : Natural)
renames Super_Slice;
- function "="
+ overriding function "="
(Left : Bounded_Wide_Wide_String;
Right : Bounded_Wide_Wide_String) return Boolean
renames Equal;
diff --git a/gcc/ada/a-stzfix.adb b/gcc/ada/a-stzfix.adb
index 9176d400e0..b0087831d9 100644
--- a/gcc/ada/a-stzfix.adb
+++ b/gcc/ada/a-stzfix.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -329,7 +329,6 @@ package body Ada.Strings.Wide_Wide_Fixed is
Target := Source;
elsif Slength > Tlength then
-
case Drop is
when Left =>
Target := Source (Slast - Tlength + 1 .. Slast);
diff --git a/gcc/ada/a-stzsup.adb b/gcc/ada/a-stzsup.adb
index d197a8fb7b..acd003591e 100644
--- a/gcc/ada/a-stzsup.adb
+++ b/gcc/ada/a-stzsup.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -529,7 +529,6 @@ package body Ada.Strings.Wide_Wide_Superbounded is
raise Ada.Strings.Length_Error;
end case;
end if;
-
end Super_Append;
-- Case of Wide_Wide_String and Super_String
diff --git a/gcc/ada/a-sytaco.ads b/gcc/ada/a-sytaco.ads
index bf1ab8720c..733fc764e2 100644
--- a/gcc/ada/a-sytaco.ads
+++ b/gcc/ada/a-sytaco.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -44,7 +44,8 @@ is
pragma Preelaborate;
-- In accordance with Ada 2005 AI-362
- type Suspension_Object is limited private;
+ type Suspension_Object is limited private with
+ Default_Initial_Condition;
procedure Set_True (S : in out Suspension_Object) with
Global => null,
diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb
index 203d19ed67..08c4dd91b6 100644
--- a/gcc/ada/a-tags.adb
+++ b/gcc/ada/a-tags.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -61,6 +61,13 @@ package body Ada.Tags is
-- table. This is Inline_Always since it is called from other Inline_
-- Always subprograms where we want no out of line code to be generated.
+ function IW_Membership
+ (Descendant_TSD : Type_Specific_Data_Ptr;
+ T : Tag) return Boolean;
+ -- Subsidiary function of IW_Membership and CW_Membership which factorizes
+ -- the functionality needed to check if a given descendant implements an
+ -- interface tag T.
+
function Length (Str : Cstring_Ptr) return Natural;
-- Length of string represented by the given pointer (treating the string
-- as a C-style string, which is Nul terminated). See comment in body
@@ -431,27 +438,14 @@ package body Ada.Tags is
-- IW_Membership --
-------------------
- -- Canonical implementation of Classwide Membership corresponding to:
-
- -- Obj in Iface'Class
-
- -- Each dispatch table contains a table with the tags of all the
- -- implemented interfaces.
-
- -- Obj is in Iface'Class if Iface'Tag is found in the table of interfaces
- -- that are contained in the dispatch table referenced by Obj'Tag.
-
- function IW_Membership (This : System.Address; T : Tag) return Boolean is
+ function IW_Membership
+ (Descendant_TSD : Type_Specific_Data_Ptr;
+ T : Tag) return Boolean
+ is
Iface_Table : Interface_Data_Ptr;
- Obj_Base : System.Address;
- Obj_DT : Dispatch_Table_Ptr;
- Obj_TSD : Type_Specific_Data_Ptr;
begin
- Obj_Base := Base_Address (This);
- Obj_DT := DT (To_Tag_Ptr (Obj_Base).all);
- Obj_TSD := To_Type_Specific_Data_Ptr (Obj_DT.TSD);
- Iface_Table := Obj_TSD.Interfaces_Table;
+ Iface_Table := Descendant_TSD.Interfaces_Table;
if Iface_Table /= null then
for Id in 1 .. Iface_Table.Nb_Ifaces loop
@@ -464,8 +458,8 @@ package body Ada.Tags is
-- Look for the tag in the ancestor tags table. This is required for:
-- Iface_CW in Typ'Class
- for Id in 0 .. Obj_TSD.Idepth loop
- if Obj_TSD.Tags_Table (Id) = T then
+ for Id in 0 .. Descendant_TSD.Idepth loop
+ if Descendant_TSD.Tags_Table (Id) = T then
return True;
end if;
end loop;
@@ -474,6 +468,33 @@ package body Ada.Tags is
end IW_Membership;
-------------------
+ -- IW_Membership --
+ -------------------
+
+ -- Canonical implementation of Classwide Membership corresponding to:
+
+ -- Obj in Iface'Class
+
+ -- Each dispatch table contains a table with the tags of all the
+ -- implemented interfaces.
+
+ -- Obj is in Iface'Class if Iface'Tag is found in the table of interfaces
+ -- that are contained in the dispatch table referenced by Obj'Tag.
+
+ function IW_Membership (This : System.Address; T : Tag) return Boolean is
+ Obj_Base : System.Address;
+ Obj_DT : Dispatch_Table_Ptr;
+ Obj_TSD : Type_Specific_Data_Ptr;
+
+ begin
+ Obj_Base := Base_Address (This);
+ Obj_DT := DT (To_Tag_Ptr (Obj_Base).all);
+ Obj_TSD := To_Type_Specific_Data_Ptr (Obj_DT.TSD);
+
+ return IW_Membership (Obj_TSD, T);
+ end IW_Membership;
+
+ -------------------
-- Expanded_Name --
-------------------
@@ -721,18 +742,27 @@ package body Ada.Tags is
(Descendant : Tag;
Ancestor : Tag) return Boolean
is
- D_TSD_Ptr : constant Addr_Ptr :=
- To_Addr_Ptr (To_Address (Descendant) - DT_Typeinfo_Ptr_Size);
- A_TSD_Ptr : constant Addr_Ptr :=
- To_Addr_Ptr (To_Address (Ancestor) - DT_Typeinfo_Ptr_Size);
- D_TSD : constant Type_Specific_Data_Ptr :=
- To_Type_Specific_Data_Ptr (D_TSD_Ptr.all);
- A_TSD : constant Type_Specific_Data_Ptr :=
- To_Type_Specific_Data_Ptr (A_TSD_Ptr.all);
-
begin
- return CW_Membership (Descendant, Ancestor)
- and then D_TSD.Access_Level = A_TSD.Access_Level;
+ if Descendant = Ancestor then
+ return True;
+
+ else
+ declare
+ D_TSD_Ptr : constant Addr_Ptr :=
+ To_Addr_Ptr (To_Address (Descendant) - DT_Typeinfo_Ptr_Size);
+ A_TSD_Ptr : constant Addr_Ptr :=
+ To_Addr_Ptr (To_Address (Ancestor) - DT_Typeinfo_Ptr_Size);
+ D_TSD : constant Type_Specific_Data_Ptr :=
+ To_Type_Specific_Data_Ptr (D_TSD_Ptr.all);
+ A_TSD : constant Type_Specific_Data_Ptr :=
+ To_Type_Specific_Data_Ptr (A_TSD_Ptr.all);
+ begin
+ return
+ D_TSD.Access_Level = A_TSD.Access_Level
+ and then (CW_Membership (Descendant, Ancestor)
+ or else IW_Membership (D_TSD, Ancestor));
+ end;
+ end if;
end Is_Descendant_At_Same_Level;
------------
diff --git a/gcc/ada/a-tasatt.adb b/gcc/ada/a-tasatt.adb
index e0ef9b22fb..1eb7d59271 100644
--- a/gcc/ada/a-tasatt.adb
+++ b/gcc/ada/a-tasatt.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -93,6 +93,11 @@ package body Ada.Task_Attributes is
function To_Attribute is new
Ada.Unchecked_Conversion (Atomic_Address, Attribute);
+ function To_Address is new
+ Ada.Unchecked_Conversion (Attribute, System.Address);
+ function To_Int is new
+ Ada.Unchecked_Conversion (Attribute, Integer);
+
pragma Warnings (On);
function To_Address is new
@@ -114,9 +119,12 @@ package body Ada.Task_Attributes is
Ada.Unchecked_Deallocation (Real_Attribute, Real_Attribute_Access);
Fast_Path : constant Boolean :=
- Attribute'Size <= Atomic_Address'Size
+ (Attribute'Size = Integer'Size
+ and then Attribute'Alignment <= Atomic_Address'Alignment
+ and then To_Int (Initial_Value) = 0)
+ or else (Attribute'Size = System.Address'Size
and then Attribute'Alignment <= Atomic_Address'Alignment
- and then To_Address (Initial_Value) = 0;
+ and then To_Address (Initial_Value) = System.Null_Address);
-- If the attribute fits in an Atomic_Address (both size and alignment)
-- and Initial_Value is 0 (or null), then we will map the attribute
-- directly into ATCB.Attributes (Index), otherwise we will create
diff --git a/gcc/ada/a-tasatt.ads b/gcc/ada/a-tasatt.ads
index a3e1f0eddc..857cdd7956 100644
--- a/gcc/ada/a-tasatt.ads
+++ b/gcc/ada/a-tasatt.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2016, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -42,8 +42,9 @@ generic
package Ada.Task_Attributes is
-- Note that this package will use an efficient implementation with no
- -- locks and no extra dynamic memory allocation if Attribute can fit in a
- -- System.Address type, and Initial_Value is 0 (null for an access type).
+ -- locks and no extra dynamic memory allocation if Attribute is the size
+ -- of either Integer or System.Address, and Initial_Value is 0 (null for
+ -- an access type).
-- Other types and initial values are supported, but will require
-- the use of locking and a level of indirection (meaning extra dynamic
diff --git a/gcc/ada/a-taside.ads b/gcc/ada/a-taside.ads
index ee39ec3e5a..72467bf66d 100644
--- a/gcc/ada/a-taside.ads
+++ b/gcc/ada/a-taside.ads
@@ -40,7 +40,8 @@ package Ada.Task_Identification with
SPARK_Mode,
Abstract_State => (Tasking_State with Synchronous,
External => (Async_Readers,
- Async_Writers))
+ Async_Writers)),
+ Initializes => Tasking_State
is
pragma Preelaborate;
-- In accordance with Ada 2005 AI-362
diff --git a/gcc/ada/a-teioed.adb b/gcc/ada/a-teioed.adb
index 734917940f..3c3e874f0d 100644
--- a/gcc/ada/a-teioed.adb
+++ b/gcc/ada/a-teioed.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -69,7 +69,6 @@ package body Ada.Text_IO.Editing is
loop
case Picture (Picture_Index) is
-
when '(' =>
Int_IO.Get
(Picture (Picture_Index + 1 .. Picture'Last), Count, Last);
@@ -107,7 +106,6 @@ package body Ada.Text_IO.Editing is
Result (Result_Index) := Picture (Picture_Index);
Picture_Index := Picture_Index + 1;
Result_Index := Result_Index + 1;
-
end case;
exit when Picture_Index > Picture'Last;
@@ -219,7 +217,6 @@ package body Ada.Text_IO.Editing is
exit when Answer (Last) = '9';
case Answer (Last) is
-
when '_' =>
Answer (Last) := Separator_Character;
@@ -228,7 +225,6 @@ package body Ada.Text_IO.Editing is
when others =>
null;
-
end case;
exit when Last = Answer'Last;
@@ -248,7 +244,6 @@ package body Ada.Text_IO.Editing is
end if;
case Answer (J) is
-
when '_' =>
Answer (J) := Separator_Character;
@@ -260,7 +255,6 @@ package body Ada.Text_IO.Editing is
when others =>
null;
-
end case;
end loop;
@@ -442,7 +436,6 @@ package body Ada.Text_IO.Editing is
for J in reverse Pic.Start_Float .. Position loop
case Answer (J) is
-
when '*' =>
Answer (J) := Fill_Character;
@@ -472,9 +465,7 @@ package body Ada.Text_IO.Editing is
end if;
when '_' =>
-
case Pic.Floater is
-
when '*' =>
Answer (J) := Fill_Character;
@@ -492,12 +483,10 @@ package body Ada.Text_IO.Editing is
when others =>
null;
-
end case;
when others =>
null;
-
end case;
end loop;
@@ -528,13 +517,11 @@ package body Ada.Text_IO.Editing is
when others =>
raise Picture_Error;
-
end case;
else -- positive
case Answer (Sign_Position) is
-
when '-' =>
Answer (Sign_Position) := ' ';
@@ -547,7 +534,6 @@ package body Ada.Text_IO.Editing is
when others =>
raise Picture_Error;
-
end case;
end if;
end if;
@@ -580,7 +566,6 @@ package body Ada.Text_IO.Editing is
elsif Answer (J) = '_' then
Answer (J) := Separator_Character;
-
end if;
Last := J + 1;
@@ -668,7 +653,6 @@ package body Ada.Text_IO.Editing is
Currency_Pos := Currency_Pos + 1;
case Pic.Floater is
-
when '*' =>
Answer (J) := Fill_Character;
@@ -685,12 +669,10 @@ package body Ada.Text_IO.Editing is
when others =>
null;
-
end case;
when others =>
exit;
-
end case;
end loop;
@@ -855,7 +837,6 @@ package body Ada.Text_IO.Editing is
begin
for J in Str'Range loop
case Str (J) is
-
when ' ' =>
null; -- ignore
@@ -1094,7 +1075,6 @@ package body Ada.Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@@ -1181,7 +1161,6 @@ package body Ada.Text_IO.Editing is
end if;
case Look is
-
when '-' =>
Pic.Max_Trailing_Digits :=
Pic.Max_Trailing_Digits + 1;
@@ -1197,7 +1176,6 @@ package body Ada.Text_IO.Editing is
when others =>
return;
-
end case;
end loop;
@@ -1264,7 +1242,6 @@ package body Ada.Text_IO.Editing is
end if;
case Look is
-
when '+' =>
Pic.Max_Trailing_Digits :=
Pic.Max_Trailing_Digits + 1;
@@ -1280,7 +1257,6 @@ package body Ada.Text_IO.Editing is
when others =>
return;
-
end case;
end loop;
@@ -1292,7 +1268,6 @@ package body Ada.Text_IO.Editing is
when others =>
return;
-
end case;
end loop;
end Floating_Plus;
@@ -1308,14 +1283,15 @@ package body Ada.Text_IO.Editing is
end if;
case Pic.Picture.Expanded (Index) is
-
- when '_' | '0' | '/' => return True;
+ when '_' | '0' | '/' =>
+ return True;
when 'B' | 'b' =>
Pic.Picture.Expanded (Index) := 'b'; -- canonical
return True;
- when others => return False;
+ when others =>
+ return False;
end case;
end Is_Insert;
@@ -1362,7 +1338,6 @@ package body Ada.Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@@ -1438,7 +1413,6 @@ package body Ada.Text_IO.Editing is
when others =>
return;
-
end case;
end loop;
end Leading_Dollar;
@@ -1499,7 +1473,6 @@ package body Ada.Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Inserts := True;
@@ -1605,7 +1578,6 @@ package body Ada.Text_IO.Editing is
Debug_Start ("Number");
loop
-
case Look is
when '_' | '0' | '/' =>
Skip;
@@ -1628,7 +1600,6 @@ package body Ada.Text_IO.Editing is
when others =>
return;
-
end case;
if At_End then
@@ -1650,7 +1621,6 @@ package body Ada.Text_IO.Editing is
while not At_End loop
case Look is
-
when '_' | '0' | '/' =>
Skip;
@@ -1725,8 +1695,8 @@ package body Ada.Text_IO.Editing is
end if;
case Look is
-
- when '_' | '0' | '/' => Skip;
+ when '_' | '0' | '/' =>
+ Skip;
when 'B' | 'b' =>
Pic.Picture.Expanded (Index) := 'b';
@@ -1837,7 +1807,6 @@ package body Ada.Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
@@ -1856,7 +1825,6 @@ package body Ada.Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
@@ -1872,14 +1840,12 @@ package body Ada.Text_IO.Editing is
when others =>
return;
-
end case;
end loop;
when others =>
Number_Fraction;
return;
-
end case;
end loop;
end Number_Fraction_Or_Pound;
@@ -1898,7 +1864,6 @@ package body Ada.Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
@@ -1918,7 +1883,6 @@ package body Ada.Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
@@ -1941,7 +1905,6 @@ package body Ada.Text_IO.Editing is
when others =>
Number_Fraction;
return;
-
end case;
end loop;
end Number_Fraction_Or_Star_Fill;
@@ -1960,7 +1923,6 @@ package body Ada.Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
@@ -1981,7 +1943,6 @@ package body Ada.Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
@@ -2022,7 +1983,6 @@ package body Ada.Text_IO.Editing is
end if;
case Look is
-
when '+' | '-' =>
Pic.Sign_Position := Index;
Skip;
@@ -2071,7 +2031,6 @@ package body Ada.Text_IO.Editing is
when others =>
return;
-
end case;
end Optional_RHS_Sign;
@@ -2094,7 +2053,6 @@ package body Ada.Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
@@ -2125,7 +2083,6 @@ package body Ada.Text_IO.Editing is
when others =>
return;
-
end case;
end loop;
end Picture;
@@ -2153,7 +2110,6 @@ package body Ada.Text_IO.Editing is
loop
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@@ -2197,7 +2153,6 @@ package body Ada.Text_IO.Editing is
when others =>
raise Picture_Error;
-
end case;
end loop;
end Picture_Bracket;
@@ -2225,7 +2180,6 @@ package body Ada.Text_IO.Editing is
loop
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@@ -2283,7 +2237,6 @@ package body Ada.Text_IO.Editing is
when others =>
return;
-
end case;
end loop;
end Picture_Minus;
@@ -2310,7 +2263,6 @@ package body Ada.Text_IO.Editing is
loop
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@@ -2377,7 +2329,6 @@ package body Ada.Text_IO.Editing is
when others =>
return;
-
end case;
end loop;
end Picture_Plus;
@@ -2395,7 +2346,6 @@ package body Ada.Text_IO.Editing is
end loop;
case Look is
-
when '$' | '#' =>
Picture;
Optional_RHS_Sign;
@@ -2427,7 +2377,6 @@ package body Ada.Text_IO.Editing is
when others =>
raise Picture_Error;
-
end case;
-- Blank when zero either if the PIC does not contain a '9' or if
@@ -2444,7 +2393,6 @@ package body Ada.Text_IO.Editing is
if not At_End then
Set_State (Reject);
end if;
-
end Picture_String;
---------------
@@ -2509,7 +2457,6 @@ package body Ada.Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@@ -2546,7 +2493,8 @@ package body Ada.Text_IO.Editing is
Set_State (Okay);
return;
- when others => raise Picture_Error;
+ when others =>
+ raise Picture_Error;
end case;
end loop;
end Star_Suppression;
@@ -2601,13 +2549,15 @@ package body Ada.Text_IO.Editing is
end if;
case Look is
- when '_' | '0' | '/' => Skip;
+ when '_' | '0' | '/' =>
+ Skip;
when 'B' | 'b' =>
Pic.Picture.Expanded (Index) := 'b';
Skip;
- when others => return;
+ when others =>
+ return;
end case;
end loop;
end Trailing_Currency;
diff --git a/gcc/ada/a-textio.adb b/gcc/ada/a-textio.adb
index 6a2108acad..f9219e3b3a 100644
--- a/gcc/ada/a-textio.adb
+++ b/gcc/ada/a-textio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -704,9 +704,6 @@ package body Ada.Text_IO is
end Get_Line;
function Get_Line (File : File_Type) return String is
- Buffer : String (1 .. 500);
- Last : Natural;
-
function Get_Rest (S : String) return String;
-- This is a recursive function that reads the rest of the line and
-- returns it. S is the part read so far.
@@ -717,11 +714,12 @@ package body Ada.Text_IO is
function Get_Rest (S : String) return String is
- -- Each time we allocate a buffer the same size as what we have
- -- read so far. This limits us to a logarithmic number of calls
- -- to Get_Rest and also ensures only a linear use of stack space.
+ -- The first time we allocate a buffer of size 500. Each following
+ -- time we allocate a buffer the same size as what we have read so
+ -- far. This limits us to a logarithmic number of calls to Get_Rest
+ -- and also ensures only a linear use of stack space.
- Buffer : String (1 .. S'Length);
+ Buffer : String (1 .. Integer'Max (500, S'Length));
Last : Natural;
begin
@@ -732,8 +730,20 @@ package body Ada.Text_IO is
begin
if Last < Buffer'Last then
return R;
+
else
- return Get_Rest (R);
+ pragma Assert (Last = Buffer'Last);
+
+ -- If the String has the same length as the buffer, and there
+ -- is no end of line, check whether we are at the end of file,
+ -- in which case we have the full String in the buffer.
+
+ if End_Of_File (File) then
+ return R;
+
+ else
+ return Get_Rest (R);
+ end if;
end if;
end;
end Get_Rest;
@@ -741,13 +751,7 @@ package body Ada.Text_IO is
-- Start of processing for Get_Line
begin
- Get_Line (File, Buffer, Last);
-
- if Last < Buffer'Last then
- return Buffer (1 .. Last);
- else
- return Get_Rest (Buffer (1 .. Last));
- end if;
+ return Get_Rest ("");
end Get_Line;
function Get_Line return String is
diff --git a/gcc/ada/a-tigeli.adb b/gcc/ada/a-tigeli.adb
index 8273b05077..f7cb533275 100644
--- a/gcc/ada/a-tigeli.adb
+++ b/gcc/ada/a-tigeli.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -120,10 +120,15 @@ is
K : Natural := Natural (P - S);
begin
- -- Now Buf (K + 2) should be 0, or otherwise Buf (K) is the 0
- -- put in by fgets, so compensate.
+ -- If K + 2 is greater than N, then Buf (K + 1) cannot be a LM
+ -- character from the source file, as the call to fgets copied at
+ -- most N - 1 characters. Otherwise, either LM is a character from
+ -- the source file and then Buf (K + 2) should be 0, or LM is a
+ -- character put in Buf by memset and then Buf (K) is the 0 put in
+ -- by fgets. In both cases where LM does not come from the source
+ -- file, compensate.
- if K + 2 > Buf'Last or else Buf (K + 2) /= ASCII.NUL then
+ if K + 2 > N or else Buf (K + 2) /= ASCII.NUL then
-- Incomplete last line, so remove the extra 0
@@ -145,6 +150,12 @@ is
begin
FIO.Check_Read_Status (AP (File));
+ -- Set Last to Item'First - 1 when no characters are read, as mandated by
+ -- Ada RM. In the case where Item'First is negative or null, this results
+ -- in Constraint_Error being raised.
+
+ Last := Item'First - 1;
+
-- Immediate exit for null string, this is a case in which we do not
-- need to test for end of file and we do not skip a line mark under
-- any circumstances.
@@ -155,8 +166,6 @@ begin
N := Item'Last - Item'First + 1;
- Last := Item'First - 1;
-
-- Here we have at least one character, if we are immediately before
-- a line mark, then we will just skip past it storing no characters.
@@ -187,8 +196,13 @@ begin
-- If we get EOF after already reading data, this is an incomplete
-- last line, in which case no End_Error should be raised.
- if ch = EOF and then Last < Item'First then
- raise End_Error;
+ if ch = EOF then
+ if Last < Item'First then
+ raise End_Error;
+
+ else -- All done
+ return;
+ end if;
elsif ch /= LM then
diff --git a/gcc/ada/a-unccon.ads b/gcc/ada/a-unccon.ads
index ffa84d9fad..a3b4318d1c 100644
--- a/gcc/ada/a-unccon.ads
+++ b/gcc/ada/a-unccon.ads
@@ -19,5 +19,6 @@ generic
function Ada.Unchecked_Conversion (S : Source) return Target;
+pragma No_Elaboration_Code_All (Unchecked_Conversion);
pragma Pure (Unchecked_Conversion);
pragma Import (Intrinsic, Unchecked_Conversion);
diff --git a/gcc/ada/a-wtedit.adb b/gcc/ada/a-wtedit.adb
index 4524f7ff6c..32d62b9708 100644
--- a/gcc/ada/a-wtedit.adb
+++ b/gcc/ada/a-wtedit.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -210,7 +210,6 @@ package body Ada.Wide_Text_IO.Editing is
loop
case Picture (Picture_Index) is
-
when '(' =>
-- We now need to scan out the count after a left paren. In
@@ -275,7 +274,6 @@ package body Ada.Wide_Text_IO.Editing is
Result (Result_Index) := Picture (Picture_Index);
Picture_Index := Picture_Index + 1;
Result_Index := Result_Index + 1;
-
end case;
exit when Picture_Index > Picture'Last;
@@ -390,7 +388,6 @@ package body Ada.Wide_Text_IO.Editing is
exit when Answer (Last) = '9';
case Answer (Last) is
-
when '_' =>
Answer (Last) := Separator_Character;
@@ -399,7 +396,6 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
null;
-
end case;
exit when Last = Answer'Last;
@@ -419,7 +415,6 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Answer (J) is
-
when '_' =>
Answer (J) := Separator_Character;
@@ -431,7 +426,6 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
null;
-
end case;
end loop;
@@ -613,7 +607,6 @@ package body Ada.Wide_Text_IO.Editing is
for J in reverse Pic.Start_Float .. Position loop
case Answer (J) is
-
when '*' =>
Answer (J) := Fill_Character;
@@ -635,9 +628,7 @@ package body Ada.Wide_Text_IO.Editing is
end if;
when '_' =>
-
case Pic.Floater is
-
when '*' =>
Answer (J) := Fill_Character;
@@ -655,12 +646,10 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
null;
-
end case;
when others =>
null;
-
end case;
end loop;
@@ -691,13 +680,11 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
raise Picture_Error;
-
end case;
else -- positive
case Answer (Sign_Position) is
-
when '-' =>
Answer (Sign_Position) := ' ';
@@ -710,7 +697,6 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
raise Picture_Error;
-
end case;
end if;
end if;
@@ -724,7 +710,6 @@ package body Ada.Wide_Text_IO.Editing is
Last := Pic.Radix_Position + 1;
for J in Last .. Answer'Last loop
-
if Answer (J) = '9' or else Answer (J) = Pic.Floater then
Answer (J) := To_Wide (Rounded (Position));
@@ -821,7 +806,6 @@ package body Ada.Wide_Text_IO.Editing is
end if;
when '_' =>
-
case Pic.Floater is
when '*' =>
@@ -840,12 +824,10 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
null;
-
end case;
when others =>
exit;
-
end case;
end loop;
@@ -1013,7 +995,6 @@ package body Ada.Wide_Text_IO.Editing is
begin
for J in Str'Range loop
case Str (J) is
-
when ' ' =>
null; -- ignore
@@ -1188,7 +1169,6 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@@ -1219,7 +1199,7 @@ package body Ada.Wide_Text_IO.Editing is
return;
when others =>
- return;
+ return;
end case;
end loop;
end Floating_Bracket;
@@ -1273,7 +1253,6 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Look is
-
when '-' =>
Pic.Max_Trailing_Digits :=
Pic.Max_Trailing_Digits + 1;
@@ -1289,7 +1268,6 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
return;
-
end case;
end loop;
@@ -1354,7 +1332,6 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Look is
-
when '+' =>
Pic.Max_Trailing_Digits :=
Pic.Max_Trailing_Digits + 1;
@@ -1370,7 +1347,6 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
return;
-
end case;
end loop;
@@ -1382,7 +1358,6 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
return;
-
end case;
end loop;
end Floating_Plus;
@@ -1398,14 +1373,15 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Pic.Picture.Expanded (Index) is
-
- when '_' | '0' | '/' => return True;
+ when '_' | '0' | '/' =>
+ return True;
when 'B' | 'b' =>
Pic.Picture.Expanded (Index) := 'b'; -- canonical
return True;
- when others => return False;
+ when others =>
+ return False;
end case;
end Is_Insert;
@@ -1441,7 +1417,6 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@@ -1513,7 +1488,6 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
return;
-
end case;
end loop;
end Leading_Dollar;
@@ -1565,7 +1539,6 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Inserts := True;
@@ -1666,7 +1639,6 @@ package body Ada.Wide_Text_IO.Editing is
procedure Number is
begin
loop
-
case Look is
when '_' | '0' | '/' =>
Skip;
@@ -1689,7 +1661,6 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
return;
-
end case;
if At_End then
@@ -1709,7 +1680,6 @@ package body Ada.Wide_Text_IO.Editing is
begin
while not At_End loop
case Look is
-
when '_' | '0' | '/' =>
Skip;
@@ -1780,8 +1750,8 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Look is
-
- when '_' | '0' | '/' => Skip;
+ when '_' | '0' | '/' =>
+ Skip;
when 'B' | 'b' =>
Pic.Picture.Expanded (Index) := 'b';
@@ -1890,7 +1860,6 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
@@ -1909,7 +1878,6 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
@@ -1925,14 +1893,12 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
return;
-
end case;
end loop;
when others =>
Number_Fraction;
return;
-
end case;
end loop;
end Number_Fraction_Or_Pound;
@@ -1949,7 +1915,6 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
@@ -1969,7 +1934,6 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
@@ -1992,7 +1956,6 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
Number_Fraction;
return;
-
end case;
end loop;
end Number_Fraction_Or_Star_Fill;
@@ -2009,7 +1972,6 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
@@ -2030,7 +1992,6 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
@@ -2069,7 +2030,6 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Look is
-
when '+' | '-' =>
Pic.Sign_Position := Index;
Skip;
@@ -2118,7 +2078,6 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
return;
-
end case;
end Optional_RHS_Sign;
@@ -2139,7 +2098,6 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
@@ -2170,7 +2128,6 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
return;
-
end case;
end loop;
end Picture;
@@ -2197,7 +2154,6 @@ package body Ada.Wide_Text_IO.Editing is
loop
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@@ -2241,7 +2197,6 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
raise Picture_Error;
-
end case;
end loop;
end Picture_Bracket;
@@ -2267,7 +2222,6 @@ package body Ada.Wide_Text_IO.Editing is
loop
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@@ -2325,7 +2279,6 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
return;
-
end case;
end loop;
end Picture_Minus;
@@ -2351,7 +2304,6 @@ package body Ada.Wide_Text_IO.Editing is
loop
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@@ -2413,7 +2365,6 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
return;
-
end case;
end loop;
end Picture_Plus;
@@ -2429,7 +2380,6 @@ package body Ada.Wide_Text_IO.Editing is
end loop;
case Look is
-
when '$' | '#' =>
Picture;
Optional_RHS_Sign;
@@ -2461,7 +2411,6 @@ package body Ada.Wide_Text_IO.Editing is
when others =>
raise Picture_Error;
-
end case;
-- Blank when zero either if the PIC does not contain a '9' or if
@@ -2478,7 +2427,6 @@ package body Ada.Wide_Text_IO.Editing is
if not At_End then
Set_State (Reject);
end if;
-
end Picture_String;
---------------
@@ -2522,7 +2470,6 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@@ -2553,7 +2500,8 @@ package body Ada.Wide_Text_IO.Editing is
Set_State (Okay);
return;
- when others => raise Picture_Error;
+ when others =>
+ raise Picture_Error;
end case;
end loop;
end Star_Suppression;
@@ -2604,13 +2552,15 @@ package body Ada.Wide_Text_IO.Editing is
end if;
case Look is
- when '_' | '0' | '/' => Skip;
+ when '_' | '0' | '/' =>
+ Skip;
when 'B' | 'b' =>
Pic.Picture.Expanded (Index) := 'b';
Skip;
- when others => return;
+ when others =>
+ return;
end case;
end loop;
end Trailing_Currency;
@@ -2693,7 +2643,6 @@ package body Ada.Wide_Text_IO.Editing is
-- To deal with special cases like null strings
raise Picture_Error;
-
end Precalculate;
----------------
diff --git a/gcc/ada/a-wtenau.adb b/gcc/ada/a-wtenau.adb
index d09306bb75..709703e95a 100644
--- a/gcc/ada/a-wtenau.adb
+++ b/gcc/ada/a-wtenau.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -307,8 +307,6 @@ package body Ada.Wide_Text_IO.Enumeration_Aux is
and then
not Is_Letter (To_Character (WC))
and then
- not Is_Letter (To_Character (WC))
- and then
(WC /= '_' or else From (Stop - 1) = '_');
Stop := Stop + 1;
diff --git a/gcc/ada/a-ztedit.adb b/gcc/ada/a-ztedit.adb
index 5c7c9b4c3d..bc759e05bb 100644
--- a/gcc/ada/a-ztedit.adb
+++ b/gcc/ada/a-ztedit.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -211,7 +211,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
loop
case Picture (Picture_Index) is
-
when '(' =>
-- We now need to scan out the count after a left paren. In
@@ -276,7 +275,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
Result (Result_Index) := Picture (Picture_Index);
Picture_Index := Picture_Index + 1;
Result_Index := Result_Index + 1;
-
end case;
exit when Picture_Index > Picture'Last;
@@ -391,7 +389,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
exit when Answer (Last) = '9';
case Answer (Last) is
-
when '_' =>
Answer (Last) := Separator_Character;
@@ -400,7 +397,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
null;
-
end case;
exit when Last = Answer'Last;
@@ -420,7 +416,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Answer (J) is
-
when '_' =>
Answer (J) := Separator_Character;
@@ -432,7 +427,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
null;
-
end case;
end loop;
@@ -614,7 +608,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
for J in reverse Pic.Start_Float .. Position loop
case Answer (J) is
-
when '*' =>
Answer (J) := Fill_Character;
@@ -636,9 +629,7 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
when '_' =>
-
case Pic.Floater is
-
when '*' =>
Answer (J) := Fill_Character;
@@ -656,12 +647,10 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
null;
-
end case;
when others =>
null;
-
end case;
end loop;
@@ -692,13 +681,11 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
raise Picture_Error;
-
end case;
else -- positive
case Answer (Sign_Position) is
-
when '-' =>
Answer (Sign_Position) := ' ';
@@ -711,7 +698,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
raise Picture_Error;
-
end case;
end if;
end if;
@@ -719,13 +705,11 @@ package body Ada.Wide_Wide_Text_IO.Editing is
-- Fill in trailing digits
if Pic.Max_Trailing_Digits > 0 then
-
if Attrs.Has_Fraction then
Position := Attrs.Start_Of_Fraction;
Last := Pic.Radix_Position + 1;
for J in Last .. Answer'Last loop
-
if Answer (J) = '9' or else Answer (J) = Pic.Floater then
Answer (J) := To_Wide (Rounded (Position));
@@ -745,7 +729,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
elsif Answer (J) = '_' then
Answer (J) := Separator_Character;
-
end if;
Last := J + 1;
@@ -773,7 +756,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
elsif Answer (J) = 'b' then
Answer (J) := ' ';
-
end if;
end loop;
@@ -822,9 +804,7 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
when '_' =>
-
case Pic.Floater is
-
when '*' =>
Answer (J) := Fill_Character;
@@ -841,12 +821,10 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
null;
-
end case;
when others =>
exit;
-
end case;
end loop;
@@ -931,7 +909,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
-- 9) No radix, no currency expansion
if Pic.Radix_Position /= Invalid_Position then
-
if Answer (Pic.Radix_Position) = '.' then
Answer (Pic.Radix_Position) := Radix_Point;
@@ -1014,7 +991,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
begin
for J in Str'Range loop
case Str (J) is
-
when ' ' =>
null; -- ignore
@@ -1189,7 +1165,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@@ -1220,7 +1195,7 @@ package body Ada.Wide_Wide_Text_IO.Editing is
return;
when others =>
- return;
+ return;
end case;
end loop;
end Floating_Bracket;
@@ -1274,7 +1249,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Look is
-
when '-' =>
Pic.Max_Trailing_Digits :=
Pic.Max_Trailing_Digits + 1;
@@ -1290,7 +1264,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
return;
-
end case;
end loop;
@@ -1355,7 +1328,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Look is
-
when '+' =>
Pic.Max_Trailing_Digits :=
Pic.Max_Trailing_Digits + 1;
@@ -1371,7 +1343,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
return;
-
end case;
end loop;
@@ -1383,7 +1354,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
return;
-
end case;
end loop;
end Floating_Plus;
@@ -1399,14 +1369,15 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Pic.Picture.Expanded (Index) is
-
- when '_' | '0' | '/' => return True;
+ when '_' | '0' | '/' =>
+ return True;
when 'B' | 'b' =>
Pic.Picture.Expanded (Index) := 'b'; -- canonical
return True;
- when others => return False;
+ when others =>
+ return False;
end case;
end Is_Insert;
@@ -1442,7 +1413,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@@ -1514,7 +1484,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
return;
-
end case;
end loop;
end Leading_Dollar;
@@ -1534,7 +1503,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
-- floating unless there is only one '#'.
procedure Leading_Pound is
-
Inserts : Boolean := False;
-- Set to True if a '_', '0', '/', 'B', or 'b' is encountered
@@ -1565,7 +1533,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Inserts := True;
@@ -1666,7 +1633,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
procedure Number is
begin
loop
-
case Look is
when '_' | '0' | '/' =>
Skip;
@@ -1709,7 +1675,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
begin
while not At_End loop
case Look is
-
when '_' | '0' | '/' =>
Skip;
@@ -1780,8 +1745,8 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Look is
-
- when '_' | '0' | '/' => Skip;
+ when '_' | '0' | '/' =>
+ Skip;
when 'B' | 'b' =>
Pic.Picture.Expanded (Index) := 'b';
@@ -1890,7 +1855,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
@@ -1909,7 +1873,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
@@ -1925,14 +1888,12 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
return;
-
end case;
end loop;
when others =>
Number_Fraction;
return;
-
end case;
end loop;
end Number_Fraction_Or_Pound;
@@ -1949,7 +1910,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
@@ -1969,7 +1929,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
@@ -1992,7 +1951,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
Number_Fraction;
return;
-
end case;
end loop;
end Number_Fraction_Or_Star_Fill;
@@ -2009,7 +1967,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
@@ -2030,7 +1987,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
@@ -2069,7 +2025,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Look is
-
when '+' | '-' =>
Pic.Sign_Position := Index;
Skip;
@@ -2118,7 +2073,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
return;
-
end case;
end Optional_RHS_Sign;
@@ -2139,7 +2093,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Skip;
@@ -2170,7 +2123,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
return;
-
end case;
end loop;
end Picture;
@@ -2197,7 +2149,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
loop
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@@ -2241,7 +2192,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
raise Picture_Error;
-
end case;
end loop;
end Picture_Bracket;
@@ -2267,7 +2217,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
loop
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@@ -2325,7 +2274,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
return;
-
end case;
end loop;
end Picture_Minus;
@@ -2351,7 +2299,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
loop
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@@ -2413,7 +2360,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
return;
-
end case;
end loop;
end Picture_Plus;
@@ -2429,7 +2375,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end loop;
case Look is
-
when '$' | '#' =>
Picture;
Optional_RHS_Sign;
@@ -2461,7 +2406,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
when others =>
raise Picture_Error;
-
end case;
-- Blank when zero either if the PIC does not contain a '9' or if
@@ -2478,7 +2422,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
if not At_End then
Set_State (Reject);
end if;
-
end Picture_String;
---------------
@@ -2522,7 +2465,6 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Look is
-
when '_' | '0' | '/' =>
Pic.End_Float := Index;
Skip;
@@ -2553,7 +2495,8 @@ package body Ada.Wide_Wide_Text_IO.Editing is
Set_State (Okay);
return;
- when others => raise Picture_Error;
+ when others =>
+ raise Picture_Error;
end case;
end loop;
end Star_Suppression;
@@ -2604,13 +2547,15 @@ package body Ada.Wide_Wide_Text_IO.Editing is
end if;
case Look is
- when '_' | '0' | '/' => Skip;
+ when '_' | '0' | '/' =>
+ Skip;
when 'B' | 'b' =>
Pic.Picture.Expanded (Index) := 'b';
Skip;
- when others => return;
+ when others =>
+ return;
end case;
end loop;
end Trailing_Currency;
diff --git a/gcc/ada/aa_util.adb b/gcc/ada/aa_util.adb
deleted file mode 100644
index 6ea4421f57..0000000000
--- a/gcc/ada/aa_util.adb
+++ /dev/null
@@ -1,458 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAAMP COMPILER COMPONENTS --
--- --
--- A A _ U T I L --
--- --
--- B o d y --
--- --
--- Copyright (C) 2001-2012, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
-------------------------------------------------------------------------------
-
-with Sem_Aux; use Sem_Aux;
-with Sinput; use Sinput;
-with Stand; use Stand;
-with Stringt; use Stringt;
-
-with GNAT.Case_Util; use GNAT.Case_Util;
-
-package body AA_Util is
-
- ----------------------
- -- Is_Global_Entity --
- ----------------------
-
- function Is_Global_Entity (E : Entity_Id) return Boolean is
- begin
- return Enclosing_Dynamic_Scope (E) = Standard_Standard;
- end Is_Global_Entity;
-
- -----------------
- -- New_Name_Id --
- -----------------
-
- function New_Name_Id (Name : String) return Name_Id is
- begin
- for J in 1 .. Name'Length loop
- Name_Buffer (J) := Name (Name'First + (J - 1));
- end loop;
-
- Name_Len := Name'Length;
- return Name_Find;
- end New_Name_Id;
-
- -----------------
- -- Name_String --
- -----------------
-
- function Name_String (Name : Name_Id) return String is
- begin
- pragma Assert (Name /= No_Name);
- return Get_Name_String (Name);
- end Name_String;
-
- -------------------
- -- New_String_Id --
- -------------------
-
- function New_String_Id (S : String) return String_Id is
- begin
- for J in 1 .. S'Length loop
- Name_Buffer (J) := S (S'First + (J - 1));
- end loop;
-
- Name_Len := S'Length;
- return String_From_Name_Buffer;
- end New_String_Id;
-
- ------------------
- -- String_Value --
- ------------------
-
- function String_Value (Str_Id : String_Id) return String is
- begin
- -- ??? pragma Assert (Str_Id /= No_String);
-
- if Str_Id = No_String then
- return "";
- end if;
-
- String_To_Name_Buffer (Str_Id);
-
- return Name_Buffer (1 .. Name_Len);
- end String_Value;
-
- ---------------
- -- Next_Name --
- ---------------
-
- function Next_Name
- (Name_Seq : not null access Name_Sequencer;
- Name_Prefix : String) return Name_Id
- is
- begin
- Name_Seq.Sequence_Number := Name_Seq.Sequence_Number + 1;
-
- declare
- Number_Image : constant String := Name_Seq.Sequence_Number'Img;
- begin
- return New_Name_Id
- (Name_Prefix & "__" & Number_Image (2 .. Number_Image'Last));
- end;
- end Next_Name;
-
- --------------------
- -- Elab_Spec_Name --
- --------------------
-
- function Elab_Spec_Name (Module_Name : Name_Id) return Name_Id is
- begin
- return New_Name_Id (Name_String (Module_Name) & "___elabs");
- end Elab_Spec_Name;
-
- --------------------
- -- Elab_Spec_Name --
- --------------------
-
- function Elab_Body_Name (Module_Name : Name_Id) return Name_Id is
- begin
- return New_Name_Id (Name_String (Module_Name) & "___elabb");
- end Elab_Body_Name;
-
- --------------------------------
- -- Source_Name_Without_Suffix --
- --------------------------------
-
- function File_Name_Without_Suffix (File_Name : String) return String is
- Name_Index : Natural := File_Name'Last;
-
- begin
- pragma Assert (File_Name'Length > 0);
-
- -- We loop in reverse to ensure that file names that follow nonstandard
- -- naming conventions that include additional dots are handled properly,
- -- preserving dots in front of the main file suffix (for example,
- -- main.2.ada => main.2).
-
- while Name_Index >= File_Name'First
- and then File_Name (Name_Index) /= '.'
- loop
- Name_Index := Name_Index - 1;
- end loop;
-
- -- Return the part of the file name up to but not including the last dot
- -- in the name, or return the whole name as is if no dot character was
- -- found.
-
- if Name_Index >= File_Name'First then
- return File_Name (File_Name'First .. Name_Index - 1);
-
- else
- return File_Name;
- end if;
- end File_Name_Without_Suffix;
-
- -----------------
- -- Source_Name --
- -----------------
-
- function Source_Name (Sloc : Source_Ptr) return File_Name_Type is
- begin
- if Sloc = No_Location or Sloc = Standard_Location then
- return No_File;
- else
- return File_Name (Get_Source_File_Index (Sloc));
- end if;
- end Source_Name;
-
- --------------------------------
- -- Source_Name_Without_Suffix --
- --------------------------------
-
- function Source_Name_Without_Suffix (Sloc : Source_Ptr) return String is
- Src_Name : constant String :=
- Name_String (Name_Id (Source_Name (Sloc)));
- Src_Index : Natural := Src_Name'Last;
-
- begin
- pragma Assert (Src_Name'Length > 0);
-
- -- Treat the presence of a ".dg" suffix specially, stripping it off
- -- in addition to any suffix preceding it.
-
- if Src_Name'Length >= 4
- and then Src_Name (Src_Name'Last - 2 .. Src_Name'Last) = ".dg"
- then
- Src_Index := Src_Index - 3;
- end if;
-
- return File_Name_Without_Suffix (Src_Name (Src_Name'First .. Src_Index));
- end Source_Name_Without_Suffix;
-
- ----------------------
- -- Source_Id_String --
- ----------------------
-
- function Source_Id_String (Unit_Name : Name_Id) return String is
- Unit_String : String := Name_String (Unit_Name);
- Name_Last : Positive := Unit_String'Last;
- Name_Index : Positive := Unit_String'First;
-
- begin
- To_Mixed (Unit_String);
-
- -- Replace any embedded sequences of two or more '_' characters
- -- with a single '.' character. Note that this will leave any
- -- leading or trailing single '_' characters untouched, but those
- -- should normally not occur in compilation unit names (and if
- -- they do then it's better to leave them as is).
-
- while Name_Index <= Name_Last loop
- if Unit_String (Name_Index) = '_'
- and then Name_Index /= Name_Last
- and then Unit_String (Name_Index + 1) = '_'
- then
- Unit_String (Name_Index) := '.';
- Name_Index := Name_Index + 1;
-
- while Unit_String (Name_Index) = '_'
- and then Name_Index <= Name_Last
- loop
- Unit_String (Name_Index .. Name_Last - 1)
- := Unit_String (Name_Index + 1 .. Name_Last);
- Name_Last := Name_Last - 1;
- end loop;
-
- else
- Name_Index := Name_Index + 1;
- end if;
- end loop;
-
- return Unit_String (Unit_String'First .. Name_Last);
- end Source_Id_String;
-
- -- This version of Source_Id_String is obsolescent and is being
- -- replaced with the above function.
-
- function Source_Id_String (Sloc : Source_Ptr) return String is
- File_Index : Source_File_Index;
-
- begin
- -- Use an arbitrary artificial 22-character value for package Standard,
- -- since Standard doesn't have an associated source file.
-
- if Sloc <= Standard_Location then
- return "20010101010101standard";
-
- -- Return the concatentation of the source file's timestamp and
- -- its 8-digit hex checksum.
-
- else
- File_Index := Get_Source_File_Index (Sloc);
-
- return String (Time_Stamp (File_Index))
- & Get_Hex_String (Source_Checksum (File_Index));
- end if;
- end Source_Id_String;
-
- ---------------
- -- Source_Id --
- ---------------
-
- function Source_Id (Unit_Name : Name_Id) return String_Id is
- begin
- return New_String_Id (Source_Id_String (Unit_Name));
- end Source_Id;
-
- -- This version of Source_Id is obsolescent and is being
- -- replaced with the above function.
-
- function Source_Id (Sloc : Source_Ptr) return String_Id is
- begin
- return New_String_Id (Source_Id_String (Sloc));
- end Source_Id;
-
- -----------
- -- Image --
- -----------
-
- function Image (I : Int) return String is
- Image_String : constant String := Pos'Image (I);
- begin
- if Image_String (1) = ' ' then
- return Image_String (2 .. Image_String'Last);
- else
- return Image_String;
- end if;
- end Image;
-
- --------------
- -- UI_Image --
- --------------
-
- function UI_Image (I : Uint; Format : Integer_Image_Format) return String is
- begin
- if Format = Decimal then
- UI_Image (I, Format => Decimal);
- return UI_Image_Buffer (1 .. UI_Image_Length);
-
- elsif Format = Ada_Hex then
- UI_Image (I, Format => Hex);
- return UI_Image_Buffer (1 .. UI_Image_Length);
-
- else
- pragma Assert (I >= Uint_0);
-
- UI_Image (I, Format => Hex);
-
- pragma Assert (UI_Image_Buffer (1 .. 3) = "16#"
- and then UI_Image_Buffer (UI_Image_Length) = '#');
-
- -- Declare a string where we will copy the digits from the UI_Image,
- -- interspersing '_' characters as 4-digit group separators. The
- -- underscores in UI_Image's result are not always at the places
- -- where we want them, which is why we do the following copy
- -- (e.g., we map "16#ABCD_EF#" to "^AB_CDEF^").
-
- declare
- Hex_String : String (1 .. UI_Image_Max);
- Last_Index : Natural;
- Digit_Count : Natural := 0;
- UI_Image_Index : Natural := 4; -- Skip past the "16#" bracket
- Sep_Count : Natural := 0;
-
- begin
- -- Count up the number of non-underscore characters in the
- -- literal value portion of the UI_Image string.
-
- while UI_Image_Buffer (UI_Image_Index) /= '#' loop
- if UI_Image_Buffer (UI_Image_Index) /= '_' then
- Digit_Count := Digit_Count + 1;
- end if;
-
- UI_Image_Index := UI_Image_Index + 1;
- end loop;
-
- UI_Image_Index := 4; -- Reset the index past the "16#" bracket
-
- Last_Index := 1;
-
- Hex_String (Last_Index) := '^';
- Last_Index := Last_Index + 1;
-
- -- Copy digits from UI_Image_Buffer to Hex_String, adding
- -- underscore separators as appropriate. The initial value
- -- of Sep_Count accounts for the leading '^' and being one
- -- character ahead after inserting a digit.
-
- Sep_Count := 2;
-
- while UI_Image_Buffer (UI_Image_Index) /= '#' loop
- if UI_Image_Buffer (UI_Image_Index) /= '_' then
- Hex_String (Last_Index) := UI_Image_Buffer (UI_Image_Index);
-
- Last_Index := Last_Index + 1;
-
- -- Add '_' characters to separate groups of four hex
- -- digits for readability (grouping from right to left).
-
- if (Digit_Count - (Last_Index - Sep_Count)) mod 4 = 0 then
- Hex_String (Last_Index) := '_';
- Last_Index := Last_Index + 1;
- Sep_Count := Sep_Count + 1;
- end if;
- end if;
-
- UI_Image_Index := UI_Image_Index + 1;
- end loop;
-
- -- Back up before any trailing underscore
-
- if Hex_String (Last_Index - 1) = '_' then
- Last_Index := Last_Index - 1;
- end if;
-
- Hex_String (Last_Index) := '^';
-
- return Hex_String (1 .. Last_Index);
- end;
- end if;
- end UI_Image;
-
- --------------
- -- UR_Image --
- --------------
-
- -- Shouldn't this be added to Urealp???
-
- function UR_Image (R : Ureal) return String is
-
- -- The algorithm used here for conversion of Ureal values
- -- is taken from the JGNAT back end.
-
- Num : Long_Long_Float := 0.0;
- Den : Long_Long_Float := 0.0;
- Sign : Long_Long_Float := 1.0;
- Result : Long_Long_Float;
- Tmp : Uint;
- Index : Integer;
-
- begin
- if UR_Is_Negative (R) then
- Sign := -1.0;
- end if;
-
- -- In the following calculus, we consider numbers modulo 2 ** 31,
- -- so that we don't have problems with signed Int...
-
- Tmp := abs (Numerator (R));
- Index := 0;
- while Tmp > 0 loop
- Num := Num
- + Long_Long_Float (UI_To_Int (Tmp mod (Uint_2 ** 31)))
- * (2.0 ** Index);
- Tmp := Tmp / Uint_2 ** 31;
- Index := Index + 31;
- end loop;
-
- Tmp := abs (Denominator (R));
- if Rbase (R) /= 0 then
- Tmp := Rbase (R) ** Tmp;
- end if;
-
- Index := 0;
- while Tmp > 0 loop
- Den := Den
- + Long_Long_Float (UI_To_Int (Tmp mod (Uint_2 ** 31)))
- * (2.0 ** Index);
- Tmp := Tmp / Uint_2 ** 31;
- Index := Index + 31;
- end loop;
-
- -- If the denominator denotes a negative power of Rbase,
- -- then multiply by the denominator.
-
- if Rbase (R) /= 0 and then Denominator (R) < 0 then
- Result := Sign * Num * Den;
-
- -- Otherwise compute the quotient
-
- else
- Result := Sign * Num / Den;
- end if;
-
- return Long_Long_Float'Image (Result);
- end UR_Image;
-
-end AA_Util;
diff --git a/gcc/ada/aa_util.ads b/gcc/ada/aa_util.ads
deleted file mode 100644
index 27b6183248..0000000000
--- a/gcc/ada/aa_util.ads
+++ /dev/null
@@ -1,145 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAAMP COMPILER COMPONENTS --
--- --
--- A A _ U T I L --
--- --
--- S p e c --
--- --
--- Copyright (C) 2001-2011, AdaCore --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING3. If not, go to --
--- http://www.gnu.org/licenses for a complete copy of the license. --
--- --
-------------------------------------------------------------------------------
-
--- This package provides various utility operations used by GNAT back-ends
--- (e.g. AAMP).
-
--- This package is a messy grab bag of stuff. These routines should be moved
--- to appropriate units (sem_util,sem_aux,exp_util,namet,uintp,urealp). ???
-
-with Namet; use Namet;
-with Types; use Types;
-with Uintp; use Uintp;
-with Urealp; use Urealp;
-
-package AA_Util is
-
- function Is_Global_Entity (E : Entity_Id) return Boolean;
- -- Returns true if and only if E is a library-level entity (excludes
- -- entities declared within blocks at the outer level of library packages).
-
- function New_Name_Id (Name : String) return Name_Id;
- -- Returns a Name_Id corresponding to the given name string
-
- function Name_String (Name : Name_Id) return String;
- -- Returns the name string associated with Name
-
- function New_String_Id (S : String) return String_Id;
- -- Returns a String_Id corresponding to the given string
-
- function String_Value (Str_Id : String_Id) return String;
- -- Returns the string associated with Str_Id
-
- -- Name-generation utilities
-
- type Name_Sequencer is private;
- -- This type is used to support back-end generation of unique symbol
- -- (e.g., for string literal objects or labels). By declaring an
- -- aliased object of type Name_Sequence and passing that object
- -- to the function Next_Name, a series of names with suffixes
- -- of the form "__n" will be produced, where n is a string denoting
- -- a positive integer. The sequence starts with "__1", and increases
- -- by one on each successive call to Next_Name for a given Name_Sequencer.
-
- function Next_Name
- (Name_Seq : not null access Name_Sequencer;
- Name_Prefix : String) return Name_Id;
- -- Returns the Name_Id for a name composed of the given Name_Prefix
- -- concatentated with a unique number suffix of the form "__n",
- -- as detemined by the current state of Name_Seq.
-
- function Elab_Spec_Name (Module_Name : Name_Id) return Name_Id;
- -- Returns a name id for the elaboration subprogram to be associated with
- -- the specification of the named module. The denoted name is of the form
- -- "modulename___elabs".
-
- function Elab_Body_Name (Module_Name : Name_Id) return Name_Id;
- -- Returns a name id for the elaboration subprogram to be associated
- -- with the body of the named module. The denoted name is of the form
- -- "modulename___elabb".
-
- function File_Name_Without_Suffix (File_Name : String) return String;
- -- Removes the suffix ('.' followed by other characters), if present, from
- -- the end of File_Name and returns the shortened name (otherwise simply
- -- returns File_Name).
-
- function Source_Name (Sloc : Source_Ptr) return File_Name_Type;
- -- Returns file name corresponding to the source file name associated with
- -- the given source position Sloc.
-
- function Source_Name_Without_Suffix (Sloc : Source_Ptr) return String;
- -- Returns a string corresponding to the source file name associated with
- -- the given source position Sloc, with its dot-preceded suffix, if any,
- -- removed. As examples, the name "main.adb" is mapped to "main" and the
- -- name "main.2.ada" is mapped to "main.2". As a special case, file names
- -- with a ".dg" suffix will also strip off the ".dg", so "main.adb.dg"
- -- becomes simply "main".
-
- function Source_Id_String (Unit_Name : Name_Id) return String;
- -- Returns a string that uniquely identifies the unit with the given
- -- Unit_Name. This string is derived from Unit_Name by replacing any
- -- multiple underscores with dot ('.') characters and normalizing the
- -- casing to mixed case (e.g., "ada__strings" is mapped to ("Ada.Strings").
-
- function Source_Id (Unit_Name : Name_Id) return String_Id;
- -- Returns a String_Id reference to a string that uniquely identifies
- -- the program unit having the given name (as defined for function
- -- Source_Id_String).
-
- function Source_Id_String (Sloc : Source_Ptr) return String;
- -- Returns a string that uniquely identifies the source file containing
- -- the given source location. This string is constructed from the
- -- concatentation of the date and time stamp of the file with a
- -- hexadecimal check sum (e.g., "020425143059ABCDEF01").
-
- function Source_Id (Sloc : Source_Ptr) return String_Id;
- -- Returns a String_Id reference to a string that uniquely identifies the
- -- source file containing the given source location (as defined for
- -- function Source_Id_String).
-
- function Image (I : Int) return String;
- -- Returns Int'Image (I), but without a leading space in the case where
- -- I is nonnegative. Useful for concatenating integers onto other names.
-
- type Integer_Image_Format is (Decimal, Ada_Hex, AAMP_Hex);
-
- function UI_Image (I : Uint; Format : Integer_Image_Format) return String;
- -- Returns the image of the universal integer I, with no leading spaces
- -- and in the format specified. The Format parameter specifies whether
- -- the integer representation should be decimal (the default), or Ada
- -- hexadecimal (Ada_Hex => "16#xxxxx#" format), or AAMP hexadecimal.
- -- In the latter case, the integer will have the form of a sequence of
- -- hexadecimal digits bracketed by '^' characters, and will contain '_'
- -- characters as separators for groups of four hexadecimal digits
- -- (e.g., ^1C_A3CD^). If the format AAMP_Hex is selected, the universal
- -- integer must have a nonnegative value.
-
- function UR_Image (R : Ureal) return String;
- -- Returns a decimal image of the universal real value R
-
-private
-
- type Name_Sequencer is record
- Sequence_Number : Natural := 0;
- end record;
-
-end AA_Util;
diff --git a/gcc/ada/ada.ads b/gcc/ada/ada.ads
index 8c860110f9..4c2a3d00e5 100644
--- a/gcc/ada/ada.ads
+++ b/gcc/ada/ada.ads
@@ -14,6 +14,7 @@
------------------------------------------------------------------------------
package Ada is
+ pragma No_Elaboration_Code_All;
pragma Pure;
end Ada;
diff --git a/gcc/ada/adabkend.adb b/gcc/ada/adabkend.adb
index 5bf4f748bf..7eee887901 100644
--- a/gcc/ada/adabkend.adb
+++ b/gcc/ada/adabkend.adb
@@ -1,12 +1,12 @@
------------------------------------------------------------------------------
-- --
--- GNAAMP COMPILER COMPONENTS --
+-- GNAT COMPILER COMPONENTS --
-- --
-- A D A B K E N D --
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2015, AdaCore --
+-- Copyright (C) 2001-2016, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -98,31 +98,15 @@ package body Adabkend is
-- affect code generation or falling through if it does, so the
-- switch will get stored.
- if Is_Internal_GCC_Switch (Switch_Chars) then
+ -- Skip -o, -G or internal GCC switches together with their argument.
+
+ if Switch_Chars (First .. Last) = "o"
+ or else Switch_Chars (First .. Last) = "G"
+ or else Is_Internal_GCC_Switch (Switch_Chars)
+ then
Next_Arg := Next_Arg + 1;
return; -- ignore this switch
- -- Record that an object file name has been specified. The actual
- -- file name argument is picked up and saved below by the main body
- -- of Scan_Compiler_Arguments.
-
- elsif Switch_Chars (First .. Last) = "o" then
- if First = Last then
- if Opt.Output_File_Name_Present then
-
- -- Ignore extra -o when -gnatO has already been specified
-
- Next_Arg := Next_Arg + 1;
-
- else
- Opt.Output_File_Name_Present := True;
- end if;
-
- return;
- else
- Fail ("invalid switch: " & Switch_Chars);
- end if;
-
-- Set optimization indicators appropriately. In gcc-based GNAT this
-- is picked up from imported variables set by the gcc driver, but
-- for compilers with non-gcc back ends we do it here to allow use
@@ -157,8 +141,8 @@ package body Adabkend is
return; -- ignore this switch
-- The -x switch and its language name argument will generally be
- -- ignored by non-gcc back ends (e.g. the GNAAMP back end). In any
- -- case, we save the switch and argument in the compilation switches.
+ -- ignored by non-gcc back ends. In any case, we save the switch and
+ -- argument in the compilation switches.
elsif Switch_Chars (First .. Last) = "x" then
Lib.Store_Compilation_Switch (Switch_Chars);
@@ -244,16 +228,6 @@ package body Adabkend is
then
if Is_Switch (Argv) then
Fail ("Object file name missing after -gnatO");
-
- -- In GNATprove_Mode, such an object file is never written, and
- -- the call to Set_Output_Object_File_Name may fail (e.g. when
- -- the object file name does not have the expected suffix).
- -- So we skip that call when GNATprove_Mode is set. Same for
- -- CodePeer_Mode.
-
- elsif GNATprove_Mode or CodePeer_Mode then
- Output_File_Name_Seen := True;
-
else
Set_Output_Object_File_Name (Argv);
Output_File_Name_Seen := True;
diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c
index 3053c69f50..bff875a682 100644
--- a/gcc/ada/adaint.c
+++ b/gcc/ada/adaint.c
@@ -112,13 +112,24 @@
extern "C" {
#endif
-#if defined (__MINGW32__) || defined (__CYGWIN__)
+#if defined (__DJGPP__)
+
+/* For isalpha-like tests in the compiler, we're expected to resort to
+ safe-ctype.h/ISALPHA. This isn't available for the runtime library
+ build, so we fallback on ctype.h/isalpha there. */
+
+#ifdef IN_RTS
+#include <ctype.h>
+#define ISALPHA isalpha
+#endif
+
+#elif defined (__MINGW32__) || defined (__CYGWIN__)
#include "mingw32.h"
/* Current code page and CCS encoding to use, set in initialize.c. */
-UINT CurrentCodePage;
-UINT CurrentCCSEncoding;
+UINT __gnat_current_codepage;
+UINT __gnat_current_ccs_encoding;
#include <sys/utime.h>
@@ -165,15 +176,21 @@ UINT CurrentCCSEncoding;
#include <sys/wait.h>
#endif
-#if defined (_WIN32)
-
+#if defined (__DJGPP__)
#include <process.h>
#include <signal.h>
#include <dir.h>
+#include <utime.h>
+#undef DIR_SEPARATOR
+#define DIR_SEPARATOR '\\'
+
+#elif defined (_WIN32)
+
#include <windows.h>
#include <accctrl.h>
#include <aclapi.h>
#include <tlhelp32.h>
+#include <signal.h>
#undef DIR_SEPARATOR
#define DIR_SEPARATOR '\\'
@@ -554,7 +571,7 @@ __gnat_get_file_names_case_sensitive (void)
{
/* By default, we suppose filesystems aren't case sensitive on
Windows and Darwin (but they are on arm-darwin). */
-#if defined (WINNT) \
+#if defined (WINNT) || defined (__DJGPP__) \
|| (defined (__APPLE__) && !(defined (__arm__) || defined (__arm64__)))
file_names_case_sensitive_cache = 0;
#else
@@ -570,7 +587,7 @@ __gnat_get_file_names_case_sensitive (void)
int
__gnat_get_env_vars_case_sensitive (void)
{
-#if defined (WINNT)
+#if defined (WINNT) || defined (__DJGPP__)
return 0;
#else
return 1;
@@ -1640,7 +1657,7 @@ __gnat_is_absolute_path (char *name, int length)
#else
return (length != 0) &&
(*name == '/' || *name == DIR_SEPARATOR
-#if defined (WINNT)
+#if defined (WINNT) || defined(__DJGPP__)
|| (length > 1 && ISALPHA (name[0]) && name[1] == ':')
#endif
);
@@ -1912,6 +1929,29 @@ __gnat_is_readable_file_attr (char* name, struct file_attributes* attr)
}
int
+__gnat_is_read_accessible_file (char *name)
+{
+#if defined (_WIN32)
+ TCHAR wname [GNAT_MAX_PATH_LEN + 2];
+
+ S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
+
+ return !_waccess (wname, 4);
+
+#elif defined (__vxworks)
+ int fd;
+
+ if ((fd = open (name, O_RDONLY, 0)) < 0)
+ return 0;
+ close (fd);
+ return 1;
+
+#else
+ return !access (name, R_OK);
+#endif
+}
+
+int
__gnat_is_readable_file (char *name)
{
struct file_attributes attr;
@@ -1962,6 +2002,29 @@ __gnat_is_writable_file (char *name)
}
int
+__gnat_is_write_accessible_file (char *name)
+{
+#if defined (_WIN32)
+ TCHAR wname [GNAT_MAX_PATH_LEN + 2];
+
+ S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
+
+ return !_waccess (wname, 2);
+
+#elif defined (__vxworks)
+ int fd;
+
+ if ((fd = open (name, O_WRONLY, 0)) < 0)
+ return 0;
+ close (fd);
+ return 1;
+
+#else
+ return !access (name, W_OK);
+#endif
+}
+
+int
__gnat_is_executable_file_attr (char* name, struct file_attributes* attr)
{
if (attr->executable == ATTR_UNSET)
@@ -2182,7 +2245,7 @@ __gnat_portable_spawn (char *args[] ATTRIBUTE_UNUSED)
#if defined (__vxworks) || defined(__PikeOS__)
return -1;
-#elif defined (_WIN32)
+#elif defined (__DJGPP__) || defined (_WIN32)
/* args[0] must be quotes as it could contain a full pathname with spaces */
char *args_0 = args[0];
args[0] = (char *)xmalloc (strlen (args_0) + 3);
@@ -2554,6 +2617,12 @@ __gnat_portable_no_block_spawn (char *args[] ATTRIBUTE_UNUSED)
/* Not supported. */
return -1;
+#elif defined(__DJGPP__)
+ if (spawnvp (P_WAIT, args[0], args) != 0)
+ return -1;
+ else
+ return 0;
+
#elif defined (_WIN32)
HANDLE h = NULL;
@@ -2597,6 +2666,9 @@ __gnat_portable_wait (int *process_status)
pid = win32_wait (&status);
+#elif defined (__DJGPP__)
+ /* Child process has already ended in case of DJGPP.
+ No need to do anything. Just return success. */
#else
pid = waitpid (-1, &status, 0);
@@ -2613,6 +2685,22 @@ __gnat_os_exit (int status)
exit (status);
}
+int
+__gnat_current_process_id (void)
+{
+#if defined (__vxworks) || defined (__PikeOS__)
+ return -1;
+
+#elif defined (_WIN32)
+
+ return (int)GetCurrentProcessId();
+
+#else
+
+ return (int)getpid();
+#endif
+}
+
/* Locate file on path, that matches a predicate */
char *
@@ -3085,6 +3173,30 @@ __gnat_lwp_self (void)
}
#endif
+#if defined (__APPLE__)
+#include <mach/thread_info.h>
+#include <mach/mach_init.h>
+#include <mach/thread_act.h>
+
+/* System-wide thread identifier. Note it could be truncated on 32 bit
+ hosts.
+ Previously was: pthread_mach_thread_np (pthread_self ()). */
+void *
+__gnat_lwp_self (void)
+{
+ thread_identifier_info_data_t data;
+ mach_msg_type_number_t count = THREAD_IDENTIFIER_INFO_COUNT;
+ kern_return_t kret;
+
+ kret = thread_info (mach_thread_self (), THREAD_IDENTIFIER_INFO,
+ (thread_info_t) &data, &count);
+ if (kret == KERN_SUCCESS)
+ return (void *)(uintptr_t)data.thread_id;
+ else
+ return 0;
+}
+#endif
+
#if defined (__linux__)
#include <sched.h>
@@ -3223,7 +3335,6 @@ __gnat_kill (int pid, int sig, int close ATTRIBUTE_UNUSED)
void __gnat_killprocesstree (int pid, int sig_num)
{
#if defined(_WIN32)
- HANDLE hWnd;
PROCESSENTRY32 pe;
memset(&pe, 0, sizeof(PROCESSENTRY32));
@@ -3247,7 +3358,7 @@ void __gnat_killprocesstree (int pid, int sig_num)
while (bContinue)
{
- if (pe.th32ParentProcessID == (int)pid)
+ if (pe.th32ParentProcessID == (DWORD)pid)
__gnat_killprocesstree (pe.th32ProcessID, sig_num);
bContinue = Process32Next (hSnap, &pe);
@@ -3285,14 +3396,16 @@ void __gnat_killprocesstree (int pid, int sig_num)
{
if ((d->d_type & DT_DIR) == DT_DIR)
{
- char statfile[64] = { 0 };
+ char statfile[64];
int _pid, _ppid;
/* read /proc/<PID>/stat */
- strncpy (statfile, "/proc/", sizeof(statfile));
- strncat (statfile, d->d_name, sizeof(statfile));
- strncat (statfile, "/stat", sizeof(statfile));
+ if (strlen (d->d_name) >= sizeof (statfile) - strlen ("/proc//stat"))
+ continue;
+ strcpy (statfile, "/proc/");
+ strcat (statfile, d->d_name);
+ strcat (statfile, "/stat");
FILE *fd = fopen (statfile, "r");
diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h
index 09fc83c5da..232b5eb437 100644
--- a/gcc/ada/adaint.h
+++ b/gcc/ada/adaint.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2015, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2016, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -67,6 +67,30 @@ extern "C" {
#define GNAT_LSTAT lstat
#define GNAT_STRUCT_STAT struct stat64
+#elif defined(__APPLE__)
+
+# include <TargetConditionals.h>
+
+# if TARGET_IPHONE_SIMULATOR
+ /* On iOS (simulator or not), the stat structure is the 64 bit one.
+ But the simulator uses the MacOS X syscalls that aren't 64 bit.
+ Fix this interfacing issue here. */
+ int fstat64(int, struct stat *);
+ int stat64(const char *, struct stat *);
+ int lstat64(const char *, struct stat *);
+# define GNAT_STAT stat64
+# define GNAT_FSTAT fstat64
+# define GNAT_LSTAT lstat64
+# else
+# define GNAT_STAT stat
+# define GNAT_FSTAT fstat
+# define GNAT_LSTAT lstat
+# endif
+
+# define GNAT_FOPEN fopen
+# define GNAT_OPEN open
+# define GNAT_STRUCT_STAT struct stat
+
#else
#define GNAT_FOPEN fopen
#define GNAT_OPEN open
@@ -84,6 +108,7 @@ typedef long OS_Time;
#endif
#define __int64 long long
+GNAT_STRUCT_STAT;
/* A lazy cache for the attributes of a file. On some systems, a single call to
stat() will give all this information, so it is better than doing a system
@@ -183,6 +208,8 @@ extern int __gnat_is_directory (char *);
extern int __gnat_is_writable_file (char *);
extern int __gnat_is_readable_file (char *name);
extern int __gnat_is_executable_file (char *name);
+extern int __gnat_is_write_accessible_file (char *name);
+extern int __gnat_is_read_accessible_file (char *name);
extern void __gnat_reset_attributes (struct file_attributes *);
extern int __gnat_error_attributes (struct file_attributes *);
@@ -206,8 +233,9 @@ extern int __gnat_is_symbolic_link (char *name);
extern int __gnat_portable_spawn (char *[]);
extern int __gnat_portable_no_block_spawn (char *[]);
extern int __gnat_portable_wait (int *);
+extern int __gnat_current_process_id (void);
extern char *__gnat_locate_exec (char *, char *);
-extern char *__gnat_locate_exec_on_path (char *);
+extern char *__gnat_locate_exec_on_path (char *);
extern char *__gnat_locate_regular_file (char *, char *);
extern void __gnat_maybe_glob_args (int *, char ***);
extern void __gnat_os_exit (int);
diff --git a/gcc/ada/affinity.c b/gcc/ada/affinity.c
index 215a6144f0..bac8b5aec2 100644
--- a/gcc/ada/affinity.c
+++ b/gcc/ada/affinity.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2005-2011, Free Software Foundation, Inc. *
+ * Copyright (C) 2005-2015, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -34,11 +34,11 @@
#include "taskLib.h"
#include "cpuset.h"
-extern int __gnat_set_affinity (int tid, unsigned cpu);
-extern int __gnat_set_affinity_mask (int tid, unsigned mask);
+extern int __gnat_set_affinity (TASK_ID tid, unsigned cpu);
+extern int __gnat_set_affinity_mask (TASK_ID tid, unsigned mask);
int
- __gnat_set_affinity (int tid, unsigned cpu)
+ __gnat_set_affinity (TASK_ID tid, unsigned cpu)
{
cpuset_t cpuset;
@@ -48,9 +48,9 @@ int
}
int
-__gnat_set_affinity_mask (int tid, unsigned mask)
+__gnat_set_affinity_mask (TASK_ID tid, unsigned mask)
{
- int index;
+ unsigned index;
cpuset_t cpuset;
CPUSET_ZERO(cpuset);
diff --git a/gcc/ada/ali-util.ads b/gcc/ada/ali-util.ads
index 251f3e7c5a..c9abc5c2d5 100644
--- a/gcc/ada/ali-util.ads
+++ b/gcc/ada/ali-util.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -24,7 +24,7 @@
------------------------------------------------------------------------------
-- This child unit provides utility data structures and procedures used
--- for manipulation of ALI data by the gnatbind and gnatmake.
+-- for manipulation of ALI data by gnatbind and gnatmake.
package ALI.Util is
diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb
index d07b3df781..d42cb34431 100644
--- a/gcc/ada/ali.adb
+++ b/gcc/ada/ali.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -116,7 +116,6 @@ package body ALI is
Partition_Elaboration_Policy_Specified := ' ';
Queuing_Policy_Specified := ' ';
SSO_Default_Specified := False;
- Static_Elaboration_Model_Used := False;
Task_Dispatching_Policy_Specified := ' ';
Unreserve_All_Interrupts_Specified := False;
Frontend_Exceptions_Specified := False;
@@ -718,7 +717,7 @@ package body ALI is
begin
loop
case Nextc is
- when '[' =>
+ when '[' =>
Nested_Brackets := Nested_Brackets + 1;
when ']' =>
Nested_Brackets := Nested_Brackets - 1;
@@ -1464,19 +1463,19 @@ package body ALI is
C := Getc;
case C is
- when 'v' =>
- ALIs.Table (Id).Restrictions.Violated (R) := True;
- Cumulative_Restrictions.Violated (R) := True;
+ when 'v' =>
+ ALIs.Table (Id).Restrictions.Violated (R) := True;
+ Cumulative_Restrictions.Violated (R) := True;
- when 'r' =>
- ALIs.Table (Id).Restrictions.Set (R) := True;
- Cumulative_Restrictions.Set (R) := True;
+ when 'r' =>
+ ALIs.Table (Id).Restrictions.Set (R) := True;
+ Cumulative_Restrictions.Set (R) := True;
- when 'n' =>
- null;
+ when 'n' =>
+ null;
- when others =>
- raise Bad_R_Line;
+ when others =>
+ raise Bad_R_Line;
end case;
end loop;
@@ -1996,14 +1995,6 @@ package body ALI is
Skip_Eol;
- -- Check if static elaboration model used
-
- if not Units.Table (Units.Last).Dynamic_Elab
- and then not Units.Table (Units.Last).Internal
- then
- Static_Elaboration_Model_Used := True;
- end if;
-
C := Getc;
-- Scan out With lines for this unit
@@ -2056,8 +2047,7 @@ package body ALI is
-- Store AD indication unless ignore required
if not Ignore_ED then
- Withs.Table (Withs.Last).Elab_All_Desirable :=
- True;
+ Withs.Table (Withs.Last).Elab_All_Desirable := True;
end if;
elsif Nextc = 'E' then
diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads
index 96f6bd55a9..c51129df0d 100644
--- a/gcc/ada/ali.ads
+++ b/gcc/ada/ali.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -42,32 +42,28 @@ package ALI is
-- Id Types --
--------------
- -- The various entries are stored in tables with distinct subscript ranges.
- -- The following type definitions show the ranges used for the subscripts
- -- (Id values) for the various tables.
-
- type ALI_Id is range 0 .. 999_999;
+ type ALI_Id is range 0 .. 99_999_999;
-- Id values used for ALIs table entries
- type Unit_Id is range 1_000_000 .. 1_999_999;
+ type Unit_Id is range 0 .. 99_999_999;
-- Id values used for Unit table entries
- type With_Id is range 2_000_000 .. 2_999_999;
+ type With_Id is range 0 .. 99_999_999;
-- Id values used for Withs table entries
- type Arg_Id is range 3_000_000 .. 3_999_999;
+ type Arg_Id is range 0 .. 99_999_999;
-- Id values used for argument table entries
- type Sdep_Id is range 4_000_000 .. 4_999_999;
+ type Sdep_Id is range 0 .. 99_999_999;
-- Id values used for Sdep table entries
- type Source_Id is range 5_000_000 .. 5_999_999;
+ type Source_Id is range 0 .. 99_999_999;
-- Id values used for Source table entries
- type Interrupt_State_Id is range 6_000_000 .. 6_999_999;
+ type Interrupt_State_Id is range 0 .. 99_999_999;
-- Id values used for Interrupt_State table entries
- type Priority_Specific_Dispatching_Id is range 7_000_000 .. 7_999_999;
+ type Priority_Specific_Dispatching_Id is range 0 .. 99_999_999;
-- Id values used for Priority_Specific_Dispatching table entries
--------------------
@@ -527,11 +523,6 @@ package ALI is
-- Set to True if at least one ALI file contains '-fstack-check' in its
-- argument list.
- Static_Elaboration_Model_Used : Boolean := False;
- -- Set to False by Initialize_ALI. Set to True if any ALI file for a
- -- non-internal unit compiled with the static elaboration model is
- -- encountered.
-
Task_Dispatching_Policy_Specified : Character := ' ';
-- Set to blank by Initialize_ALI. Set to the appropriate task dispatching
-- policy character if an ali file contains a P line setting the
diff --git a/gcc/ada/alloc.ads b/gcc/ada/alloc.ads
index e175f8b433..7112fabfac 100644
--- a/gcc/ada/alloc.ads
+++ b/gcc/ada/alloc.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -30,14 +30,14 @@
------------------------------------------------------------------------------
-- This package contains definitions for initial sizes and growth increments
--- for the various dynamic arrays used for principle compiler data strcutures.
+-- for the various dynamic arrays used for the main compiler data structures.
-- The indicated initial size is allocated for the start of each file, and
-- the increment factor is a percentage used to increase the table size when
-- it needs expanding (e.g. a value of 100 = 100% increase = double)
--- Note: the initial values here are multiplied by Table_Factor, as set
--- by the -gnatTnn switch. This variable is defined in Opt, as is the
--- default value for the table factor.
+-- Note: the initial values here are multiplied by Table_Factor as set by the
+-- -gnatTnn switch. This variable is defined in Opt, as is the default value
+-- for the table factor.
package Alloc is
@@ -102,6 +102,7 @@ package Alloc is
Nodes_Initial : constant := 50_000; -- Atree
Nodes_Increment : constant := 100;
+ Nodes_Release_Threshold : constant := 100_000;
Notes_Initial : constant := 100; -- Lib
Notes_Increment : constant := 200;
@@ -111,6 +112,7 @@ package Alloc is
Orig_Nodes_Initial : constant := 50_000; -- Atree
Orig_Nodes_Increment : constant := 100;
+ Orig_Nodes_Release_Threshold : constant := 100_000;
Pending_Instantiations_Initial : constant := 10; -- Inline
Pending_Instantiations_Increment : constant := 100;
diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb
index 4398f92280..49eddf4285 100644
--- a/gcc/ada/aspects.adb
+++ b/gcc/ada/aspects.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2010-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -568,6 +568,7 @@ package body Aspects is
Aspect_Linker_Section => Aspect_Linker_Section,
Aspect_Lock_Free => Aspect_Lock_Free,
Aspect_Machine_Radix => Aspect_Machine_Radix,
+ Aspect_Max_Queue_Length => Aspect_Max_Queue_Length,
Aspect_No_Elaboration_Code_All => Aspect_No_Elaboration_Code_All,
Aspect_No_Return => Aspect_No_Return,
Aspect_No_Tagged_Streams => Aspect_No_Tagged_Streams,
@@ -598,6 +599,7 @@ package body Aspects is
Aspect_Read => Aspect_Read,
Aspect_Relative_Deadline => Aspect_Relative_Deadline,
Aspect_Scalar_Storage_Order => Aspect_Scalar_Storage_Order,
+ Aspect_Secondary_Stack_Size => Aspect_Secondary_Stack_Size,
Aspect_Shared => Aspect_Atomic,
Aspect_Shared_Passive => Aspect_Shared_Passive,
Aspect_Simple_Storage_Pool => Aspect_Simple_Storage_Pool,
diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
index 5e042ada03..586d35fea3 100644
--- a/gcc/ada/aspects.ads
+++ b/gcc/ada/aspects.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2010-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -116,6 +116,7 @@ package Aspects is
Aspect_Link_Name,
Aspect_Linker_Section, -- GNAT
Aspect_Machine_Radix,
+ Aspect_Max_Queue_Length, -- GNAT
Aspect_Object_Size, -- GNAT
Aspect_Obsolescent, -- GNAT
Aspect_Output,
@@ -134,6 +135,7 @@ package Aspects is
Aspect_Refined_State, -- GNAT
Aspect_Relative_Deadline,
Aspect_Scalar_Storage_Order, -- GNAT
+ Aspect_Secondary_Stack_Size, -- GNAT
Aspect_Simple_Storage_Pool, -- GNAT
Aspect_Size,
Aspect_Small,
@@ -247,12 +249,14 @@ package Aspects is
Aspect_Inline_Always => True,
Aspect_Invariant => True,
Aspect_Lock_Free => True,
+ Aspect_Max_Queue_Length => True,
Aspect_Object_Size => True,
Aspect_Persistent_BSS => True,
Aspect_Predicate => True,
Aspect_Pure_Function => True,
Aspect_Remote_Access_Type => True,
Aspect_Scalar_Storage_Order => True,
+ Aspect_Secondary_Stack_Size => True,
Aspect_Shared => True,
Aspect_Simple_Storage_Pool => True,
Aspect_Simple_Storage_Pool_Type => True,
@@ -353,6 +357,7 @@ package Aspects is
Aspect_Link_Name => Expression,
Aspect_Linker_Section => Expression,
Aspect_Machine_Radix => Expression,
+ Aspect_Max_Queue_Length => Expression,
Aspect_Object_Size => Expression,
Aspect_Obsolescent => Optional_Expression,
Aspect_Output => Name,
@@ -371,6 +376,7 @@ package Aspects is
Aspect_Refined_State => Expression,
Aspect_Relative_Deadline => Expression,
Aspect_Scalar_Storage_Order => Expression,
+ Aspect_Secondary_Stack_Size => Expression,
Aspect_Simple_Storage_Pool => Name,
Aspect_Size => Expression,
Aspect_Small => Expression,
@@ -460,6 +466,7 @@ package Aspects is
Aspect_Linker_Section => Name_Linker_Section,
Aspect_Lock_Free => Name_Lock_Free,
Aspect_Machine_Radix => Name_Machine_Radix,
+ Aspect_Max_Queue_Length => Name_Max_Queue_Length,
Aspect_No_Elaboration_Code_All => Name_No_Elaboration_Code_All,
Aspect_No_Return => Name_No_Return,
Aspect_No_Tagged_Streams => Name_No_Tagged_Streams,
@@ -490,6 +497,7 @@ package Aspects is
Aspect_Remote_Call_Interface => Name_Remote_Call_Interface,
Aspect_Remote_Types => Name_Remote_Types,
Aspect_Scalar_Storage_Order => Name_Scalar_Storage_Order,
+ Aspect_Secondary_Stack_Size => Name_Secondary_Stack_Size,
Aspect_Shared => Name_Shared,
Aspect_Shared_Passive => Name_Shared_Passive,
Aspect_Simple_Storage_Pool => Name_Simple_Storage_Pool,
@@ -652,12 +660,10 @@ package Aspects is
Aspect_Dispatching_Domain => Always_Delay,
Aspect_Dynamic_Predicate => Always_Delay,
Aspect_Elaborate_Body => Always_Delay,
- Aspect_Export => Always_Delay,
Aspect_External_Name => Always_Delay,
Aspect_External_Tag => Always_Delay,
Aspect_Favor_Top_Level => Always_Delay,
Aspect_Implicit_Dereference => Always_Delay,
- Aspect_Import => Always_Delay,
Aspect_Independent => Always_Delay,
Aspect_Independent_Components => Always_Delay,
Aspect_Inline => Always_Delay,
@@ -690,6 +696,7 @@ package Aspects is
Aspect_Remote_Access_Type => Always_Delay,
Aspect_Remote_Call_Interface => Always_Delay,
Aspect_Remote_Types => Always_Delay,
+ Aspect_Secondary_Stack_Size => Always_Delay,
Aspect_Shared => Always_Delay,
Aspect_Shared_Passive => Always_Delay,
Aspect_Simple_Storage_Pool => Always_Delay,
@@ -726,11 +733,14 @@ package Aspects is
Aspect_Disable_Controlled => Never_Delay,
Aspect_Effective_Reads => Never_Delay,
Aspect_Effective_Writes => Never_Delay,
+ Aspect_Export => Never_Delay,
Aspect_Extensions_Visible => Never_Delay,
Aspect_Ghost => Never_Delay,
Aspect_Global => Never_Delay,
+ Aspect_Import => Never_Delay,
Aspect_Initial_Condition => Never_Delay,
Aspect_Initializes => Never_Delay,
+ Aspect_Max_Queue_Length => Never_Delay,
Aspect_No_Elaboration_Code_All => Never_Delay,
Aspect_No_Tagged_Streams => Never_Delay,
Aspect_Obsolescent => Never_Delay,
diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb
index 5ae768a41e..29251c226a 100644
--- a/gcc/ada/atree.adb
+++ b/gcc/ada/atree.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -44,8 +44,15 @@ with Output; use Output;
with Sinput; use Sinput;
with Tree_IO; use Tree_IO;
+with GNAT.Heap_Sort_G;
+
package body Atree is
+ Locked : Boolean := False;
+ -- Compiling with assertions enabled, node contents modifications are
+ -- permitted only when this switch is set to False; compiling without
+ -- assertions this lock has no effect.
+
Reporting_Proc : Report_Proc := null;
-- Record argument to last call to Set_Reporting_Proc
@@ -115,6 +122,10 @@ package body Atree is
procedure Node_Debug_Output (Op : String; N : Node_Id);
-- Common code for nnd and rrd, writes Op followed by information about N
+ procedure Print_Statistics;
+ pragma Export (Ada, Print_Statistics);
+ -- Print various statistics on the tables maintained by the package
+
-----------------------------
-- Local Objects and Types --
-----------------------------
@@ -510,6 +521,7 @@ package body Atree is
Table_Low_Bound => First_Node_Id,
Table_Initial => Alloc.Orig_Nodes_Initial,
Table_Increment => Alloc.Orig_Nodes_Increment,
+ Release_Threshold => Alloc.Orig_Nodes_Release_Threshold,
Table_Name => "Orig_Nodes");
--------------------------
@@ -542,16 +554,20 @@ package body Atree is
-- Local Subprograms --
-----------------------
- procedure Fix_Parents (Ref_Node, Fix_Node : Node_Id);
- -- Fixup parent pointers for the syntactic children of Fix_Node after
- -- a copy, setting them to Fix_Node when they pointed to Ref_Node.
-
function Allocate_Initialize_Node
(Src : Node_Id;
With_Extension : Boolean) return Node_Id;
-- Allocate a new node or node extension. If Src is not empty, the
-- information for the newly-allocated node is copied from it.
+ procedure Fix_Parents (Ref_Node, Fix_Node : Node_Id);
+ -- Fix up parent pointers for the syntactic children of Fix_Node after a
+ -- copy, setting them to Fix_Node when they pointed to Ref_Node.
+
+ procedure Mark_New_Ghost_Node (N : Node_Or_Entity_Id);
+ -- Mark arbitrary node or entity N as Ghost when it is created within a
+ -- Ghost region.
+
------------------------------
-- Allocate_Initialize_Node --
------------------------------
@@ -587,13 +603,6 @@ package body Atree is
Node_Count := Node_Count + 1;
end if;
- -- Mark the node as ignored Ghost if it is created in an ignored Ghost
- -- region.
-
- if Ghost_Mode = Ignore then
- Set_Is_Ignored_Ghost_Node (New_Id);
- end if;
-
-- Clear Check_Actuals to False
Set_Check_Actuals (New_Id, False);
@@ -905,7 +914,7 @@ package body Atree is
else
New_Id := New_Copy (Source);
- -- Recursively copy descendents
+ -- Recursively copy descendants
Set_Field1 (New_Id, Possible_Copy (Field1 (New_Id)));
Set_Field2 (New_Id, Possible_Copy (Field2 (New_Id)));
@@ -1425,9 +1434,8 @@ package body Atree is
-----------------
procedure Fix_Parents (Ref_Node, Fix_Node : Node_Id) is
-
procedure Fix_Parent (Field : Union_Id);
- -- Fixup one parent pointer. Field is checked to see if it points to
+ -- Fix up one parent pointer. Field is checked to see if it points to
-- a node, list, or element list that has a parent that points to
-- Ref_Node. If so, the parent is reset to point to Fix_Node.
@@ -1583,6 +1591,38 @@ package body Atree is
Orig_Nodes.Release;
end Lock;
+ ----------------
+ -- Lock_Nodes --
+ ----------------
+
+ procedure Lock_Nodes is
+ begin
+ pragma Assert (not Locked);
+ Locked := True;
+ end Lock_Nodes;
+
+ -------------------------
+ -- Mark_New_Ghost_Node --
+ -------------------------
+
+ procedure Mark_New_Ghost_Node (N : Node_Or_Entity_Id) is
+ begin
+ -- The Ghost node is created within a Ghost region
+
+ if Ghost_Mode = Check then
+ if Nkind (N) in N_Entity then
+ Set_Is_Checked_Ghost_Entity (N);
+ end if;
+
+ elsif Ghost_Mode = Ignore then
+ if Nkind (N) in N_Entity then
+ Set_Is_Ignored_Ghost_Entity (N);
+ end if;
+
+ Set_Is_Ignored_Ghost_Node (N);
+ end if;
+ end Mark_New_Ghost_Node;
+
----------------------------
-- Mark_Rewrite_Insertion --
----------------------------
@@ -1623,6 +1663,10 @@ package body Atree is
-- aspects if this is required for the particular situation.
Set_Has_Aspects (New_Id, False);
+
+ -- Mark the copy as Ghost depending on the current Ghost region
+
+ Mark_New_Ghost_Node (New_Id);
end if;
return New_Id;
@@ -1655,6 +1699,10 @@ package body Atree is
Nodes.Table (Ent).Sloc := New_Sloc;
pragma Debug (New_Node_Debugging_Output (Ent));
+ -- Mark the new entity as Ghost depending on the current Ghost region
+
+ Mark_New_Ghost_Node (Ent);
+
return Ent;
end New_Entity;
@@ -1683,6 +1731,10 @@ package body Atree is
Current_Error_Node := Nod;
end if;
+ -- Mark the new node as Ghost depending on the current Ghost region
+
+ Mark_New_Ghost_Node (Nod);
+
return Nod;
end New_Node;
@@ -1955,6 +2007,114 @@ package body Atree is
Nodes.Table (OldN).Comes_From_Source;
end Preserve_Comes_From_Source;
+ ----------------------
+ -- Print_Statistics --
+ ----------------------
+
+ procedure Print_Statistics is
+ N_Count : constant Natural := Natural (Nodes.Last - First_Node_Id + 1);
+ E_Count : Natural := 0;
+
+ begin
+ Write_Str ("Number of entities: ");
+ Write_Eol;
+
+ declare
+ function CP_Lt (Op1, Op2 : Natural) return Boolean;
+ -- Compare routine for Sort
+
+ procedure CP_Move (From : Natural; To : Natural);
+ -- Move routine for Sort
+
+ Kind_Count : array (Node_Kind) of Natural := (others => 0);
+ -- Array of occurrence count per node kind
+
+ Kind_Max : constant Natural := Node_Kind'Pos (N_Unused_At_End) - 1;
+ -- The index of the largest (interesting) node kind
+
+ Ranking : array (0 .. Kind_Max) of Node_Kind;
+ -- Ranking array for node kinds (index 0 is used for the temporary)
+
+ package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt);
+
+ function CP_Lt (Op1, Op2 : Natural) return Boolean is
+ begin
+ return Kind_Count (Ranking (Op2)) < Kind_Count (Ranking (Op1));
+ end CP_Lt;
+
+ procedure CP_Move (From : Natural; To : Natural) is
+ begin
+ Ranking (To) := Ranking (From);
+ end CP_Move;
+
+ begin
+ -- Count the number of occurrences of each node kind
+
+ for I in First_Node_Id .. Nodes.Last loop
+ declare
+ Nkind : constant Node_Kind := Nodes.Table (I).Nkind;
+ begin
+ if not Nodes.Table (I).Is_Extension then
+ Kind_Count (Nkind) := Kind_Count (Nkind) + 1;
+ end if;
+ end;
+ end loop;
+
+ -- Sort the node kinds by number of occurrences
+
+ for N in 1 .. Kind_Max loop
+ Ranking (N) := Node_Kind'Val (N);
+ end loop;
+
+ Sorting.Sort (Kind_Max);
+
+ -- Print the list in descending order
+
+ for N in 1 .. Kind_Max loop
+ declare
+ Count : constant Natural := Kind_Count (Ranking (N));
+ begin
+ if Count > 0 then
+ Write_Str (" ");
+ Write_Str (Node_Kind'Image (Ranking (N)));
+ Write_Str (": ");
+ Write_Int (Int (Count));
+ Write_Eol;
+
+ E_Count := E_Count + Count;
+ end if;
+ end;
+ end loop;
+ end;
+
+ Write_Str ("Total number of entities: ");
+ Write_Int (Int (E_Count));
+ Write_Eol;
+
+ Write_Str ("Maximum number of nodes per entity: ");
+ Write_Int (Int (Num_Extension_Nodes + 1));
+ Write_Eol;
+
+ Write_Str ("Number of allocated nodes: ");
+ Write_Int (Int (N_Count));
+ Write_Eol;
+
+ Write_Str ("Ratio allocated nodes/entities: ");
+ Write_Int (Int (Long_Long_Integer (N_Count) * 100 /
+ Long_Long_Integer (E_Count)));
+ Write_Str ("/100");
+ Write_Eol;
+
+ Write_Str ("Size of a node in bytes: ");
+ Write_Int (Int (Node_Record'Size) / Storage_Unit);
+ Write_Eol;
+
+ Write_Str ("Memory consumption in bytes: ");
+ Write_Int (Int (Long_Long_Integer (N_Count) *
+ (Node_Record'Size / Storage_Unit)));
+ Write_Eol;
+ end Print_Statistics;
+
-------------------
-- Relocate_Node --
-------------------
@@ -2140,6 +2300,7 @@ package body Atree is
procedure Set_Analyzed (N : Node_Id; Val : Boolean := True) is
begin
+ pragma Assert (not Locked);
Nodes.Table (N).Analyzed := Val;
end Set_Analyzed;
@@ -2149,6 +2310,7 @@ package body Atree is
procedure Set_Check_Actuals (N : Node_Id; Val : Boolean := True) is
begin
+ pragma Assert (not Locked);
Flags.Table (N).Check_Actuals := Val;
end Set_Check_Actuals;
@@ -2158,6 +2320,7 @@ package body Atree is
procedure Set_Comes_From_Source (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Comes_From_Source := Val;
end Set_Comes_From_Source;
@@ -2177,6 +2340,7 @@ package body Atree is
procedure Set_Ekind (E : Entity_Id; Val : Entity_Kind) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (E) in N_Entity);
Nodes.Table (E + 1).Nkind := E_To_N (Val);
end Set_Ekind;
@@ -2187,6 +2351,7 @@ package body Atree is
procedure Set_Error_Posted (N : Node_Id; Val : Boolean := True) is
begin
+ pragma Assert (not Locked);
Nodes.Table (N).Error_Posted := Val;
end Set_Error_Posted;
@@ -2196,6 +2361,7 @@ package body Atree is
procedure Set_Has_Aspects (N : Node_Id; Val : Boolean := True) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Has_Aspects := Val;
end Set_Has_Aspects;
@@ -2206,6 +2372,7 @@ package body Atree is
procedure Set_Is_Ignored_Ghost_Node (N : Node_Id; Val : Boolean := True) is
begin
+ pragma Assert (not Locked);
Flags.Table (N).Is_Ignored_Ghost_Node := Val;
end Set_Is_Ignored_Ghost_Node;
@@ -2215,6 +2382,7 @@ package body Atree is
procedure Set_Original_Node (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
Orig_Nodes.Table (N) := Val;
end Set_Original_Node;
@@ -2224,6 +2392,7 @@ package body Atree is
procedure Set_Paren_Count (N : Node_Id; Val : Nat) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Subexpr);
-- Value of 0,1,2 stored as is
@@ -2255,6 +2424,7 @@ package body Atree is
procedure Set_Parent (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (not Nodes.Table (N).In_List);
Nodes.Table (N).Link := Union_Id (Val);
end Set_Parent;
@@ -2265,6 +2435,7 @@ package body Atree is
procedure Set_Sloc (N : Node_Id; Val : Source_Ptr) is
begin
+ pragma Assert (not Locked);
Nodes.Table (N).Sloc := Val;
end Set_Sloc;
@@ -2305,11 +2476,11 @@ package body Atree is
if Fld = Union_Id (Empty) then
return OK;
- -- Descendent is a node
+ -- Descendant is a node
elsif Fld in Node_Range then
- -- Traverse descendent that is syntactic subtree node
+ -- Traverse descendant that is syntactic subtree node
if Is_Syntactic_Field (Nkind (Nod), FN) then
return Traverse_Func (Node_Id (Fld));
@@ -2320,11 +2491,11 @@ package body Atree is
return OK;
end if;
- -- Descendent is a list
+ -- Descendant is a list
elsif Fld in List_Range then
- -- Traverse descendent that is a syntactic subtree list
+ -- Traverse descendant that is a syntactic subtree list
if Is_Syntactic_Field (Nkind (Nod), FN) then
declare
@@ -3203,6 +3374,17 @@ package body Atree is
end if;
end Elist26;
+ function Elist29 (N : Node_Id) return Elist_Id is
+ pragma Assert (Nkind (N) in N_Entity);
+ Value : constant Union_Id := Nodes.Table (N + 4).Field11;
+ begin
+ if Value = 0 then
+ return No_Elist;
+ else
+ return Elist_Id (Value);
+ end if;
+ end Elist29;
+
function Elist36 (N : Node_Id) return Elist_Id is
pragma Assert (Nkind (N) in N_Entity);
Value : constant Union_Id := Nodes.Table (N + 6).Field6;
@@ -5336,1195 +5518,1402 @@ package body Atree is
procedure Set_Nkind (N : Node_Id; Val : Node_Kind) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Nkind := Val;
end Set_Nkind;
procedure Set_Field1 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field1 := Val;
end Set_Field1;
procedure Set_Field2 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field2 := Val;
end Set_Field2;
procedure Set_Field3 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field3 := Val;
end Set_Field3;
procedure Set_Field4 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field4 := Val;
end Set_Field4;
procedure Set_Field5 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field5 := Val;
end Set_Field5;
procedure Set_Field6 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Field6 := Val;
end Set_Field6;
procedure Set_Field7 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Field7 := Val;
end Set_Field7;
procedure Set_Field8 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Field8 := Val;
end Set_Field8;
procedure Set_Field9 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Field9 := Val;
end Set_Field9;
procedure Set_Field10 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Field10 := Val;
end Set_Field10;
procedure Set_Field11 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Field11 := Val;
end Set_Field11;
procedure Set_Field12 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Field12 := Val;
end Set_Field12;
procedure Set_Field13 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Field6 := Val;
end Set_Field13;
procedure Set_Field14 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Field7 := Val;
end Set_Field14;
procedure Set_Field15 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Field8 := Val;
end Set_Field15;
procedure Set_Field16 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Field9 := Val;
end Set_Field16;
procedure Set_Field17 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Field10 := Val;
end Set_Field17;
procedure Set_Field18 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Field11 := Val;
end Set_Field18;
procedure Set_Field19 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Field6 := Val;
end Set_Field19;
procedure Set_Field20 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Field7 := Val;
end Set_Field20;
procedure Set_Field21 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Field8 := Val;
end Set_Field21;
procedure Set_Field22 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Field9 := Val;
end Set_Field22;
procedure Set_Field23 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Field10 := Val;
end Set_Field23;
procedure Set_Field24 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Field6 := Val;
end Set_Field24;
procedure Set_Field25 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Field7 := Val;
end Set_Field25;
procedure Set_Field26 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Field8 := Val;
end Set_Field26;
procedure Set_Field27 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Field9 := Val;
end Set_Field27;
procedure Set_Field28 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Field10 := Val;
end Set_Field28;
procedure Set_Field29 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Field11 := Val;
end Set_Field29;
procedure Set_Field30 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Field6 := Val;
end Set_Field30;
procedure Set_Field31 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Field7 := Val;
end Set_Field31;
procedure Set_Field32 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Field8 := Val;
end Set_Field32;
procedure Set_Field33 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Field9 := Val;
end Set_Field33;
procedure Set_Field34 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Field10 := Val;
end Set_Field34;
procedure Set_Field35 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Field11 := Val;
end Set_Field35;
procedure Set_Field36 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 6).Field6 := Val;
end Set_Field36;
procedure Set_Field37 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 6).Field7 := Val;
end Set_Field37;
procedure Set_Field38 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 6).Field8 := Val;
end Set_Field38;
procedure Set_Field39 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 6).Field9 := Val;
end Set_Field39;
procedure Set_Field40 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 6).Field10 := Val;
end Set_Field40;
procedure Set_Field41 (N : Node_Id; Val : Union_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 6).Field11 := Val;
end Set_Field41;
procedure Set_Node1 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field1 := Union_Id (Val);
end Set_Node1;
procedure Set_Node2 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field2 := Union_Id (Val);
end Set_Node2;
procedure Set_Node3 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field3 := Union_Id (Val);
end Set_Node3;
procedure Set_Node4 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field4 := Union_Id (Val);
end Set_Node4;
procedure Set_Node5 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field5 := Union_Id (Val);
end Set_Node5;
procedure Set_Node6 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Field6 := Union_Id (Val);
end Set_Node6;
procedure Set_Node7 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Field7 := Union_Id (Val);
end Set_Node7;
procedure Set_Node8 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Field8 := Union_Id (Val);
end Set_Node8;
procedure Set_Node9 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Field9 := Union_Id (Val);
end Set_Node9;
procedure Set_Node10 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Field10 := Union_Id (Val);
end Set_Node10;
procedure Set_Node11 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Field11 := Union_Id (Val);
end Set_Node11;
procedure Set_Node12 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Field12 := Union_Id (Val);
end Set_Node12;
procedure Set_Node13 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Field6 := Union_Id (Val);
end Set_Node13;
procedure Set_Node14 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Field7 := Union_Id (Val);
end Set_Node14;
procedure Set_Node15 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Field8 := Union_Id (Val);
end Set_Node15;
procedure Set_Node16 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Field9 := Union_Id (Val);
end Set_Node16;
procedure Set_Node17 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Field10 := Union_Id (Val);
end Set_Node17;
procedure Set_Node18 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Field11 := Union_Id (Val);
end Set_Node18;
procedure Set_Node19 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Field6 := Union_Id (Val);
end Set_Node19;
procedure Set_Node20 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Field7 := Union_Id (Val);
end Set_Node20;
procedure Set_Node21 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Field8 := Union_Id (Val);
end Set_Node21;
procedure Set_Node22 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Field9 := Union_Id (Val);
end Set_Node22;
procedure Set_Node23 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Field10 := Union_Id (Val);
end Set_Node23;
procedure Set_Node24 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Field6 := Union_Id (Val);
end Set_Node24;
procedure Set_Node25 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Field7 := Union_Id (Val);
end Set_Node25;
procedure Set_Node26 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Field8 := Union_Id (Val);
end Set_Node26;
procedure Set_Node27 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Field9 := Union_Id (Val);
end Set_Node27;
procedure Set_Node28 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Field10 := Union_Id (Val);
end Set_Node28;
procedure Set_Node29 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Field11 := Union_Id (Val);
end Set_Node29;
procedure Set_Node30 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Field6 := Union_Id (Val);
end Set_Node30;
procedure Set_Node31 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Field7 := Union_Id (Val);
end Set_Node31;
procedure Set_Node32 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Field8 := Union_Id (Val);
end Set_Node32;
procedure Set_Node33 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Field9 := Union_Id (Val);
end Set_Node33;
procedure Set_Node34 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Field10 := Union_Id (Val);
end Set_Node34;
procedure Set_Node35 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Field11 := Union_Id (Val);
end Set_Node35;
procedure Set_Node36 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 6).Field6 := Union_Id (Val);
end Set_Node36;
procedure Set_Node37 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 6).Field7 := Union_Id (Val);
end Set_Node37;
procedure Set_Node38 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 6).Field8 := Union_Id (Val);
end Set_Node38;
procedure Set_Node39 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 6).Field9 := Union_Id (Val);
end Set_Node39;
procedure Set_Node40 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 6).Field10 := Union_Id (Val);
end Set_Node40;
procedure Set_Node41 (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 6).Field11 := Union_Id (Val);
end Set_Node41;
procedure Set_List1 (N : Node_Id; Val : List_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field1 := Union_Id (Val);
end Set_List1;
procedure Set_List2 (N : Node_Id; Val : List_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field2 := Union_Id (Val);
end Set_List2;
procedure Set_List3 (N : Node_Id; Val : List_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field3 := Union_Id (Val);
end Set_List3;
procedure Set_List4 (N : Node_Id; Val : List_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field4 := Union_Id (Val);
end Set_List4;
procedure Set_List5 (N : Node_Id; Val : List_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field5 := Union_Id (Val);
end Set_List5;
procedure Set_List10 (N : Node_Id; Val : List_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Field10 := Union_Id (Val);
end Set_List10;
procedure Set_List14 (N : Node_Id; Val : List_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Field7 := Union_Id (Val);
end Set_List14;
procedure Set_List25 (N : Node_Id; Val : List_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Field7 := Union_Id (Val);
end Set_List25;
procedure Set_List38 (N : Node_Id; Val : List_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 6).Field8 := Union_Id (Val);
end Set_List38;
procedure Set_List39 (N : Node_Id; Val : List_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 6).Field9 := Union_Id (Val);
end Set_List39;
procedure Set_Elist1 (N : Node_Id; Val : Elist_Id) is
begin
+ pragma Assert (not Locked);
Nodes.Table (N).Field1 := Union_Id (Val);
end Set_Elist1;
procedure Set_Elist2 (N : Node_Id; Val : Elist_Id) is
begin
+ pragma Assert (not Locked);
Nodes.Table (N).Field2 := Union_Id (Val);
end Set_Elist2;
procedure Set_Elist3 (N : Node_Id; Val : Elist_Id) is
begin
+ pragma Assert (not Locked);
Nodes.Table (N).Field3 := Union_Id (Val);
end Set_Elist3;
procedure Set_Elist4 (N : Node_Id; Val : Elist_Id) is
begin
+ pragma Assert (not Locked);
Nodes.Table (N).Field4 := Union_Id (Val);
end Set_Elist4;
procedure Set_Elist5 (N : Node_Id; Val : Elist_Id) is
begin
+ pragma Assert (not Locked);
Nodes.Table (N).Field5 := Union_Id (Val);
end Set_Elist5;
procedure Set_Elist8 (N : Node_Id; Val : Elist_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Field8 := Union_Id (Val);
end Set_Elist8;
procedure Set_Elist9 (N : Node_Id; Val : Elist_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Field9 := Union_Id (Val);
end Set_Elist9;
procedure Set_Elist10 (N : Node_Id; Val : Elist_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Field10 := Union_Id (Val);
end Set_Elist10;
procedure Set_Elist11 (N : Node_Id; Val : Elist_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Field11 := Union_Id (Val);
end Set_Elist11;
procedure Set_Elist13 (N : Node_Id; Val : Elist_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Field6 := Union_Id (Val);
end Set_Elist13;
procedure Set_Elist15 (N : Node_Id; Val : Elist_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Field8 := Union_Id (Val);
end Set_Elist15;
procedure Set_Elist16 (N : Node_Id; Val : Elist_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Field9 := Union_Id (Val);
end Set_Elist16;
procedure Set_Elist18 (N : Node_Id; Val : Elist_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Field11 := Union_Id (Val);
end Set_Elist18;
procedure Set_Elist21 (N : Node_Id; Val : Elist_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Field8 := Union_Id (Val);
end Set_Elist21;
procedure Set_Elist23 (N : Node_Id; Val : Elist_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Field10 := Union_Id (Val);
end Set_Elist23;
procedure Set_Elist24 (N : Node_Id; Val : Elist_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Field6 := Union_Id (Val);
end Set_Elist24;
procedure Set_Elist25 (N : Node_Id; Val : Elist_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Field7 := Union_Id (Val);
end Set_Elist25;
procedure Set_Elist26 (N : Node_Id; Val : Elist_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Field8 := Union_Id (Val);
end Set_Elist26;
+ procedure Set_Elist29 (N : Node_Id; Val : Elist_Id) is
+ begin
+ pragma Assert (not Locked);
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 4).Field11 := Union_Id (Val);
+ end Set_Elist29;
+
procedure Set_Elist36 (N : Node_Id; Val : Elist_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 6).Field6 := Union_Id (Val);
end Set_Elist36;
procedure Set_Name1 (N : Node_Id; Val : Name_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field1 := Union_Id (Val);
end Set_Name1;
procedure Set_Name2 (N : Node_Id; Val : Name_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field2 := Union_Id (Val);
end Set_Name2;
procedure Set_Str3 (N : Node_Id; Val : String_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field3 := Union_Id (Val);
end Set_Str3;
procedure Set_Uint2 (N : Node_Id; Val : Uint) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field2 := To_Union (Val);
end Set_Uint2;
procedure Set_Uint3 (N : Node_Id; Val : Uint) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field3 := To_Union (Val);
end Set_Uint3;
procedure Set_Uint4 (N : Node_Id; Val : Uint) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field4 := To_Union (Val);
end Set_Uint4;
procedure Set_Uint5 (N : Node_Id; Val : Uint) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field5 := To_Union (Val);
end Set_Uint5;
procedure Set_Uint8 (N : Node_Id; Val : Uint) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Field8 := To_Union (Val);
end Set_Uint8;
procedure Set_Uint9 (N : Node_Id; Val : Uint) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Field9 := To_Union (Val);
end Set_Uint9;
procedure Set_Uint10 (N : Node_Id; Val : Uint) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Field10 := To_Union (Val);
end Set_Uint10;
procedure Set_Uint11 (N : Node_Id; Val : Uint) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Field11 := To_Union (Val);
end Set_Uint11;
procedure Set_Uint12 (N : Node_Id; Val : Uint) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Field12 := To_Union (Val);
end Set_Uint12;
procedure Set_Uint13 (N : Node_Id; Val : Uint) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Field6 := To_Union (Val);
end Set_Uint13;
procedure Set_Uint14 (N : Node_Id; Val : Uint) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Field7 := To_Union (Val);
end Set_Uint14;
procedure Set_Uint15 (N : Node_Id; Val : Uint) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Field8 := To_Union (Val);
end Set_Uint15;
procedure Set_Uint16 (N : Node_Id; Val : Uint) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Field9 := To_Union (Val);
end Set_Uint16;
procedure Set_Uint17 (N : Node_Id; Val : Uint) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Field10 := To_Union (Val);
end Set_Uint17;
procedure Set_Uint22 (N : Node_Id; Val : Uint) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Field9 := To_Union (Val);
end Set_Uint22;
procedure Set_Uint24 (N : Node_Id; Val : Uint) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Field6 := To_Union (Val);
end Set_Uint24;
procedure Set_Ureal3 (N : Node_Id; Val : Ureal) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Field3 := To_Union (Val);
end Set_Ureal3;
procedure Set_Ureal18 (N : Node_Id; Val : Ureal) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Field11 := To_Union (Val);
end Set_Ureal18;
procedure Set_Ureal21 (N : Node_Id; Val : Ureal) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Field8 := To_Union (Val);
end Set_Ureal21;
procedure Set_Flag0 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Flags.Table (N).Flag0 := Val;
end Set_Flag0;
procedure Set_Flag1 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Flags.Table (N).Flag1 := Val;
end Set_Flag1;
procedure Set_Flag2 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Flags.Table (N).Flag2 := Val;
end Set_Flag2;
procedure Set_Flag3 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Flags.Table (N).Flag3 := Val;
end Set_Flag3;
procedure Set_Flag4 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Flag4 := Val;
end Set_Flag4;
procedure Set_Flag5 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Flag5 := Val;
end Set_Flag5;
procedure Set_Flag6 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Flag6 := Val;
end Set_Flag6;
procedure Set_Flag7 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Flag7 := Val;
end Set_Flag7;
procedure Set_Flag8 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Flag8 := Val;
end Set_Flag8;
procedure Set_Flag9 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Flag9 := Val;
end Set_Flag9;
procedure Set_Flag10 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Flag10 := Val;
end Set_Flag10;
procedure Set_Flag11 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Flag11 := Val;
end Set_Flag11;
procedure Set_Flag12 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Flag12 := Val;
end Set_Flag12;
procedure Set_Flag13 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Flag13 := Val;
end Set_Flag13;
procedure Set_Flag14 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Flag14 := Val;
end Set_Flag14;
procedure Set_Flag15 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Flag15 := Val;
end Set_Flag15;
procedure Set_Flag16 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Flag16 := Val;
end Set_Flag16;
procedure Set_Flag17 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Flag17 := Val;
end Set_Flag17;
procedure Set_Flag18 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
Nodes.Table (N).Flag18 := Val;
end Set_Flag18;
procedure Set_Flag19 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).In_List := Val;
end Set_Flag19;
procedure Set_Flag20 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Has_Aspects := Val;
end Set_Flag20;
procedure Set_Flag21 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Rewrite_Ins := Val;
end Set_Flag21;
procedure Set_Flag22 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Analyzed := Val;
end Set_Flag22;
procedure Set_Flag23 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Comes_From_Source := Val;
end Set_Flag23;
procedure Set_Flag24 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Error_Posted := Val;
end Set_Flag24;
procedure Set_Flag25 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Flag4 := Val;
end Set_Flag25;
procedure Set_Flag26 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Flag5 := Val;
end Set_Flag26;
procedure Set_Flag27 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Flag6 := Val;
end Set_Flag27;
procedure Set_Flag28 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Flag7 := Val;
end Set_Flag28;
procedure Set_Flag29 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Flag8 := Val;
end Set_Flag29;
procedure Set_Flag30 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Flag9 := Val;
end Set_Flag30;
procedure Set_Flag31 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Flag10 := Val;
end Set_Flag31;
procedure Set_Flag32 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Flag11 := Val;
end Set_Flag32;
procedure Set_Flag33 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Flag12 := Val;
end Set_Flag33;
procedure Set_Flag34 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Flag13 := Val;
end Set_Flag34;
procedure Set_Flag35 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Flag14 := Val;
end Set_Flag35;
procedure Set_Flag36 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Flag15 := Val;
end Set_Flag36;
procedure Set_Flag37 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Flag16 := Val;
end Set_Flag37;
procedure Set_Flag38 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Flag17 := Val;
end Set_Flag38;
procedure Set_Flag39 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Flag18 := Val;
end Set_Flag39;
procedure Set_Flag40 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).In_List := Val;
end Set_Flag40;
procedure Set_Flag41 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Has_Aspects := Val;
end Set_Flag41;
procedure Set_Flag42 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Rewrite_Ins := Val;
end Set_Flag42;
procedure Set_Flag43 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Analyzed := Val;
end Set_Flag43;
procedure Set_Flag44 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Comes_From_Source := Val;
end Set_Flag44;
procedure Set_Flag45 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Error_Posted := Val;
end Set_Flag45;
procedure Set_Flag46 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Flag4 := Val;
end Set_Flag46;
procedure Set_Flag47 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Flag5 := Val;
end Set_Flag47;
procedure Set_Flag48 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Flag6 := Val;
end Set_Flag48;
procedure Set_Flag49 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Flag7 := Val;
end Set_Flag49;
procedure Set_Flag50 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Flag8 := Val;
end Set_Flag50;
procedure Set_Flag51 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Flag9 := Val;
end Set_Flag51;
procedure Set_Flag52 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Flag10 := Val;
end Set_Flag52;
procedure Set_Flag53 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Flag11 := Val;
end Set_Flag53;
procedure Set_Flag54 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Flag12 := Val;
end Set_Flag54;
procedure Set_Flag55 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Flag13 := Val;
end Set_Flag55;
procedure Set_Flag56 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Flag14 := Val;
end Set_Flag56;
procedure Set_Flag57 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Flag15 := Val;
end Set_Flag57;
procedure Set_Flag58 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Flag16 := Val;
end Set_Flag58;
procedure Set_Flag59 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Flag17 := Val;
end Set_Flag59;
procedure Set_Flag60 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Flag18 := Val;
end Set_Flag60;
procedure Set_Flag61 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Pflag1 := Val;
end Set_Flag61;
procedure Set_Flag62 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 1).Pflag2 := Val;
end Set_Flag62;
procedure Set_Flag63 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Pflag1 := Val;
end Set_Flag63;
procedure Set_Flag64 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 2).Pflag2 := Val;
end Set_Flag64;
procedure Set_Flag65 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Byte_Ptr
(Node_Kind_Ptr'
@@ -6533,6 +6922,7 @@ package body Atree is
procedure Set_Flag66 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Byte_Ptr
(Node_Kind_Ptr'
@@ -6541,6 +6931,7 @@ package body Atree is
procedure Set_Flag67 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Byte_Ptr
(Node_Kind_Ptr'
@@ -6549,6 +6940,7 @@ package body Atree is
procedure Set_Flag68 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Byte_Ptr
(Node_Kind_Ptr'
@@ -6557,6 +6949,7 @@ package body Atree is
procedure Set_Flag69 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Byte_Ptr
(Node_Kind_Ptr'
@@ -6565,6 +6958,7 @@ package body Atree is
procedure Set_Flag70 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Byte_Ptr
(Node_Kind_Ptr'
@@ -6573,6 +6967,7 @@ package body Atree is
procedure Set_Flag71 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Byte_Ptr
(Node_Kind_Ptr'
@@ -6581,6 +6976,7 @@ package body Atree is
procedure Set_Flag72 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Byte_Ptr
(Node_Kind_Ptr'
@@ -6589,6 +6985,7 @@ package body Atree is
procedure Set_Flag73 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word_Ptr
(Union_Id_Ptr'
@@ -6597,6 +6994,7 @@ package body Atree is
procedure Set_Flag74 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word_Ptr
(Union_Id_Ptr'
@@ -6605,6 +7003,7 @@ package body Atree is
procedure Set_Flag75 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word_Ptr
(Union_Id_Ptr'
@@ -6613,6 +7012,7 @@ package body Atree is
procedure Set_Flag76 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word_Ptr
(Union_Id_Ptr'
@@ -6621,6 +7021,7 @@ package body Atree is
procedure Set_Flag77 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word_Ptr
(Union_Id_Ptr'
@@ -6629,6 +7030,7 @@ package body Atree is
procedure Set_Flag78 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word_Ptr
(Union_Id_Ptr'
@@ -6637,6 +7039,7 @@ package body Atree is
procedure Set_Flag79 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word_Ptr
(Union_Id_Ptr'
@@ -6645,6 +7048,7 @@ package body Atree is
procedure Set_Flag80 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word_Ptr
(Union_Id_Ptr'
@@ -6653,6 +7057,7 @@ package body Atree is
procedure Set_Flag81 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word_Ptr
(Union_Id_Ptr'
@@ -6661,6 +7066,7 @@ package body Atree is
procedure Set_Flag82 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word_Ptr
(Union_Id_Ptr'
@@ -6669,6 +7075,7 @@ package body Atree is
procedure Set_Flag83 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word_Ptr
(Union_Id_Ptr'
@@ -6677,6 +7084,7 @@ package body Atree is
procedure Set_Flag84 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word_Ptr
(Union_Id_Ptr'
@@ -6685,6 +7093,7 @@ package body Atree is
procedure Set_Flag85 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word_Ptr
(Union_Id_Ptr'
@@ -6693,6 +7102,7 @@ package body Atree is
procedure Set_Flag86 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word_Ptr
(Union_Id_Ptr'
@@ -6701,6 +7111,7 @@ package body Atree is
procedure Set_Flag87 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word_Ptr
(Union_Id_Ptr'
@@ -6709,6 +7120,7 @@ package body Atree is
procedure Set_Flag88 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word_Ptr
(Union_Id_Ptr'
@@ -6717,6 +7129,7 @@ package body Atree is
procedure Set_Flag89 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word_Ptr
(Union_Id_Ptr'
@@ -6725,6 +7138,7 @@ package body Atree is
procedure Set_Flag90 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word_Ptr
(Union_Id_Ptr'
@@ -6733,6 +7147,7 @@ package body Atree is
procedure Set_Flag91 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word_Ptr
(Union_Id_Ptr'
@@ -6741,6 +7156,7 @@ package body Atree is
procedure Set_Flag92 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word_Ptr
(Union_Id_Ptr'
@@ -6749,6 +7165,7 @@ package body Atree is
procedure Set_Flag93 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word_Ptr
(Union_Id_Ptr'
@@ -6757,6 +7174,7 @@ package body Atree is
procedure Set_Flag94 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word_Ptr
(Union_Id_Ptr'
@@ -6765,6 +7183,7 @@ package body Atree is
procedure Set_Flag95 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word_Ptr
(Union_Id_Ptr'
@@ -6773,6 +7192,7 @@ package body Atree is
procedure Set_Flag96 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word_Ptr
(Union_Id_Ptr'
@@ -6781,6 +7201,7 @@ package body Atree is
procedure Set_Flag97 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word2_Ptr
(Union_Id_Ptr'
@@ -6789,6 +7210,7 @@ package body Atree is
procedure Set_Flag98 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word2_Ptr
(Union_Id_Ptr'
@@ -6797,6 +7219,7 @@ package body Atree is
procedure Set_Flag99 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word2_Ptr
(Union_Id_Ptr'
@@ -6805,6 +7228,7 @@ package body Atree is
procedure Set_Flag100 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word2_Ptr
(Union_Id_Ptr'
@@ -6813,6 +7237,7 @@ package body Atree is
procedure Set_Flag101 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word2_Ptr
(Union_Id_Ptr'
@@ -6821,6 +7246,7 @@ package body Atree is
procedure Set_Flag102 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word2_Ptr
(Union_Id_Ptr'
@@ -6829,6 +7255,7 @@ package body Atree is
procedure Set_Flag103 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word2_Ptr
(Union_Id_Ptr'
@@ -6837,6 +7264,7 @@ package body Atree is
procedure Set_Flag104 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word2_Ptr
(Union_Id_Ptr'
@@ -6845,6 +7273,7 @@ package body Atree is
procedure Set_Flag105 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word2_Ptr
(Union_Id_Ptr'
@@ -6853,6 +7282,7 @@ package body Atree is
procedure Set_Flag106 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word2_Ptr
(Union_Id_Ptr'
@@ -6861,6 +7291,7 @@ package body Atree is
procedure Set_Flag107 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word2_Ptr
(Union_Id_Ptr'
@@ -6869,6 +7300,7 @@ package body Atree is
procedure Set_Flag108 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word2_Ptr
(Union_Id_Ptr'
@@ -6877,6 +7309,7 @@ package body Atree is
procedure Set_Flag109 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word2_Ptr
(Union_Id_Ptr'
@@ -6885,6 +7318,7 @@ package body Atree is
procedure Set_Flag110 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word2_Ptr
(Union_Id_Ptr'
@@ -6893,6 +7327,7 @@ package body Atree is
procedure Set_Flag111 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word2_Ptr
(Union_Id_Ptr'
@@ -6901,6 +7336,7 @@ package body Atree is
procedure Set_Flag112 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word2_Ptr
(Union_Id_Ptr'
@@ -6909,6 +7345,7 @@ package body Atree is
procedure Set_Flag113 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word2_Ptr
(Union_Id_Ptr'
@@ -6917,6 +7354,7 @@ package body Atree is
procedure Set_Flag114 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word2_Ptr
(Union_Id_Ptr'
@@ -6925,6 +7363,7 @@ package body Atree is
procedure Set_Flag115 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word2_Ptr
(Union_Id_Ptr'
@@ -6933,6 +7372,7 @@ package body Atree is
procedure Set_Flag116 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word2_Ptr
(Union_Id_Ptr'
@@ -6941,6 +7381,7 @@ package body Atree is
procedure Set_Flag117 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word2_Ptr
(Union_Id_Ptr'
@@ -6949,6 +7390,7 @@ package body Atree is
procedure Set_Flag118 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word2_Ptr
(Union_Id_Ptr'
@@ -6957,6 +7399,7 @@ package body Atree is
procedure Set_Flag119 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word2_Ptr
(Union_Id_Ptr'
@@ -6965,6 +7408,7 @@ package body Atree is
procedure Set_Flag120 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word2_Ptr
(Union_Id_Ptr'
@@ -6973,6 +7417,7 @@ package body Atree is
procedure Set_Flag121 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word2_Ptr
(Union_Id_Ptr'
@@ -6981,6 +7426,7 @@ package body Atree is
procedure Set_Flag122 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word2_Ptr
(Union_Id_Ptr'
@@ -6989,6 +7435,7 @@ package body Atree is
procedure Set_Flag123 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word2_Ptr
(Union_Id_Ptr'
@@ -6997,6 +7444,7 @@ package body Atree is
procedure Set_Flag124 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word2_Ptr
(Union_Id_Ptr'
@@ -7005,6 +7453,7 @@ package body Atree is
procedure Set_Flag125 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word2_Ptr
(Union_Id_Ptr'
@@ -7013,6 +7462,7 @@ package body Atree is
procedure Set_Flag126 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word2_Ptr
(Union_Id_Ptr'
@@ -7021,6 +7471,7 @@ package body Atree is
procedure Set_Flag127 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word2_Ptr
(Union_Id_Ptr'
@@ -7029,6 +7480,7 @@ package body Atree is
procedure Set_Flag128 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word2_Ptr
(Union_Id_Ptr'
@@ -7037,144 +7489,168 @@ package body Atree is
procedure Set_Flag129 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).In_List := Val;
end Set_Flag129;
procedure Set_Flag130 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Has_Aspects := Val;
end Set_Flag130;
procedure Set_Flag131 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Rewrite_Ins := Val;
end Set_Flag131;
procedure Set_Flag132 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Analyzed := Val;
end Set_Flag132;
procedure Set_Flag133 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Comes_From_Source := Val;
end Set_Flag133;
procedure Set_Flag134 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Error_Posted := Val;
end Set_Flag134;
procedure Set_Flag135 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Flag4 := Val;
end Set_Flag135;
procedure Set_Flag136 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Flag5 := Val;
end Set_Flag136;
procedure Set_Flag137 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Flag6 := Val;
end Set_Flag137;
procedure Set_Flag138 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Flag7 := Val;
end Set_Flag138;
procedure Set_Flag139 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Flag8 := Val;
end Set_Flag139;
procedure Set_Flag140 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Flag9 := Val;
end Set_Flag140;
procedure Set_Flag141 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Flag10 := Val;
end Set_Flag141;
procedure Set_Flag142 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Flag11 := Val;
end Set_Flag142;
procedure Set_Flag143 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Flag12 := Val;
end Set_Flag143;
procedure Set_Flag144 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Flag13 := Val;
end Set_Flag144;
procedure Set_Flag145 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Flag14 := Val;
end Set_Flag145;
procedure Set_Flag146 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Flag15 := Val;
end Set_Flag146;
procedure Set_Flag147 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Flag16 := Val;
end Set_Flag147;
procedure Set_Flag148 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Flag17 := Val;
end Set_Flag148;
procedure Set_Flag149 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Flag18 := Val;
end Set_Flag149;
procedure Set_Flag150 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Pflag1 := Val;
end Set_Flag150;
procedure Set_Flag151 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 3).Pflag2 := Val;
end Set_Flag151;
procedure Set_Flag152 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word3_Ptr
(Union_Id_Ptr'
@@ -7183,6 +7659,7 @@ package body Atree is
procedure Set_Flag153 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word3_Ptr
(Union_Id_Ptr'
@@ -7191,6 +7668,7 @@ package body Atree is
procedure Set_Flag154 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word3_Ptr
(Union_Id_Ptr'
@@ -7199,6 +7677,7 @@ package body Atree is
procedure Set_Flag155 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word3_Ptr
(Union_Id_Ptr'
@@ -7207,6 +7686,7 @@ package body Atree is
procedure Set_Flag156 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word3_Ptr
(Union_Id_Ptr'
@@ -7215,6 +7695,7 @@ package body Atree is
procedure Set_Flag157 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word3_Ptr
(Union_Id_Ptr'
@@ -7223,6 +7704,7 @@ package body Atree is
procedure Set_Flag158 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word3_Ptr
(Union_Id_Ptr'
@@ -7231,6 +7713,7 @@ package body Atree is
procedure Set_Flag159 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word3_Ptr
(Union_Id_Ptr'
@@ -7239,6 +7722,7 @@ package body Atree is
procedure Set_Flag160 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word3_Ptr
(Union_Id_Ptr'
@@ -7247,6 +7731,7 @@ package body Atree is
procedure Set_Flag161 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word3_Ptr
(Union_Id_Ptr'
@@ -7255,6 +7740,7 @@ package body Atree is
procedure Set_Flag162 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word3_Ptr
(Union_Id_Ptr'
@@ -7263,6 +7749,7 @@ package body Atree is
procedure Set_Flag163 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word3_Ptr
(Union_Id_Ptr'
@@ -7271,6 +7758,7 @@ package body Atree is
procedure Set_Flag164 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word3_Ptr
(Union_Id_Ptr'
@@ -7279,6 +7767,7 @@ package body Atree is
procedure Set_Flag165 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word3_Ptr
(Union_Id_Ptr'
@@ -7287,6 +7776,7 @@ package body Atree is
procedure Set_Flag166 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word3_Ptr
(Union_Id_Ptr'
@@ -7295,6 +7785,7 @@ package body Atree is
procedure Set_Flag167 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word3_Ptr
(Union_Id_Ptr'
@@ -7303,6 +7794,7 @@ package body Atree is
procedure Set_Flag168 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word3_Ptr
(Union_Id_Ptr'
@@ -7311,6 +7803,7 @@ package body Atree is
procedure Set_Flag169 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word3_Ptr
(Union_Id_Ptr'
@@ -7319,6 +7812,7 @@ package body Atree is
procedure Set_Flag170 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word3_Ptr
(Union_Id_Ptr'
@@ -7327,6 +7821,7 @@ package body Atree is
procedure Set_Flag171 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word3_Ptr
(Union_Id_Ptr'
@@ -7335,6 +7830,7 @@ package body Atree is
procedure Set_Flag172 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word3_Ptr
(Union_Id_Ptr'
@@ -7343,6 +7839,7 @@ package body Atree is
procedure Set_Flag173 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word3_Ptr
(Union_Id_Ptr'
@@ -7351,6 +7848,7 @@ package body Atree is
procedure Set_Flag174 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word3_Ptr
(Union_Id_Ptr'
@@ -7359,6 +7857,7 @@ package body Atree is
procedure Set_Flag175 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word3_Ptr
(Union_Id_Ptr'
@@ -7367,6 +7866,7 @@ package body Atree is
procedure Set_Flag176 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word3_Ptr
(Union_Id_Ptr'
@@ -7375,6 +7875,7 @@ package body Atree is
procedure Set_Flag177 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word3_Ptr
(Union_Id_Ptr'
@@ -7383,6 +7884,7 @@ package body Atree is
procedure Set_Flag178 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word3_Ptr
(Union_Id_Ptr'
@@ -7391,6 +7893,7 @@ package body Atree is
procedure Set_Flag179 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word3_Ptr
(Union_Id_Ptr'
@@ -7399,6 +7902,7 @@ package body Atree is
procedure Set_Flag180 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word3_Ptr
(Union_Id_Ptr'
@@ -7407,6 +7911,7 @@ package body Atree is
procedure Set_Flag181 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word3_Ptr
(Union_Id_Ptr'
@@ -7415,6 +7920,7 @@ package body Atree is
procedure Set_Flag182 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word3_Ptr
(Union_Id_Ptr'
@@ -7423,6 +7929,7 @@ package body Atree is
procedure Set_Flag183 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word3_Ptr
(Union_Id_Ptr'
@@ -7431,6 +7938,7 @@ package body Atree is
procedure Set_Flag184 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word4_Ptr
(Union_Id_Ptr'
@@ -7439,6 +7947,7 @@ package body Atree is
procedure Set_Flag185 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word4_Ptr
(Union_Id_Ptr'
@@ -7447,6 +7956,7 @@ package body Atree is
procedure Set_Flag186 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word4_Ptr
(Union_Id_Ptr'
@@ -7455,6 +7965,7 @@ package body Atree is
procedure Set_Flag187 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word4_Ptr
(Union_Id_Ptr'
@@ -7463,6 +7974,7 @@ package body Atree is
procedure Set_Flag188 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word4_Ptr
(Union_Id_Ptr'
@@ -7471,6 +7983,7 @@ package body Atree is
procedure Set_Flag189 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word4_Ptr
(Union_Id_Ptr'
@@ -7479,6 +7992,7 @@ package body Atree is
procedure Set_Flag190 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word4_Ptr
(Union_Id_Ptr'
@@ -7487,6 +8001,7 @@ package body Atree is
procedure Set_Flag191 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word4_Ptr
(Union_Id_Ptr'
@@ -7495,6 +8010,7 @@ package body Atree is
procedure Set_Flag192 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word4_Ptr
(Union_Id_Ptr'
@@ -7503,6 +8019,7 @@ package body Atree is
procedure Set_Flag193 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word4_Ptr
(Union_Id_Ptr'
@@ -7511,6 +8028,7 @@ package body Atree is
procedure Set_Flag194 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word4_Ptr
(Union_Id_Ptr'
@@ -7519,6 +8037,7 @@ package body Atree is
procedure Set_Flag195 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word4_Ptr
(Union_Id_Ptr'
@@ -7527,6 +8046,7 @@ package body Atree is
procedure Set_Flag196 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word4_Ptr
(Union_Id_Ptr'
@@ -7535,6 +8055,7 @@ package body Atree is
procedure Set_Flag197 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word4_Ptr
(Union_Id_Ptr'
@@ -7543,6 +8064,7 @@ package body Atree is
procedure Set_Flag198 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word4_Ptr
(Union_Id_Ptr'
@@ -7551,6 +8073,7 @@ package body Atree is
procedure Set_Flag199 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word4_Ptr
(Union_Id_Ptr'
@@ -7559,6 +8082,7 @@ package body Atree is
procedure Set_Flag200 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word4_Ptr
(Union_Id_Ptr'
@@ -7567,6 +8091,7 @@ package body Atree is
procedure Set_Flag201 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word4_Ptr
(Union_Id_Ptr'
@@ -7575,6 +8100,7 @@ package body Atree is
procedure Set_Flag202 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word4_Ptr
(Union_Id_Ptr'
@@ -7583,6 +8109,7 @@ package body Atree is
procedure Set_Flag203 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word4_Ptr
(Union_Id_Ptr'
@@ -7591,6 +8118,7 @@ package body Atree is
procedure Set_Flag204 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word4_Ptr
(Union_Id_Ptr'
@@ -7599,6 +8127,7 @@ package body Atree is
procedure Set_Flag205 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word4_Ptr
(Union_Id_Ptr'
@@ -7607,6 +8136,7 @@ package body Atree is
procedure Set_Flag206 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word4_Ptr
(Union_Id_Ptr'
@@ -7615,6 +8145,7 @@ package body Atree is
procedure Set_Flag207 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word4_Ptr
(Union_Id_Ptr'
@@ -7623,6 +8154,7 @@ package body Atree is
procedure Set_Flag208 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word4_Ptr
(Union_Id_Ptr'
@@ -7631,6 +8163,7 @@ package body Atree is
procedure Set_Flag209 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word4_Ptr
(Union_Id_Ptr'
@@ -7639,6 +8172,7 @@ package body Atree is
procedure Set_Flag210 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word4_Ptr
(Union_Id_Ptr'
@@ -7647,6 +8181,7 @@ package body Atree is
procedure Set_Flag211 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word4_Ptr
(Union_Id_Ptr'
@@ -7655,6 +8190,7 @@ package body Atree is
procedure Set_Flag212 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word4_Ptr
(Union_Id_Ptr'
@@ -7663,6 +8199,7 @@ package body Atree is
procedure Set_Flag213 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word4_Ptr
(Union_Id_Ptr'
@@ -7671,6 +8208,7 @@ package body Atree is
procedure Set_Flag214 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word4_Ptr
(Union_Id_Ptr'
@@ -7679,6 +8217,7 @@ package body Atree is
procedure Set_Flag215 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word4_Ptr
(Union_Id_Ptr'
@@ -7687,144 +8226,168 @@ package body Atree is
procedure Set_Flag216 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).In_List := Val;
end Set_Flag216;
procedure Set_Flag217 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Has_Aspects := Val;
end Set_Flag217;
procedure Set_Flag218 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Rewrite_Ins := Val;
end Set_Flag218;
procedure Set_Flag219 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Analyzed := Val;
end Set_Flag219;
procedure Set_Flag220 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Comes_From_Source := Val;
end Set_Flag220;
procedure Set_Flag221 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Error_Posted := Val;
end Set_Flag221;
procedure Set_Flag222 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Flag4 := Val;
end Set_Flag222;
procedure Set_Flag223 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Flag5 := Val;
end Set_Flag223;
procedure Set_Flag224 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Flag6 := Val;
end Set_Flag224;
procedure Set_Flag225 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Flag7 := Val;
end Set_Flag225;
procedure Set_Flag226 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Flag8 := Val;
end Set_Flag226;
procedure Set_Flag227 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Flag9 := Val;
end Set_Flag227;
procedure Set_Flag228 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Flag10 := Val;
end Set_Flag228;
procedure Set_Flag229 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Flag11 := Val;
end Set_Flag229;
procedure Set_Flag230 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Flag12 := Val;
end Set_Flag230;
procedure Set_Flag231 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Flag13 := Val;
end Set_Flag231;
procedure Set_Flag232 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Flag14 := Val;
end Set_Flag232;
procedure Set_Flag233 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Flag15 := Val;
end Set_Flag233;
procedure Set_Flag234 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Flag16 := Val;
end Set_Flag234;
procedure Set_Flag235 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Flag17 := Val;
end Set_Flag235;
procedure Set_Flag236 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Flag18 := Val;
end Set_Flag236;
procedure Set_Flag237 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Pflag1 := Val;
end Set_Flag237;
procedure Set_Flag238 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 4).Pflag2 := Val;
end Set_Flag238;
procedure Set_Flag239 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Byte2_Ptr
(Node_Kind_Ptr'
@@ -7833,6 +8396,7 @@ package body Atree is
procedure Set_Flag240 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Byte2_Ptr
(Node_Kind_Ptr'
@@ -7841,6 +8405,7 @@ package body Atree is
procedure Set_Flag241 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Byte2_Ptr
(Node_Kind_Ptr'
@@ -7849,6 +8414,7 @@ package body Atree is
procedure Set_Flag242 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Byte2_Ptr
(Node_Kind_Ptr'
@@ -7857,6 +8423,7 @@ package body Atree is
procedure Set_Flag243 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Byte2_Ptr
(Node_Kind_Ptr'
@@ -7865,6 +8432,7 @@ package body Atree is
procedure Set_Flag244 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Byte2_Ptr
(Node_Kind_Ptr'
@@ -7873,6 +8441,7 @@ package body Atree is
procedure Set_Flag245 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Byte2_Ptr
(Node_Kind_Ptr'
@@ -7881,6 +8450,7 @@ package body Atree is
procedure Set_Flag246 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Byte2_Ptr
(Node_Kind_Ptr'
@@ -7889,6 +8459,7 @@ package body Atree is
procedure Set_Flag247 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Byte3_Ptr
(Node_Kind_Ptr'
@@ -7897,6 +8468,7 @@ package body Atree is
procedure Set_Flag248 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Byte3_Ptr
(Node_Kind_Ptr'
@@ -7905,6 +8477,7 @@ package body Atree is
procedure Set_Flag249 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Byte3_Ptr
(Node_Kind_Ptr'
@@ -7913,6 +8486,7 @@ package body Atree is
procedure Set_Flag250 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Byte3_Ptr
(Node_Kind_Ptr'
@@ -7921,6 +8495,7 @@ package body Atree is
procedure Set_Flag251 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Byte3_Ptr
(Node_Kind_Ptr'
@@ -7929,6 +8504,7 @@ package body Atree is
procedure Set_Flag252 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Byte3_Ptr
(Node_Kind_Ptr'
@@ -7937,6 +8513,7 @@ package body Atree is
procedure Set_Flag253 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Byte3_Ptr
(Node_Kind_Ptr'
@@ -7945,6 +8522,7 @@ package body Atree is
procedure Set_Flag254 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Byte3_Ptr
(Node_Kind_Ptr'
@@ -7953,6 +8531,7 @@ package body Atree is
procedure Set_Flag255 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word5_Ptr
(Union_Id_Ptr'
@@ -7961,6 +8540,7 @@ package body Atree is
procedure Set_Flag256 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word5_Ptr
(Union_Id_Ptr'
@@ -7969,6 +8549,7 @@ package body Atree is
procedure Set_Flag257 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word5_Ptr
(Union_Id_Ptr'
@@ -7977,6 +8558,7 @@ package body Atree is
procedure Set_Flag258 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word5_Ptr
(Union_Id_Ptr'
@@ -7985,6 +8567,7 @@ package body Atree is
procedure Set_Flag259 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word5_Ptr
(Union_Id_Ptr'
@@ -7993,6 +8576,7 @@ package body Atree is
procedure Set_Flag260 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word5_Ptr
(Union_Id_Ptr'
@@ -8001,6 +8585,7 @@ package body Atree is
procedure Set_Flag261 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word5_Ptr
(Union_Id_Ptr'
@@ -8009,6 +8594,7 @@ package body Atree is
procedure Set_Flag262 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word5_Ptr
(Union_Id_Ptr'
@@ -8017,6 +8603,7 @@ package body Atree is
procedure Set_Flag263 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word5_Ptr
(Union_Id_Ptr'
@@ -8025,6 +8612,7 @@ package body Atree is
procedure Set_Flag264 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word5_Ptr
(Union_Id_Ptr'
@@ -8033,6 +8621,7 @@ package body Atree is
procedure Set_Flag265 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word5_Ptr
(Union_Id_Ptr'
@@ -8041,6 +8630,7 @@ package body Atree is
procedure Set_Flag266 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word5_Ptr
(Union_Id_Ptr'
@@ -8049,6 +8639,7 @@ package body Atree is
procedure Set_Flag267 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word5_Ptr
(Union_Id_Ptr'
@@ -8057,6 +8648,7 @@ package body Atree is
procedure Set_Flag268 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word5_Ptr
(Union_Id_Ptr'
@@ -8065,6 +8657,7 @@ package body Atree is
procedure Set_Flag269 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word5_Ptr
(Union_Id_Ptr'
@@ -8073,6 +8666,7 @@ package body Atree is
procedure Set_Flag270 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word5_Ptr
(Union_Id_Ptr'
@@ -8081,6 +8675,7 @@ package body Atree is
procedure Set_Flag271 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word5_Ptr
(Union_Id_Ptr'
@@ -8089,6 +8684,7 @@ package body Atree is
procedure Set_Flag272 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word5_Ptr
(Union_Id_Ptr'
@@ -8097,6 +8693,7 @@ package body Atree is
procedure Set_Flag273 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word5_Ptr
(Union_Id_Ptr'
@@ -8105,6 +8702,7 @@ package body Atree is
procedure Set_Flag274 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word5_Ptr
(Union_Id_Ptr'
@@ -8113,6 +8711,7 @@ package body Atree is
procedure Set_Flag275 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word5_Ptr
(Union_Id_Ptr'
@@ -8121,6 +8720,7 @@ package body Atree is
procedure Set_Flag276 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word5_Ptr
(Union_Id_Ptr'
@@ -8129,6 +8729,7 @@ package body Atree is
procedure Set_Flag277 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word5_Ptr
(Union_Id_Ptr'
@@ -8137,6 +8738,7 @@ package body Atree is
procedure Set_Flag278 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word5_Ptr
(Union_Id_Ptr'
@@ -8145,6 +8747,7 @@ package body Atree is
procedure Set_Flag279 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word5_Ptr
(Union_Id_Ptr'
@@ -8153,6 +8756,7 @@ package body Atree is
procedure Set_Flag280 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word5_Ptr
(Union_Id_Ptr'
@@ -8161,6 +8765,7 @@ package body Atree is
procedure Set_Flag281 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word5_Ptr
(Union_Id_Ptr'
@@ -8169,6 +8774,7 @@ package body Atree is
procedure Set_Flag282 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word5_Ptr
(Union_Id_Ptr'
@@ -8177,6 +8783,7 @@ package body Atree is
procedure Set_Flag283 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word5_Ptr
(Union_Id_Ptr'
@@ -8185,6 +8792,7 @@ package body Atree is
procedure Set_Flag284 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word5_Ptr
(Union_Id_Ptr'
@@ -8193,6 +8801,7 @@ package body Atree is
procedure Set_Flag285 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word5_Ptr
(Union_Id_Ptr'
@@ -8201,6 +8810,7 @@ package body Atree is
procedure Set_Flag286 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Word5_Ptr
(Union_Id_Ptr'
@@ -8209,144 +8819,168 @@ package body Atree is
procedure Set_Flag287 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).In_List := Val;
end Set_Flag287;
procedure Set_Flag288 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Has_Aspects := Val;
end Set_Flag288;
procedure Set_Flag289 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Rewrite_Ins := Val;
end Set_Flag289;
procedure Set_Flag290 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Analyzed := Val;
end Set_Flag290;
procedure Set_Flag291 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Comes_From_Source := Val;
end Set_Flag291;
procedure Set_Flag292 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Error_Posted := Val;
end Set_Flag292;
procedure Set_Flag293 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Flag4 := Val;
end Set_Flag293;
procedure Set_Flag294 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Flag5 := Val;
end Set_Flag294;
procedure Set_Flag295 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Flag6 := Val;
end Set_Flag295;
procedure Set_Flag296 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Flag7 := Val;
end Set_Flag296;
procedure Set_Flag297 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Flag8 := Val;
end Set_Flag297;
procedure Set_Flag298 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Flag9 := Val;
end Set_Flag298;
procedure Set_Flag299 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Flag10 := Val;
end Set_Flag299;
procedure Set_Flag300 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Flag11 := Val;
end Set_Flag300;
procedure Set_Flag301 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Flag12 := Val;
end Set_Flag301;
procedure Set_Flag302 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Flag13 := Val;
end Set_Flag302;
procedure Set_Flag303 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Flag14 := Val;
end Set_Flag303;
procedure Set_Flag304 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Flag15 := Val;
end Set_Flag304;
procedure Set_Flag305 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Flag16 := Val;
end Set_Flag305;
procedure Set_Flag306 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Flag17 := Val;
end Set_Flag306;
procedure Set_Flag307 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Flag18 := Val;
end Set_Flag307;
procedure Set_Flag308 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Pflag1 := Val;
end Set_Flag308;
procedure Set_Flag309 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
Nodes.Table (N + 5).Pflag2 := Val;
end Set_Flag309;
procedure Set_Flag310 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Byte4_Ptr
(Node_Kind_Ptr'
@@ -8355,6 +8989,7 @@ package body Atree is
procedure Set_Flag311 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Byte4_Ptr
(Node_Kind_Ptr'
@@ -8363,6 +8998,7 @@ package body Atree is
procedure Set_Flag312 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Byte4_Ptr
(Node_Kind_Ptr'
@@ -8371,6 +9007,7 @@ package body Atree is
procedure Set_Flag313 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Byte4_Ptr
(Node_Kind_Ptr'
@@ -8379,6 +9016,7 @@ package body Atree is
procedure Set_Flag314 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Byte4_Ptr
(Node_Kind_Ptr'
@@ -8387,6 +9025,7 @@ package body Atree is
procedure Set_Flag315 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Byte4_Ptr
(Node_Kind_Ptr'
@@ -8395,6 +9034,7 @@ package body Atree is
procedure Set_Flag316 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Byte4_Ptr
(Node_Kind_Ptr'
@@ -8403,6 +9043,7 @@ package body Atree is
procedure Set_Flag317 (N : Node_Id; Val : Boolean) is
begin
+ pragma Assert (not Locked);
pragma Assert (Nkind (N) in N_Entity);
To_Flag_Byte4_Ptr
(Node_Kind_Ptr'
@@ -8411,6 +9052,7 @@ package body Atree is
procedure Set_Node1_With_Parent (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
if Val > Error then
@@ -8422,6 +9064,7 @@ package body Atree is
procedure Set_Node2_With_Parent (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
if Val > Error then
@@ -8433,6 +9076,7 @@ package body Atree is
procedure Set_Node3_With_Parent (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
if Val > Error then
@@ -8444,6 +9088,7 @@ package body Atree is
procedure Set_Node4_With_Parent (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
if Val > Error then
@@ -8455,6 +9100,7 @@ package body Atree is
procedure Set_Node5_With_Parent (N : Node_Id; Val : Node_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
if Val > Error then
@@ -8466,6 +9112,7 @@ package body Atree is
procedure Set_List1_With_Parent (N : Node_Id; Val : List_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
if Val /= No_List and then Val /= Error_List then
Set_Parent (Val, N);
@@ -8475,6 +9122,7 @@ package body Atree is
procedure Set_List2_With_Parent (N : Node_Id; Val : List_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
if Val /= No_List and then Val /= Error_List then
Set_Parent (Val, N);
@@ -8484,6 +9132,7 @@ package body Atree is
procedure Set_List3_With_Parent (N : Node_Id; Val : List_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
if Val /= No_List and then Val /= Error_List then
Set_Parent (Val, N);
@@ -8493,6 +9142,7 @@ package body Atree is
procedure Set_List4_With_Parent (N : Node_Id; Val : List_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
if Val /= No_List and then Val /= Error_List then
Set_Parent (Val, N);
@@ -8502,6 +9152,7 @@ package body Atree is
procedure Set_List5_With_Parent (N : Node_Id; Val : List_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (N <= Nodes.Last);
if Val /= No_List and then Val /= Error_List then
Set_Parent (Val, N);
@@ -8522,4 +9173,14 @@ package body Atree is
Orig_Nodes.Locked := False;
end Unlock;
+ ------------------
+ -- Unlock_Nodes --
+ ------------------
+
+ procedure Unlock_Nodes is
+ begin
+ pragma Assert (Locked);
+ Locked := False;
+ end Unlock_Nodes;
+
end Atree;
diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads
index 0f5b51225d..0f3bef7e51 100644
--- a/gcc/ada/atree.ads
+++ b/gcc/ada/atree.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -76,6 +76,10 @@ package Atree is
-- This value is increased by one if debug flag -gnatd.N is set. This is
-- for testing performance impact of adding a new extension node. We make
-- this of type Node_Id for easy reference in loops using this value.
+ -- Print_Statistics can be used to display statistics on entities & nodes.
+ -- Measurements conducted for the 5->6 bump showed an increase from 1.81 to
+ -- 2.01 for the nodes/entities ratio and a 2% increase in compilation time
+ -- on average for the GCC-based compiler at -O0 on a 32-bit x86 host.
----------------------------------------
-- Definitions of Fields in Tree Node --
@@ -294,10 +298,10 @@ package Atree is
------------------
-- The following variables denote the count of errors of various kinds
- -- detected in the tree. Note that these might be more logically located
- -- in Err_Vars, but we put it to deal with licensing issues (we need this
- -- to have the GPL exception licensing, since Check_Error_Detected can
- -- be called from units with this licensing).
+ -- detected in the tree. Note that these might be more logically located in
+ -- Err_Vars, but we put it here to deal with licensing issues (we need this
+ -- to have the GPL exception licensing, since Check_Error_Detected can be
+ -- called from units with this licensing).
Serious_Errors_Detected : Nat := 0;
-- This is a count of errors that are serious enough to stop expansion,
@@ -401,9 +405,18 @@ package Atree is
-- Called before the back end is invoked to lock the nodes table
-- Also called after Unlock to relock???
+ procedure Lock_Nodes;
+ -- Called to lock node modifications when assertions are enabled; without
+ -- assertions calling this subprogram has no effect. The initial state of
+ -- the lock is unlocked.
+
procedure Unlock;
-- Unlocks nodes table, in cases where the back end needs to modify it
+ procedure Unlock_Nodes;
+ -- Called to unlock entity modifications when assertions are enabled; if
+ -- assertions are not enabled calling this subprogram has no effect.
+
procedure Tree_Read;
-- Initializes internal tables from current tree file using the relevant
-- Table.Tree_Read routines. Note that Initialize should not be called if
@@ -474,8 +487,8 @@ package Atree is
-- The contents of the source node is not affected. If the source node
-- has an extension, then the destination must have an extension also.
-- The parent pointer of the destination and its list link, if any, are
- -- not affected by the copy. Note that parent pointers of descendents
- -- are not adjusted, so the descendents of the destination node after
+ -- not affected by the copy. Note that parent pointers of descendants
+ -- are not adjusted, so the descendants of the destination node after
-- the Copy_Node is completed have dubious parent pointers. Note that
-- this routine does NOT copy aspect specifications, the Has_Aspects
-- flag in the returned node will always be False. The caller must deal
@@ -489,16 +502,16 @@ package Atree is
-- overloaded. The new node will have an extension if the source has
-- an extension. New_Copy (Empty) returns Empty, and New_Copy (Error)
-- returns Error. Note that, unlike Copy_Separate_Tree, New_Copy does not
- -- recursively copy any descendents, so in general parent pointers are not
- -- set correctly for the descendents of the copied node. Both normal and
+ -- recursively copy any descendants, so in general parent pointers are not
+ -- set correctly for the descendants of the copied node. Both normal and
-- extended nodes (entities) may be copied using New_Copy.
function Relocate_Node (Source : Node_Id) return Node_Id;
-- Source is a non-entity node that is to be relocated. A new node is
-- allocated, and the contents of Source are copied to this node, using
- -- New_Copy. The parent pointers of descendents of the node are then
+ -- New_Copy. The parent pointers of descendants of the node are then
-- adjusted to point to the relocated copy. The original node is not
- -- modified, but the parent pointers of its descendents are no longer
+ -- modified, but the parent pointers of its descendants are no longer
-- valid. The new copy is always marked as not overloaded. This routine is
-- used in conjunction with the tree rewrite routines (see descriptions of
-- Replace/Rewrite).
@@ -1063,7 +1076,7 @@ package Atree is
-- original node). Neither Old_Node nor New_Node can be extended nodes.
--
-- Note: New_Node may not contain references to Old_Node, for example as
- -- descendents, since the rewrite would make such references invalid. If
+ -- descendants, since the rewrite would make such references invalid. If
-- New_Node does need to reference Old_Node, then these references should
-- be to a relocated copy of Old_Node (see Relocate_Node procedure).
--
@@ -1082,7 +1095,7 @@ package Atree is
-- preserves the setting of Comes_From_Source.
--
-- Note, New_Node may not contain references to Old_Node, for example as
- -- descendents, since the rewrite would make such references invalid. If
+ -- descendants, since the rewrite would make such references invalid. If
-- New_Node does need to reference Old_Node, then these references should
-- be to a relocated copy of Old_Node (see Relocate_Node procedure).
--
@@ -1469,6 +1482,9 @@ package Atree is
function Elist26 (N : Node_Id) return Elist_Id;
pragma Inline (Elist26);
+ function Elist29 (N : Node_Id) return Elist_Id;
+ pragma Inline (Elist29);
+
function Elist36 (N : Node_Id) return Elist_Id;
pragma Inline (Elist36);
@@ -2832,6 +2848,9 @@ package Atree is
procedure Set_Elist26 (N : Node_Id; Val : Elist_Id);
pragma Inline (Set_Elist26);
+ procedure Set_Elist29 (N : Node_Id; Val : Elist_Id);
+ pragma Inline (Set_Elist29);
+
procedure Set_Elist36 (N : Node_Id; Val : Elist_Id);
pragma Inline (Set_Elist36);
@@ -4196,6 +4215,7 @@ package Atree is
Table_Low_Bound => First_Node_Id,
Table_Initial => Alloc.Nodes_Initial,
Table_Increment => Alloc.Nodes_Increment,
+ Release_Threshold => Alloc.Nodes_Release_Threshold,
Table_Name => "Nodes");
-- The following is a parallel table to Nodes, which provides 8 more
@@ -4241,6 +4261,7 @@ package Atree is
Table_Low_Bound => First_Node_Id,
Table_Initial => Alloc.Nodes_Initial,
Table_Increment => Alloc.Nodes_Increment,
+ Release_Threshold => Alloc.Nodes_Release_Threshold,
Table_Name => "Flags");
end Atree_Private_Part;
diff --git a/gcc/ada/atree.h b/gcc/ada/atree.h
index a2159c8377..e09f7e2c9f 100644
--- a/gcc/ada/atree.h
+++ b/gcc/ada/atree.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2015, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2016, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -526,6 +526,7 @@ extern Node_Id Current_Error_Node;
#define Elist24(N) Field24 (N)
#define Elist25(N) Field25 (N)
#define Elist26(N) Field26 (N)
+#define Elist29(N) Field29 (N)
#define Elist36(N) Field36 (N)
#define Name1(N) Field1 (N)
diff --git a/gcc/ada/bcheck.adb b/gcc/ada/bcheck.adb
index 66341b4431..fa83f89983 100644
--- a/gcc/ada/bcheck.adb
+++ b/gcc/ada/bcheck.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -517,7 +517,7 @@ package body Bcheck is
("? { which has static elaboration " &
"checks");
- Warnings_Detected := Warnings_Detected - 1;
+ Warnings_Detected := Warnings_Detected + 1;
end if;
end;
end if;
diff --git a/gcc/ada/binde.adb b/gcc/ada/binde.adb
index 785afa56f2..2becc1b43b 100644
--- a/gcc/ada/binde.adb
+++ b/gcc/ada/binde.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,21 +27,70 @@ with Binderr; use Binderr;
with Butil; use Butil;
with Debug; use Debug;
with Fname; use Fname;
-with Namet; use Namet;
with Opt; use Opt;
with Osint;
with Output; use Output;
+with Table;
with System.Case_Util; use System.Case_Util;
+with System.OS_Lib;
package body Binde is
+ -- We now have Elab_New, a new elaboration-order algorithm.
+ --
+ -- However, any change to elaboration order can break some programs.
+ -- Therefore, we are keeping the old algorithm in place, to be selected
+ -- by switches.
+ --
+ -- The new algorithm has the following interesting properties:
+ --
+ -- * The static and dynamic models use the same elaboration order. The
+ -- static model might get an error, but if it does not, it will use
+ -- the same order as the dynamic model.
+ --
+ -- * Each SCC (see below) is elaborated together; that is, units from
+ -- different SCCs are not interspersed.
+ --
+ -- * In particular, this implies that if an SCC contains just a spec and
+ -- the corresponding body, and nothing else, the body will be
+ -- elaborated immediately after the spec. This is expected to result
+ -- in a better elaboration order for most programs, because in this
+ -- case, a call from outside the library unit cannot get ABE.
+ --
+ -- * Pragmas Elaborate_All (explicit and implicit) are ignored. Instead,
+ -- we behave as if every legal pragma Elaborate_All were present. That
+ -- is, if it would be legal to have "pragma Elaborate_All(Y);" on X,
+ -- then we behave as if such a pragma exists, even if it does not.
+
+ Do_Old : constant Boolean := False;
+ Do_New : constant Boolean := True;
+ -- True to enable the old and new algorithms, respectively. Used for
+ -- debugging/experimentation.
+
+ Doing_New : Boolean := False;
+ -- True if we are currently doing the new algorithm. Print certain
+ -- messages only when doing the "new" elab order algorithm, so we don't get
+ -- duplicates. And use different heuristics in Better_Choice_Optimistic.
+
-- The following data structures are used to represent the graph that is
-- used to determine the elaboration order (using a topological sort).
- -- The following structures are used to record successors. If A is a
- -- successor of B in this table, it means that A must be elaborated
- -- before B is elaborated.
+ -- The following structures are used to record successors. If B is a
+ -- successor of A in this table, it means that A must be elaborated before
+ -- B is elaborated. For example, if Y (body) says "with X;", then Y (body)
+ -- will be a successor of X (spec), and X (spec) will be a predecessor of
+ -- Y (body).
+ --
+ -- Note that we store the successors of each unit explicitly. We don't
+ -- store the predecessors, but we store a count of them.
+ --
+ -- The basic algorithm is to first compute a directed graph of units (type
+ -- Unit_Node_Record, below), with successors as edges. A unit is "ready"
+ -- (to be chosen as the next to be elaborated) if it has no predecessors
+ -- that have not yet been chosen. We use heuristics to decide which of the
+ -- ready units should be elaborated next, and "choose" that one (which
+ -- means we append it to the elaboration-order table).
type Successor_Id is new Nat;
-- Identification of single successor entry
@@ -62,25 +111,29 @@ package body Binde is
-- After directly with's Before, so the spec of Before must be
-- elaborated before After is elaborated.
+ Forced,
+ -- Before and After come from a pair of lines in the forced elaboration
+ -- order file.
+
Elab,
- -- After directly mentions Before in a pragma Elaborate, so the
- -- body of Before must be elaborate before After is elaborated.
+ -- After directly mentions Before in a pragma Elaborate, so the body of
+ -- Before must be elaborated before After is elaborated.
Elab_All,
- -- After either mentions Before directly in a pragma Elaborate_All,
- -- or mentions a third unit, X, which itself requires that Before be
- -- elaborated before unit X is elaborated. The Elab_All_Link list
- -- traces the dependencies in the latter case.
+ -- After either mentions Before directly in a pragma Elaborate_All, or
+ -- mentions a third unit, X, which itself requires that Before be
+ -- elaborated before unit X is elaborated. The Elab_All_Link list traces
+ -- the dependencies in the latter case.
Elab_All_Desirable,
- -- This is just like Elab_All, except that the elaborate all was not
- -- explicitly present in the source, but rather was created by the
- -- front end, which decided that it was "desirable".
+ -- This is just like Elab_All, except that the Elaborate_All was not
+ -- explicitly present in the source, but rather was created by the front
+ -- end, which decided that it was "desirable".
Elab_Desirable,
- -- This is just like Elab, except that the elaborate was not
- -- explicitly present in the source, but rather was created by the
- -- front end, which decided that it was "desirable".
+ -- This is just like Elab, except that the Elaborate was not explicitly
+ -- present in the source, but rather was created by the front end, which
+ -- decided that it was "desirable".
Spec_First);
-- After is a body, and Before is the corresponding spec
@@ -110,34 +163,33 @@ package body Binde is
Elab_All_Link : Elab_All_Id;
-- If Reason = Elab_All or Elab_Desirable, then this points to the
- -- first elment in a list of Elab_All entries that record the with
- -- chain leading resulting in this particular dependency.
-
+ -- first element in a list of Elab_All entries that record the with
+ -- chain resulting in this particular dependency.
end record;
-- Note on handling of Elaborate_Body. Basically, if we have a pragma
- -- Elaborate_Body in a unit, it means that the spec and body have to
- -- be handled as a single entity from the point of view of determining
- -- an elaboration order. What we do is to essentially remove the body
- -- from consideration completely, and transfer all its links (other
- -- than the spec link) to the spec. Then when then the spec gets chosen,
- -- we choose the body right afterwards. We mark the links that get moved
- -- from the body to the spec by setting their Elab_Body flag True, so
- -- that we can understand what is going on.
+ -- Elaborate_Body in a unit, it means that the spec and body have to be
+ -- handled as a single entity from the point of view of determining an
+ -- elaboration order. What we do is to essentially remove the body from
+ -- consideration completely, and transfer all its links (other than the
+ -- spec link) to the spec. Then when the spec gets chosen, we choose the
+ -- body right afterwards. We mark the links that get moved from the body to
+ -- the spec by setting their Elab_Body flag True, so that we can understand
+ -- what is going on.
Succ_First : constant := 1;
- package Succ is new Table.Table (
- Table_Component_Type => Successor_Link,
- Table_Index_Type => Successor_Id,
- Table_Low_Bound => Succ_First,
- Table_Initial => 500,
- Table_Increment => 200,
- Table_Name => "Succ");
+ package Succ is new Table.Table
+ (Table_Component_Type => Successor_Link,
+ Table_Index_Type => Successor_Id,
+ Table_Low_Bound => Succ_First,
+ Table_Initial => 500,
+ Table_Increment => 200,
+ Table_Name => "Succ");
-- For the case of Elaborate_All, the following table is used to record
- -- chains of with relationships that lead to the Elab_All link. These
- -- are used solely for diagnostic purposes
+ -- chains of with relationships that lead to the Elab_All link. These are
+ -- used solely for diagnostic purposes
type Elab_All_Entry is record
Needed_By : Unit_Name_Type;
@@ -148,50 +200,74 @@ package body Binde is
-- Link to next entry on chain (No_Elab_All_Link marks end of list)
end record;
- package Elab_All_Entries is new Table.Table (
- Table_Component_Type => Elab_All_Entry,
- Table_Index_Type => Elab_All_Id,
- Table_Low_Bound => 1,
- Table_Initial => 2000,
- Table_Increment => 200,
- Table_Name => "Elab_All_Entries");
+ package Elab_All_Entries is new Table.Table
+ (Table_Component_Type => Elab_All_Entry,
+ Table_Index_Type => Elab_All_Id,
+ Table_Low_Bound => 1,
+ Table_Initial => 2000,
+ Table_Increment => 200,
+ Table_Name => "Elab_All_Entries");
- -- A Unit_Node record is built for each active unit
+ type Unit_Id_Array_Ptr is access Unit_Id_Array;
- type Unit_Node_Record is record
+ -- A Unit_Node_Record is built for each active unit
+ type Unit_Node_Record is record
Successors : Successor_Id;
-- Pointer to list of links for successor nodes
Num_Pred : Int;
- -- Number of predecessors for this unit. Normally non-negative, but
- -- can go negative in the case of units chosen by the diagnose error
- -- procedure (when cycles are being removed from the graph).
+ -- Number of predecessors for this unit that have not yet been chosen.
+ -- Normally non-negative, but can go negative in the case of units
+ -- chosen by the diagnose error procedure (when cycles are being removed
+ -- from the graph).
Nextnp : Unit_Id;
-- Forward pointer for list of units with no predecessors
- Elab_Order : Nat;
- -- Position in elaboration order (zero = not placed yet)
-
Visited : Boolean;
- -- Used in computing transitive closure for elaborate all and
- -- also in locating cycles and paths in the diagnose routines.
+ -- Used in computing transitive closure for Elaborate_All and also in
+ -- locating cycles and paths in the diagnose routines.
Elab_Position : Natural;
- -- Initialized to zero. Set non-zero when a unit is chosen and
- -- placed in the elaboration order. The value represents the
- -- ordinal position in the elaboration order.
-
+ -- Initialized to zero. Set non-zero when a unit is chosen and placed in
+ -- the elaboration order. The value represents the ordinal position in
+ -- the elaboration order.
+
+ -- The following are for Elab_New. We compute the strongly connected
+ -- components (SCCs) of the directed graph of units. The edges are the
+ -- Successors, which do not include pragmas Elaborate_All (explicit or
+ -- implicit) in Elab_New. In addition, we assume there is a edge
+ -- pointing from a body to its corresponding spec; this edge is not
+ -- included in Successors, because of course a spec is elaborated BEFORE
+ -- its body, not after.
+
+ SCC_Root : Unit_Id;
+ -- Each unit points to the root of its SCC, which is just an arbitrary
+ -- member of the SCC. Two units are in the same SCC if and only if their
+ -- SCC_Roots are equal. U is the root of its SCC if and only if
+ -- SCC(U)=U.
+
+ Nodes : Unit_Id_Array_Ptr;
+ -- Present only in the root of an SCC. This is the set of units in the
+ -- SCC, in no particular order.
+
+ SCC_Num_Pred : Int;
+ -- Present only in the root of an SCC. This is the number of predecessor
+ -- units of the SCC that are in other SCCs, and that have not yet been
+ -- chosen.
+
+ Validate_Seen : Boolean := False;
+ -- See procedure Validate below
end record;
- package UNR is new Table.Table (
- Table_Component_Type => Unit_Node_Record,
- Table_Index_Type => Unit_Id,
- Table_Low_Bound => First_Unit_Entry,
- Table_Initial => 500,
- Table_Increment => 200,
- Table_Name => "UNR");
+ package UNR is new Table.Table
+ (Table_Component_Type => Unit_Node_Record,
+ Table_Index_Type => Unit_Id,
+ Table_Low_Bound => First_Unit_Entry,
+ Table_Initial => 500,
+ Table_Increment => 200,
+ Table_Name => "UNR");
No_Pred : Unit_Id;
-- Head of list of items with no predecessors
@@ -200,17 +276,31 @@ package body Binde is
-- Number of entries not yet dealt with
Cur_Unit : Unit_Id;
- -- Current unit, set by Gather_Dependencies, and picked up in Build_Link
- -- to set the Reason_Unit field of the created dependency link.
+ -- Current unit, set by Gather_Dependencies, and picked up in Build_Link to
+ -- set the Reason_Unit field of the created dependency link.
- Num_Chosen : Natural := 0;
+ Num_Chosen : Natural;
-- Number of units chosen in the elaboration order so far
-----------------------
-- Local Subprograms --
-----------------------
- function Better_Choice (U1, U2 : Unit_Id) return Boolean;
+ function Debug_Flag_Older return Boolean;
+ function Debug_Flag_Old return Boolean;
+ -- True if debug flags select the old or older algorithms. Pretty much any
+ -- change to elaboration order can break some programs. For example,
+ -- programs can depend on elaboration order even without failing
+ -- access-before-elaboration checks. A trivial example is a program that
+ -- prints text during elaboration. Therefore, we have flags to revert to
+ -- the old(er) algorithms.
+
+ procedure Validate (Order : Unit_Id_Array; Doing_New : Boolean);
+ -- Assert that certain properties are true
+
+ function Better_Choice_Optimistic
+ (U1 : Unit_Id;
+ U2 : Unit_Id) return Boolean;
-- U1 and U2 are both permitted candidates for selection as the next unit
-- to be elaborated. This function determines whether U1 is a better choice
-- than U2, i.e. should be elaborated in preference to U2, based on a set
@@ -218,6 +308,18 @@ package body Binde is
-- for details). The result is True if U1 is a better choice than U2, and
-- False if it is a worse choice, or there is no preference between them.
+ function Better_Choice_Pessimistic
+ (U1 : Unit_Id;
+ U2 : Unit_Id) return Boolean;
+ -- This is like Better_Choice_Optimistic, and has the same interface, but
+ -- returns true if U1 is a worse choice than U2 in the sense of the -p
+ -- (pessimistic elaboration order) switch. We still have to obey Ada rules,
+ -- so it is not quite the direct inverse of Better_Choice_Optimistic.
+
+ function Better_Choice (U1 : Unit_Id; U2 : Unit_Id) return Boolean;
+ -- Calls Better_Choice_Optimistic or Better_Choice_Pessimistic as
+ -- appropriate. Also takes care of the U2 = No_Unit_Id case.
+
procedure Build_Link
(Before : Unit_Id;
After : Unit_Id;
@@ -227,23 +329,24 @@ package body Binde is
-- the reason for the link is R. Ea_Id is the contents to be placed in the
-- Elab_All_Link of the entry.
- procedure Choose (Chosen : Unit_Id);
+ procedure Choose (Elab_Order : in out Unit_Id_Table; Chosen : Unit_Id);
-- Chosen is the next entry chosen in the elaboration order. This procedure
-- updates all data structures appropriately.
function Corresponding_Body (U : Unit_Id) return Unit_Id;
pragma Inline (Corresponding_Body);
- -- Given a unit which is a spec for which there is a separate body, return
+ -- Given a unit that is a spec for which there is a separate body, return
-- the unit id of the body. It is an error to call this routine with a unit
- -- that is not a spec, or which does not have a separate body.
+ -- that is not a spec, or that does not have a separate body.
function Corresponding_Spec (U : Unit_Id) return Unit_Id;
pragma Inline (Corresponding_Spec);
- -- Given a unit which is a body for which there is a separate spec, return
+ -- Given a unit that is a body for which there is a separate spec, return
-- the unit id of the spec. It is an error to call this routine with a unit
- -- that is not a body, or which does not have a separate spec.
+ -- that is not a body, or that does not have a separate spec.
- procedure Diagnose_Elaboration_Problem;
+ procedure Diagnose_Elaboration_Problem
+ (Elab_Order : in out Unit_Id_Table);
-- Called when no elaboration order can be found. Outputs an appropriate
-- diagnosis of the problem, and then abandons the bind.
@@ -254,23 +357,29 @@ package body Binde is
Link : Elab_All_Id);
-- Used to compute the transitive closure of elaboration links for an
-- Elaborate_All pragma (Reason = Elab_All) or for an indication of
- -- Elaborate_All_Desirable (Reason = Elab_All_Desirable). Unit After has
- -- a pragma Elaborate_All or the front end has determined that a reference
- -- probably requires Elaborate_All is required, and unit Before must be
- -- previously elaborated. First a link is built making sure that unit
- -- Before is elaborated before After, then a recursive call ensures that
- -- we also build links for any units needed by Before (i.e. these units
- -- must/should also be elaborated before After). Link is used to build
- -- a chain of Elab_All_Entries to explain the reason for a link. The
- -- value passed is the chain so far.
+ -- Elaborate_All_Desirable (Reason = Elab_All_Desirable). Unit After has a
+ -- pragma Elaborate_All or the front end has determined that a reference
+ -- probably requires Elaborate_All, and unit Before must be previously
+ -- elaborated. First a link is built making sure that unit Before is
+ -- elaborated before After, then a recursive call ensures that we also
+ -- build links for any units needed by Before (i.e. these units must/should
+ -- also be elaborated before After). Link is used to build a chain of
+ -- Elab_All_Entries to explain the reason for a link. The value passed is
+ -- the chain so far.
procedure Elab_Error_Msg (S : Successor_Id);
-- Given a successor link, outputs an error message of the form
-- "$ must be elaborated before $ ..." where ... is the reason.
+ procedure Force_Elab_Order;
+ -- Gather dependencies from the forced elaboration order file (-f switch)
+
procedure Gather_Dependencies;
-- Compute dependencies, building the Succ and UNR tables
+ procedure Init;
+ -- Initialize global data structures in this package body
+
function Is_Body_Unit (U : Unit_Id) return Boolean;
pragma Inline (Is_Body_Unit);
-- Determines if given unit is a body
@@ -281,24 +390,22 @@ package body Binde is
function Is_Waiting_Body (U : Unit_Id) return Boolean;
pragma Inline (Is_Waiting_Body);
- -- Determines if U is a waiting body, defined as a body which has
+ -- Determines if U is a waiting body, defined as a body that has
-- not been elaborated, but whose spec has been elaborated.
- function Make_Elab_Entry
+ function Make_Elab_All_Entry
(Unam : Unit_Name_Type;
Link : Elab_All_Id) return Elab_All_Id;
-- Make an Elab_All_Entries table entry with the given Unam and Link
- function Pessimistic_Better_Choice (U1, U2 : Unit_Id) return Boolean;
- -- This is like Better_Choice, and has the same interface, but returns
- -- true if U1 is a worse choice than U2 in the sense of the -p (pessimistic
- -- elaboration order) switch. We still have to obey Ada rules, so it is
- -- not quite the direct inverse of Better_Choice.
-
function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id;
-- This function uses the Info field set in the names table to obtain
-- the unit Id of a unit, given its name id value.
+ procedure Write_Closure (Order : Unit_Id_Array);
+ -- Write the closure. This is for the -R and -Ra switches, "list closure
+ -- display".
+
procedure Write_Dependencies;
-- Write out dependencies (called only if appropriate option is set)
@@ -306,17 +413,79 @@ package body Binde is
-- If the reason for the link S is Elaborate_All or Elaborate_Desirable,
-- then this routine will output the "needed by" explanation chain.
+ procedure Write_Elab_Order (Order : Unit_Id_Array; Title : String);
+ -- Display elaboration order. This is for the -l switch. Title is a heading
+ -- to print; an empty string is passed to indicate Zero_Formatting.
+
+ package Elab_New is
+
+ -- Implementation of the new algorithm
+
+ procedure Write_SCC (U : Unit_Id);
+ -- Write the unit names of the units in the SCC in which U lives
+
+ procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table);
+
+ Illegal_Elab_All : Boolean := False;
+ -- Set true if Find_Elab_Order found an illegal pragma Elaborate_All
+ -- (explicit or implicit).
+
+ function SCC (U : Unit_Id) return Unit_Id;
+ -- The root of the strongly connected component containing U
+
+ function SCC_Num_Pred (U : Unit_Id) return Int;
+ -- The SCC_Num_Pred of the SCC in which U lives
+
+ function Nodes (U : Unit_Id) return Unit_Id_Array_Ptr;
+ -- The nodes of the strongly connected component containing U
+
+ end Elab_New;
+
+ use Elab_New;
+
+ package Elab_Old is
+
+ -- Implementation of the old algorithm
+
+ procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table);
+
+ end Elab_Old;
+
+ -- Most of the code is shared between old and new; such code is outside
+ -- packages Elab_Old and Elab_New.
+
-------------------
-- Better_Choice --
-------------------
- function Better_Choice (U1, U2 : Unit_Id) return Boolean is
+ function Better_Choice (U1 : Unit_Id; U2 : Unit_Id) return Boolean is
+ pragma Assert (U1 /= No_Unit_Id);
+ begin
+ if U2 = No_Unit_Id then
+ return True;
+ end if;
+
+ if Pessimistic_Elab_Order then
+ return Better_Choice_Pessimistic (U1, U2);
+ else
+ return Better_Choice_Optimistic (U1, U2);
+ end if;
+ end Better_Choice;
+
+ ------------------------------
+ -- Better_Choice_Optimistic --
+ ------------------------------
+
+ function Better_Choice_Optimistic
+ (U1 : Unit_Id;
+ U2 : Unit_Id) return Boolean
+ is
UT1 : Unit_Record renames Units.Table (U1);
UT2 : Unit_Record renames Units.Table (U2);
begin
if Debug_Flag_B then
- Write_Str ("Better_Choice (");
+ Write_Str ("Better_Choice_Optimistic (");
Write_Unit_Name (UT1.Uname);
Write_Str (", ");
Write_Unit_Name (UT2.Uname);
@@ -373,7 +542,8 @@ package body Binde is
return False;
- -- Prefer a pure or preelaborable unit to one that is not
+ -- Prefer a pure or preelaborated unit to one that is not. Pure should
+ -- come before preelaborated.
elsif Is_Pure_Or_Preelab_Unit (U1)
and then not
@@ -411,23 +581,23 @@ package body Binde is
return False;
- -- If both are waiting bodies, then prefer the one whose spec is
- -- more recently elaborated. Consider the following:
+ -- If both are waiting bodies, then prefer the one whose spec is more
+ -- recently elaborated. Consider the following:
-- spec of A
-- spec of B
-- body of A or B?
- -- The normal waiting body preference would have placed the body of
- -- A before the spec of B if it could. Since it could not, there it
- -- must be the case that A depends on B. It is therefore a good idea
- -- to put the body of B first.
+ -- The normal waiting body preference would have placed the body of A
+ -- before the spec of B if it could. Since it could not, then it must be
+ -- the case that A depends on B. It is therefore a good idea to put the
+ -- body of B first.
elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then
declare
Result : constant Boolean :=
- UNR.Table (Corresponding_Spec (U1)).Elab_Position >
- UNR.Table (Corresponding_Spec (U2)).Elab_Position;
+ UNR.Table (Corresponding_Spec (U1)).Elab_Position >
+ UNR.Table (Corresponding_Spec (U2)).Elab_Position;
begin
if Debug_Flag_B then
if Result then
@@ -443,9 +613,9 @@ package body Binde is
-- Remaining choice rules are disabled by Debug flag -do
- if not Debug_Flag_O then
+ if not Debug_Flag_Older then
- -- The following deal with the case of specs which have been marked
+ -- The following deal with the case of specs that have been marked
-- as Elaborate_Body_Desirable. We generally want to delay these
-- specs as long as possible, so that the bodies have a better chance
-- of being elaborated closer to the specs.
@@ -482,8 +652,8 @@ package body Binde is
then
declare
Result : constant Boolean :=
- UNR.Table (Corresponding_Body (U1)).Num_Pred <
- UNR.Table (Corresponding_Body (U2)).Num_Pred;
+ UNR.Table (Corresponding_Body (U1)).Num_Pred <
+ UNR.Table (Corresponding_Body (U2)).Num_Pred;
begin
if Debug_Flag_B then
if Result then
@@ -498,6 +668,41 @@ package body Binde is
end if;
end if;
+ -- If we have two specs in the same SCC, choose the one whose body is
+ -- closer to being ready.
+
+ if Doing_New
+ and then SCC (U1) = SCC (U2)
+ and then Units.Table (U1).Utype = Is_Spec
+ and then Units.Table (U2).Utype = Is_Spec
+ and then UNR.Table (Corresponding_Body (U1)).Num_Pred /=
+ UNR.Table (Corresponding_Body (U2)).Num_Pred
+ then
+ if UNR.Table (Corresponding_Body (U1)).Num_Pred <
+ UNR.Table (Corresponding_Body (U2)).Num_Pred
+ then
+ if Debug_Flag_B then
+ Write_Str (" True: same SCC; ");
+ Write_Int (UNR.Table (Corresponding_Body (U1)).Num_Pred);
+ Write_Str (" < ");
+ Write_Int (UNR.Table (Corresponding_Body (U2)).Num_Pred);
+ Write_Eol;
+ end if;
+
+ return True;
+ else
+ if Debug_Flag_B then
+ Write_Str (" False: same SCC; ");
+ Write_Int (UNR.Table (Corresponding_Body (U1)).Num_Pred);
+ Write_Str (" > ");
+ Write_Int (UNR.Table (Corresponding_Body (U2)).Num_Pred);
+ Write_Eol;
+ end if;
+
+ return False;
+ end if;
+ end if;
+
-- If we fall through, it means that no preference rule applies, so we
-- use alphabetical order to at least give a deterministic result.
@@ -506,7 +711,226 @@ package body Binde is
end if;
return Uname_Less (UT1.Uname, UT2.Uname);
- end Better_Choice;
+ end Better_Choice_Optimistic;
+
+ -------------------------------
+ -- Better_Choice_Pessimistic --
+ -------------------------------
+
+ function Better_Choice_Pessimistic
+ (U1 : Unit_Id;
+ U2 : Unit_Id) return Boolean
+ is
+ UT1 : Unit_Record renames Units.Table (U1);
+ UT2 : Unit_Record renames Units.Table (U2);
+
+ begin
+ if Debug_Flag_B then
+ Write_Str ("Better_Choice_Pessimistic (");
+ Write_Unit_Name (UT1.Uname);
+ Write_Str (", ");
+ Write_Unit_Name (UT2.Uname);
+ Write_Line (")");
+ end if;
+
+ -- Note: the checks here are applied in sequence, and the ordering is
+ -- significant (i.e. the more important criteria are applied first).
+
+ -- If either unit is predefined or internal, then we use the normal
+ -- Better_Choice_Optimistic rule, since we don't want to disturb the
+ -- elaboration rules of the language with -p; same treatment for
+ -- Pure/Preelab.
+
+ -- Prefer a predefined unit to a non-predefined unit
+
+ if UT1.Predefined and then not UT2.Predefined then
+ if Debug_Flag_B then
+ Write_Line (" True: u1 is predefined, u2 is not");
+ end if;
+
+ return True;
+
+ elsif UT2.Predefined and then not UT1.Predefined then
+ if Debug_Flag_B then
+ Write_Line (" False: u2 is predefined, u1 is not");
+ end if;
+
+ return False;
+
+ -- Prefer an internal unit to a non-internal unit
+
+ elsif UT1.Internal and then not UT2.Internal then
+ if Debug_Flag_B then
+ Write_Line (" True: u1 is internal, u2 is not");
+ end if;
+
+ return True;
+
+ elsif UT2.Internal and then not UT1.Internal then
+ if Debug_Flag_B then
+ Write_Line (" False: u2 is internal, u1 is not");
+ end if;
+
+ return False;
+
+ -- Prefer a pure or preelaborated unit to one that is not
+
+ elsif Is_Pure_Or_Preelab_Unit (U1)
+ and then not
+ Is_Pure_Or_Preelab_Unit (U2)
+ then
+ if Debug_Flag_B then
+ Write_Line (" True: u1 is pure/preelab, u2 is not");
+ end if;
+
+ return True;
+
+ elsif Is_Pure_Or_Preelab_Unit (U2)
+ and then not
+ Is_Pure_Or_Preelab_Unit (U1)
+ then
+ if Debug_Flag_B then
+ Write_Line (" False: u2 is pure/preelab, u1 is not");
+ end if;
+
+ return False;
+
+ -- Prefer anything else to a waiting body. We want to make bodies wait
+ -- as long as possible, till we are forced to choose them.
+
+ elsif Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then
+ if Debug_Flag_B then
+ Write_Line (" False: u1 is waiting body, u2 is not");
+ end if;
+
+ return False;
+
+ elsif Is_Waiting_Body (U2) and then not Is_Waiting_Body (U1) then
+ if Debug_Flag_B then
+ Write_Line (" True: u2 is waiting body, u1 is not");
+ end if;
+
+ return True;
+
+ -- Prefer a spec to a body (this is mandatory)
+
+ elsif Is_Body_Unit (U1) and then not Is_Body_Unit (U2) then
+ if Debug_Flag_B then
+ Write_Line (" False: u1 is body, u2 is not");
+ end if;
+
+ return False;
+
+ elsif Is_Body_Unit (U2) and then not Is_Body_Unit (U1) then
+ if Debug_Flag_B then
+ Write_Line (" True: u2 is body, u1 is not");
+ end if;
+
+ return True;
+
+ -- If both are waiting bodies, then prefer the one whose spec is less
+ -- recently elaborated. Consider the following:
+
+ -- spec of A
+ -- spec of B
+ -- body of A or B?
+
+ -- The normal waiting body preference would have placed the body of A
+ -- before the spec of B if it could. Since it could not, then it must be
+ -- the case that A depends on B. It is therefore a good idea to put the
+ -- body of B last so that if there is an elaboration order problem, we
+ -- will find it (that's what pessimistic order is about).
+
+ elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then
+ declare
+ Result : constant Boolean :=
+ UNR.Table (Corresponding_Spec (U1)).Elab_Position <
+ UNR.Table (Corresponding_Spec (U2)).Elab_Position;
+ begin
+ if Debug_Flag_B then
+ if Result then
+ Write_Line (" True: based on waiting body elab positions");
+ else
+ Write_Line (" False: based on waiting body elab positions");
+ end if;
+ end if;
+
+ return Result;
+ end;
+ end if;
+
+ -- Remaining choice rules are disabled by Debug flag -do
+
+ if not Debug_Flag_Older then
+
+ -- The following deal with the case of specs that have been marked as
+ -- Elaborate_Body_Desirable. In the normal case, we generally want to
+ -- delay the elaboration of these specs as long as possible, so that
+ -- bodies have better chance of being elaborated closer to the specs.
+ -- Better_Choice_Pessimistic as usual wants to do the opposite and
+ -- elaborate such specs as early as possible.
+
+ -- If we have two units, one of which is a spec for which this flag
+ -- is set, and the other is not, we normally prefer to delay the spec
+ -- for which the flag is set, so again Better_Choice_Pessimistic does
+ -- the opposite.
+
+ if not UT1.Elaborate_Body_Desirable
+ and then UT2.Elaborate_Body_Desirable
+ then
+ if Debug_Flag_B then
+ Write_Line (" False: u1 is elab body desirable, u2 is not");
+ end if;
+
+ return False;
+
+ elsif not UT2.Elaborate_Body_Desirable
+ and then UT1.Elaborate_Body_Desirable
+ then
+ if Debug_Flag_B then
+ Write_Line (" True: u1 is elab body desirable, u2 is not");
+ end if;
+
+ return True;
+
+ -- If we have two specs that are both marked as Elaborate_Body
+ -- desirable, we normally prefer the one whose body is nearer to
+ -- being able to be elaborated, based on the Num_Pred count. This
+ -- helps to ensure bodies are as close to specs as possible. As
+ -- usual, Better_Choice_Pessimistic does the opposite.
+
+ elsif UT1.Elaborate_Body_Desirable
+ and then UT2.Elaborate_Body_Desirable
+ then
+ declare
+ Result : constant Boolean :=
+ UNR.Table (Corresponding_Body (U1)).Num_Pred >=
+ UNR.Table (Corresponding_Body (U2)).Num_Pred;
+ begin
+ if Debug_Flag_B then
+ if Result then
+ Write_Line (" True based on Num_Pred compare");
+ else
+ Write_Line (" False based on Num_Pred compare");
+ end if;
+ end if;
+
+ return Result;
+ end;
+ end if;
+ end if;
+
+ -- If we fall through, it means that no preference rule applies, so we
+ -- use alphabetical order to at least give a deterministic result. Since
+ -- Better_Choice_Pessimistic is in the business of stirring up the
+ -- order, we will use reverse alphabetical ordering.
+
+ if Debug_Flag_B then
+ Write_Line (" choose on reverse alpha order");
+ end if;
+
+ return Uname_Less (UT2.Uname, UT1.Uname);
+ end Better_Choice_Pessimistic;
----------------
-- Build_Link --
@@ -521,13 +945,15 @@ package body Binde is
Cspec : Unit_Id;
begin
- Succ.Increment_Last;
- Succ.Table (Succ.Last).Before := Before;
- Succ.Table (Succ.Last).Next := UNR.Table (Before).Successors;
- UNR.Table (Before).Successors := Succ.Last;
- Succ.Table (Succ.Last).Reason := R;
- Succ.Table (Succ.Last).Reason_Unit := Cur_Unit;
- Succ.Table (Succ.Last).Elab_All_Link := Ea_Id;
+ Succ.Append
+ ((Before => Before,
+ After => No_Unit_Id, -- filled in below
+ Next => UNR.Table (Before).Successors,
+ Reason => R,
+ Elab_Body => False, -- set correctly below
+ Reason_Unit => Cur_Unit,
+ Elab_All_Link => Ea_Id));
+ UNR.Table (Before).Successors := Succ.Last;
-- Deal with special Elab_Body case. If the After of this link is
-- a body whose spec has Elaborate_All set, and this is not the link
@@ -549,16 +975,17 @@ package body Binde is
-- Fall through on normal case
- Succ.Table (Succ.Last).After := After;
- Succ.Table (Succ.Last).Elab_Body := False;
- UNR.Table (After).Num_Pred := UNR.Table (After).Num_Pred + 1;
+ Succ.Table (Succ.Last).After := After;
+ Succ.Table (Succ.Last).Elab_Body := False;
+ UNR.Table (After).Num_Pred := UNR.Table (After).Num_Pred + 1;
end Build_Link;
------------
-- Choose --
------------
- procedure Choose (Chosen : Unit_Id) is
+ procedure Choose (Elab_Order : in out Unit_Id_Table; Chosen : Unit_Id) is
+ pragma Assert (Chosen /= No_Unit_Id);
S : Successor_Id;
U : Unit_Id;
@@ -569,17 +996,27 @@ package body Binde is
Write_Eol;
end if;
- -- Add to elaboration order. Note that units having no elaboration
- -- code are not treated specially yet. The special casing of this
- -- is in Bindgen, where Gen_Elab_Calls skips over them. Meanwhile
- -- we need them here, because the object file list is also driven
- -- by the contents of the Elab_Order table.
+ -- We shouldn't be choosing something with unelaborated predecessors,
+ -- and we shouldn't call this twice on the same unit. But that's not
+ -- true when this is called from Diagnose_Elaboration_Problem.
- Elab_Order.Increment_Last;
- Elab_Order.Table (Elab_Order.Last) := Chosen;
+ if Errors_Detected = 0 then
+ pragma Assert (UNR.Table (Chosen).Num_Pred = 0);
+ pragma Assert (UNR.Table (Chosen).Elab_Position = 0);
+ pragma Assert (not Doing_New or else SCC_Num_Pred (Chosen) = 0);
+ null;
+ end if;
- -- Remove from No_Pred list. This is a little inefficient and may
- -- be we should doubly link the list, but it will do for now.
+ -- Add to elaboration order. Note that units having no elaboration code
+ -- are not treated specially yet. The special casing of this is in
+ -- Bindgen, where Gen_Elab_Calls skips over them. Meanwhile we need them
+ -- here, because the object file list is also driven by the contents of
+ -- the Elab_Order table.
+
+ Append (Elab_Order, Chosen);
+
+ -- Remove from No_Pred list. This is a little inefficient and may be we
+ -- should doubly link the list, but it will do for now.
if No_Pred = Chosen then
No_Pred := UNR.Table (Chosen).Nextnp;
@@ -601,8 +1038,8 @@ package body Binde is
end loop;
end if;
- -- For all successors, decrement the number of predecessors, and
- -- if it becomes zero, then add to no predecessor list.
+ -- For all successors, decrement the number of predecessors, and if it
+ -- becomes zero, then add to no-predecessor list.
S := UNR.Table (Chosen).Successors;
while S /= No_Successor loop
@@ -622,31 +1059,47 @@ package body Binde is
No_Pred := U;
end if;
+ if Doing_New and then SCC (U) /= SCC (Chosen) then
+ UNR.Table (SCC (U)).SCC_Num_Pred :=
+ UNR.Table (SCC (U)).SCC_Num_Pred - 1;
+
+ if Debug_Flag_N then
+ Write_Str (" decrementing SCC_Num_Pred for unit ");
+ Write_Unit_Name (Units.Table (U).Uname);
+ Write_Str (" new value = ");
+ Write_Int (SCC_Num_Pred (U));
+ Write_Eol;
+ end if;
+ end if;
+
S := Succ.Table (S).Next;
end loop;
-- All done, adjust number of units left count and set elaboration pos
- Num_Left := Num_Left - 1;
+ Num_Left := Num_Left - 1;
Num_Chosen := Num_Chosen + 1;
+
+ pragma Assert
+ (Errors_Detected > 0 or else Num_Chosen = Natural (Last (Elab_Order)));
+
UNR.Table (Chosen).Elab_Position := Num_Chosen;
- Units.Table (Chosen).Elab_Position := Num_Chosen;
- -- If we just chose a spec with Elaborate_Body set, then we
- -- must immediately elaborate the body, before any other units.
+ -- If we just chose a spec with Elaborate_Body set, then we must
+ -- immediately elaborate the body, before any other units.
if Units.Table (Chosen).Elaborate_Body then
-- If the unit is a spec only, then there is no body. This is a bit
- -- odd given that Elaborate_Body is here, but it is valid in an
- -- RCI unit, where we only have the interface in the stub bind.
+ -- odd given that Elaborate_Body is here, but it is valid in an RCI
+ -- unit, where we only have the interface in the stub bind.
if Units.Table (Chosen).Utype = Is_Spec_Only
and then Units.Table (Chosen).RCI
then
null;
else
- Choose (Corresponding_Body (Chosen));
+ Choose (Elab_Order, Corresponding_Body (Chosen));
end if;
end if;
end Choose;
@@ -655,9 +1108,9 @@ package body Binde is
-- Corresponding_Body --
------------------------
- -- Currently if the body and spec are separate, then they appear as
- -- two separate units in the same ALI file, with the body appearing
- -- first and the spec appearing second.
+ -- Currently if the body and spec are separate, then they appear as two
+ -- separate units in the same ALI file, with the body appearing first and
+ -- the spec appearing second.
function Corresponding_Body (U : Unit_Id) return Unit_Id is
begin
@@ -669,9 +1122,9 @@ package body Binde is
-- Corresponding_Spec --
------------------------
- -- Currently if the body and spec are separate, then they appear as
- -- two separate units in the same ALI file, with the body appearing
- -- first and the spec appearing second.
+ -- Currently if the body and spec are separate, then they appear as two
+ -- separate units in the same ALI file, with the body appearing first and
+ -- the spec appearing second.
function Corresponding_Spec (U : Unit_Id) return Unit_Id is
begin
@@ -679,13 +1132,35 @@ package body Binde is
return U + 1;
end Corresponding_Spec;
+ --------------------
+ -- Debug_Flag_Old --
+ --------------------
+
+ function Debug_Flag_Old return Boolean is
+ begin
+ return Debug_Flag_P;
+ end Debug_Flag_Old;
+
+ ----------------------
+ -- Debug_Flag_Older --
+ ----------------------
+
+ function Debug_Flag_Older return Boolean is
+ begin
+ return Debug_Flag_O;
+ end Debug_Flag_Older;
+
----------------------------------
-- Diagnose_Elaboration_Problem --
----------------------------------
- procedure Diagnose_Elaboration_Problem is
-
- function Find_Path (Ufrom, Uto : Unit_Id; ML : Nat) return Boolean;
+ procedure Diagnose_Elaboration_Problem
+ (Elab_Order : in out Unit_Id_Table)
+ is
+ function Find_Path
+ (Ufrom : Unit_Id;
+ Uto : Unit_Id;
+ ML : Nat) return Boolean;
-- Recursive routine used to find a path from node Ufrom to node Uto.
-- If a path exists, returns True and outputs an appropriate set of
-- error messages giving the path. Also calls Choose for each of the
@@ -699,8 +1174,11 @@ package body Binde is
-- Find_Path --
---------------
- function Find_Path (Ufrom, Uto : Unit_Id; ML : Nat) return Boolean is
-
+ function Find_Path
+ (Ufrom : Unit_Id;
+ Uto : Unit_Id;
+ ML : Nat) return Boolean
+ is
function Find_Link (U : Unit_Id; PL : Nat) return Boolean;
-- This is the inner recursive routine, it determines if a path
-- exists from U to Uto, and if so returns True and outputs the
@@ -714,14 +1192,14 @@ package body Binde is
S : Successor_Id;
begin
- -- Recursion ends if we are at terminating node and the path
- -- is sufficiently long, generate error message and return True.
+ -- Recursion ends if we are at terminating node and the path is
+ -- sufficiently long, generate error message and return True.
if U = Uto and then PL >= ML then
- Choose (U);
+ Choose (Elab_Order, U);
return True;
- -- All done if already visited, otherwise mark as visited
+ -- All done if already visited
elsif UNR.Table (U).Visited then
return False;
@@ -735,7 +1213,7 @@ package body Binde is
while S /= No_Successor loop
if Find_Link (Succ.Table (S).After, PL + 1) then
Elab_Error_Msg (S);
- Choose (U);
+ Choose (Elab_Order, U);
return True;
end if;
@@ -751,7 +1229,7 @@ package body Binde is
-- Start of processing for Find_Path
begin
- -- Initialize all non-chosen nodes to not visisted yet
+ -- Initialize all non-chosen nodes to not visited yet
for U in Units.First .. Units.Last loop
UNR.Table (U).Visited := UNR.Table (U).Elab_Position /= 0;
@@ -762,7 +1240,7 @@ package body Binde is
return Find_Link (Ufrom, 0);
end Find_Path;
- -- Start of processing for Diagnose_Elaboration_Error
+ -- Start of processing for Diagnose_Elaboration_Problem
begin
Set_Standard_Error;
@@ -834,9 +1312,9 @@ package body Binde is
end;
end if;
- -- Output the header for the error, and manually increment the
- -- error count. We are using Error_Msg_Output rather than Error_Msg
- -- here for two reasons:
+ -- Output the header for the error, and manually increment the error
+ -- count. We are using Error_Msg_Output rather than Error_Msg here for
+ -- two reasons:
-- This is really only one error, not one for each line
-- We want this output on standard output since it is voluminous
@@ -858,8 +1336,8 @@ package body Binde is
end if;
end loop;
- -- We should never get here, since we were called for some reason,
- -- and we should have found and eliminated at least one bad path.
+ -- We should never get here, since we were called for some reason, and
+ -- we should have found and eliminated at least one bad path.
raise Program_Error;
end Diagnose_Elaboration_Problem;
@@ -886,14 +1364,14 @@ package body Binde is
-- Process all units with'ed by Before recursively
- for W in
- Units.Table (Before).First_With .. Units.Table (Before).Last_With
+ for W in Units.Table (Before).First_With ..
+ Units.Table (Before).Last_With
loop
- -- Skip if this with is an interface to a stand-alone library.
- -- Skip also if no ALI file for this WITH, happens for language
- -- defined generics while bootstrapping the compiler (see body of
- -- Lib.Writ.Write_With_Lines). Finally, skip if it is a limited
- -- with clause, which does not impose an elaboration link.
+ -- Skip if this with is an interface to a stand-alone library. Skip
+ -- also if no ALI file for this WITH, happens for language defined
+ -- generics while bootstrapping the compiler (see body of routine
+ -- Lib.Writ.Write_With_Lines). Finally, skip if it is a limited with
+ -- clause, which does not impose an elaboration link.
if not Withs.Table (W).SAL_Interface
and then Withs.Table (W).Afile /= No_File
@@ -910,11 +1388,12 @@ package body Binde is
if Info = 0 or else Unit_Id (Info) = No_Unit_Id then
declare
- Withed : String :=
- Get_Name_String (Withs.Table (W).Uname);
+ Withed : String :=
+ Get_Name_String (Withs.Table (W).Uname);
Last_Withed : Natural := Withed'Last;
- Withing : String :=
- Get_Name_String (Units.Table (Before).Uname);
+ Withing : String :=
+ Get_Name_String
+ (Units.Table (Before).Uname);
Last_Withing : Natural := Withing'Last;
Spec_Body : String := " (Spec)";
@@ -922,20 +1401,20 @@ package body Binde is
To_Mixed (Withed);
To_Mixed (Withing);
- if Last_Withed > 2 and then
- Withed (Last_Withed - 1) = '%'
+ if Last_Withed > 2
+ and then Withed (Last_Withed - 1) = '%'
then
Last_Withed := Last_Withed - 2;
end if;
- if Last_Withing > 2 and then
- Withing (Last_Withing - 1) = '%'
+ if Last_Withing > 2
+ and then Withing (Last_Withing - 1) = '%'
then
Last_Withing := Last_Withing - 2;
end if;
- if Units.Table (Before).Utype = Is_Body or else
- Units.Table (Before).Utype = Is_Body_Only
+ if Units.Table (Before).Utype = Is_Body
+ or else Units.Table (Before).Utype = Is_Body_Only
then
Spec_Body := " (Body)";
end if;
@@ -951,7 +1430,7 @@ package body Binde is
(Unit_Id_Of (Withs.Table (W).Uname),
After,
Reason,
- Make_Elab_Entry (Withs.Table (W).Uname, Link));
+ Make_Elab_All_Entry (Withs.Table (W).Uname, Link));
end;
end if;
end loop;
@@ -962,7 +1441,7 @@ package body Binde is
Elab_All_Links
(Corresponding_Body (Before),
After, Reason,
- Make_Elab_Entry
+ Make_Elab_All_Entry
(Units.Table (Corresponding_Body (Before)).Uname, Link));
end if;
end Elab_All_Links;
@@ -1006,6 +1485,11 @@ package body Binde is
(" reason: with clause",
Info => True);
+ when Forced =>
+ Error_Msg_Output
+ (" reason: forced by -f switch",
+ Info => True);
+
when Elab =>
Error_Msg_Output
(" reason: pragma Elaborate in unit $",
@@ -1046,13 +1530,11 @@ package body Binde is
Error_Msg_Unit_1 := Units.Table (SL.Before).Uname;
Error_Msg_Unit_2 := Units.Table (SL.After).Uname;
Error_Msg_Output
- (" $ must therefore be elaborated before $",
- True);
+ (" $ must therefore be elaborated before $", True);
Error_Msg_Unit_1 := Units.Table (SL.After).Uname;
Error_Msg_Output
- (" (because $ has a pragma Elaborate_Body)",
- True);
+ (" (because $ has a pragma Elaborate_Body)", True);
end if;
if not Zero_Formatting then
@@ -1064,127 +1546,413 @@ package body Binde is
-- Find_Elab_Order --
---------------------
- procedure Find_Elab_Order is
- U : Unit_Id;
- Best_So_Far : Unit_Id;
+ procedure Find_Elab_Order
+ (Elab_Order : out Unit_Id_Table;
+ First_Main_Lib_File : File_Name_Type)
+ is
+ function Num_Spec_Body_Pairs (Order : Unit_Id_Array) return Nat;
+ -- Number of cases where the body of a unit immediately follows the
+ -- corresponding spec. Such cases are good, because calls to that unit
+ -- from outside can't get ABE.
- begin
- Succ.Init;
- Num_Left := Int (Units.Last - Units.First + 1);
+ -------------------------
+ -- Num_Spec_Body_Pairs --
+ -------------------------
- -- Initialize unit table for elaboration control
+ function Num_Spec_Body_Pairs (Order : Unit_Id_Array) return Nat is
+ Result : Nat := 0;
- for U in Units.First .. Units.Last loop
- UNR.Increment_Last;
- UNR.Table (UNR.Last).Successors := No_Successor;
- UNR.Table (UNR.Last).Num_Pred := 0;
- UNR.Table (UNR.Last).Nextnp := No_Unit_Id;
- UNR.Table (UNR.Last).Elab_Order := 0;
- UNR.Table (UNR.Last).Elab_Position := 0;
- end loop;
+ begin
+ for J in Order'First + 1 .. Order'Last loop
+ if Units.Table (Order (J - 1)).Utype = Is_Spec
+ and then Units.Table (Order (J)).Utype = Is_Body
+ and then Corresponding_Spec (Order (J)) = Order (J - 1)
+ then
+ Result := Result + 1;
+ end if;
+ end loop;
+
+ return Result;
+ end Num_Spec_Body_Pairs;
+
+ -- Local variables
+ Old_Elab_Order : Unit_Id_Table;
+
+ -- Start of processing for Find_Elab_Order
+
+ begin
-- Output warning if -p used with no -gnatE units
- if Pessimistic_Elab_Order and not Dynamic_Elaboration_Checks_Specified
+ if Pessimistic_Elab_Order
+ and not Dynamic_Elaboration_Checks_Specified
then
Error_Msg ("?use of -p switch questionable");
Error_Msg ("?since all units compiled with static elaboration model");
end if;
- -- Gather dependencies and output them if option set
+ if Do_New then
+ if Debug_Flag_V then
+ Write_Line ("Doing new...");
+ end if;
- Gather_Dependencies;
+ Doing_New := True;
+ Init;
+ Elab_New.Find_Elab_Order (Elab_Order);
+ end if;
- -- Output elaboration dependencies if option is set
+ -- Elab_New does not support the pessimistic order, so if that was
+ -- requested, use the old results. Use Elab_Old if -dp was selected.
+ -- Elab_New does not yet give proper error messages for illegal
+ -- Elaborate_Alls, so if there is one, run Elab_Old.
- if Elab_Dependency_Output or Debug_Flag_E then
- Write_Dependencies;
+ if Do_Old
+ or Pessimistic_Elab_Order
+ or Debug_Flag_Old
+ or Illegal_Elab_All
+ then
+ if Debug_Flag_V then
+ Write_Line ("Doing old...");
+ end if;
+
+ Doing_New := False;
+ Init;
+ Elab_Old.Find_Elab_Order (Old_Elab_Order);
end if;
- -- Initialize the no predecessor list
+ declare
+ Old_Order : Unit_Id_Array renames
+ Old_Elab_Order.Table (1 .. Last (Old_Elab_Order));
+ New_Order : Unit_Id_Array renames
+ Elab_Order.Table (1 .. Last (Elab_Order));
+ Old_Pairs : constant Nat := Num_Spec_Body_Pairs (Old_Order);
+ New_Pairs : constant Nat := Num_Spec_Body_Pairs (New_Order);
- No_Pred := No_Unit_Id;
- for U in UNR.First .. UNR.Last loop
- if UNR.Table (U).Num_Pred = 0 then
- UNR.Table (U).Nextnp := No_Pred;
- No_Pred := U;
- end if;
- end loop;
+ begin
+ if Do_Old and Do_New then
+ Write_Line (Get_Name_String (First_Main_Lib_File));
- -- OK, now we determine the elaboration order proper. All we do is to
- -- select the best choice from the no predecessor list until all the
- -- nodes have been chosen.
+ pragma Assert (Old_Order'Length = New_Order'Length);
+ pragma Debug (Validate (Old_Order, Doing_New => False));
+ pragma Debug (Validate (New_Order, Doing_New => True));
- Outer : loop
+ -- Misc debug printouts that can be used for experimentation by
+ -- changing the 'if's below.
- -- If there are no nodes with predecessors, then either we are
- -- done, as indicated by Num_Left being set to zero, or we have
- -- a circularity. In the latter case, diagnose the circularity,
- -- removing it from the graph and continue
+ if True then
+ if New_Order = Old_Order then
+ Write_Line ("Elab_New: same order.");
+ else
+ Write_Line ("Elab_New: diff order.");
+ end if;
+ end if;
- Get_No_Pred : while No_Pred = No_Unit_Id loop
- exit Outer when Num_Left < 1;
- Diagnose_Elaboration_Problem;
- end loop Get_No_Pred;
+ if New_Order /= Old_Order and then False then
+ Write_Line ("Elaboration orders differ:");
+ Write_Elab_Order
+ (Old_Order, Title => "OLD ELABORATION ORDER");
+ Write_Elab_Order
+ (New_Order, Title => "NEW ELABORATION ORDER");
+ end if;
- U := No_Pred;
- Best_So_Far := No_Unit_Id;
+ if True then
+ Write_Str ("Pairs: ");
+ Write_Int (Old_Pairs);
- -- Loop to choose best entry in No_Pred list
+ if Old_Pairs = New_Pairs then
+ Write_Str (" = ");
+ elsif Old_Pairs < New_Pairs then
+ Write_Str (" < ");
+ else
+ Write_Str (" > ");
+ end if;
- No_Pred_Search : loop
- if Debug_Flag_N then
- Write_Str (" considering choice of ");
- Write_Unit_Name (Units.Table (U).Uname);
+ Write_Int (New_Pairs);
Write_Eol;
+ end if;
+
+ if Old_Pairs /= New_Pairs and then False then
+ Write_Str ("Pairs: ");
+ Write_Int (Old_Pairs);
- if Units.Table (U).Elaborate_Body then
- Write_Str
- (" Elaborate_Body = True, Num_Pred for body = ");
- Write_Int
- (UNR.Table (Corresponding_Body (U)).Num_Pred);
+ if Old_Pairs < New_Pairs then
+ Write_Str (" < ");
else
- Write_Str
- (" Elaborate_Body = False");
+ Write_Str (" > ");
end if;
+ Write_Int (New_Pairs);
Write_Eol;
+
+ if Old_Pairs /= New_Pairs and then Debug_Flag_V then
+ Write_Elab_Order
+ (Old_Order, Title => "OLD ELABORATION ORDER");
+ Write_Elab_Order
+ (New_Order, Title => "NEW ELABORATION ORDER");
+ pragma Assert (New_Pairs >= Old_Pairs);
+ end if;
end if;
+ end if;
- -- This is a candididate to be considered for choice
+ -- The Elab_New algorithm doesn't implement the -p switch, so if that
+ -- was used, use the results from the old algorithm.
- if Best_So_Far = No_Unit_Id
- or else ((not Pessimistic_Elab_Order)
- and then Better_Choice (U, Best_So_Far))
- or else (Pessimistic_Elab_Order
- and then Pessimistic_Better_Choice (U, Best_So_Far))
- then
- if Debug_Flag_N then
- Write_Str (" tentatively chosen (best so far)");
- Write_Eol;
+ if Pessimistic_Elab_Order or Debug_Flag_Old then
+ New_Order := Old_Order;
+ end if;
+
+ -- Now set the Elab_Positions in the Units table. It is important to
+ -- do this late, in case we're running both Elab_New and Elab_Old.
+
+ declare
+ Units_Array : Units.Table_Type renames
+ Units.Table (Units.First .. Units.Last);
+
+ begin
+ for J in New_Order'Range loop
+ pragma Assert
+ (UNR.Table (New_Order (J)).Elab_Position = Positive (J));
+ Units_Array (New_Order (J)).Elab_Position := Positive (J);
+ end loop;
+ end;
+
+ if Errors_Detected = 0 then
+
+ -- Display elaboration order if -l was specified
+
+ if Elab_Order_Output then
+ if Zero_Formatting then
+ Write_Elab_Order (New_Order, Title => "");
+ else
+ Write_Elab_Order (New_Order, Title => "ELABORATION ORDER");
end if;
+ end if;
+
+ -- Display list of sources in the closure (except predefined
+ -- sources) if -R was used. Include predefined sources if -Ra
+ -- was used.
- Best_So_Far := U;
+ if List_Closure then
+ Write_Closure (New_Order);
end if;
+ end if;
+ end;
+ end Find_Elab_Order;
- U := UNR.Table (U).Nextnp;
- exit No_Pred_Search when U = No_Unit_Id;
- end loop No_Pred_Search;
+ ----------------------
+ -- Force_Elab_Order --
+ ----------------------
- -- If no candididate chosen, it means that no unit has No_Pred = 0,
- -- but there are units left, hence we have a circular dependency,
- -- which we will get Diagnose_Elaboration_Problem to diagnose it.
+ procedure Force_Elab_Order is
+ use System.OS_Lib;
+ -- There is a lot of fiddly string manipulation below, because we don't
+ -- want to depend on misc utility packages like Ada.Characters.Handling.
- if Best_So_Far = No_Unit_Id then
- Diagnose_Elaboration_Problem;
+ function Get_Line return String;
+ -- Read the next line from the file content read by Read_File. Strip
+ -- all leading and trailing blanks. Convert "(spec)" or "(body)" to
+ -- "%s"/"%b". Remove comments (Ada style; "--" to end of line).
- -- Otherwise choose the best candidate found
+ function Read_File (Name : String) return String_Ptr;
+ -- Read the entire contents of the named file
- else
- Choose (Best_So_Far);
+ ---------------
+ -- Read_File --
+ ---------------
+
+ function Read_File (Name : String) return String_Ptr is
+
+ -- All of the following calls should succeed, because we checked the
+ -- file in Switch.B, but we double check and raise Program_Error on
+ -- failure, just in case.
+
+ F : constant File_Descriptor := Open_Read (Name, Binary);
+
+ begin
+ if F = Invalid_FD then
+ raise Program_Error;
end if;
- end loop Outer;
- end Find_Elab_Order;
+
+ declare
+ Len : constant Natural := Natural (File_Length (F));
+ Result : constant String_Ptr := new String (1 .. Len);
+ Len_Read : constant Natural :=
+ Read (F, Result (1)'Address, Len);
+
+ Status : Boolean;
+
+ begin
+ if Len_Read /= Len then
+ raise Program_Error;
+ end if;
+
+ Close (F, Status);
+
+ if not Status then
+ raise Program_Error;
+ end if;
+
+ return Result;
+ end;
+ end Read_File;
+
+ Cur : Positive := 1;
+ S : String_Ptr := Read_File (Force_Elab_Order_File.all);
+
+ --------------
+ -- Get_Line --
+ --------------
+
+ function Get_Line return String is
+ First : Positive := Cur;
+ Last : Natural;
+
+ begin
+ -- Skip to end of line
+
+ while Cur <= S'Last
+ and then S (Cur) /= ASCII.LF
+ and then S (Cur) /= ASCII.CR
+ loop
+ Cur := Cur + 1;
+ end loop;
+
+ -- Strip leading blanks
+
+ while First <= S'Last and then S (First) = ' ' loop
+ First := First + 1;
+ end loop;
+
+ -- Strip trailing blanks and comment
+
+ Last := Cur - 1;
+
+ for J in First .. Last - 1 loop
+ if S (J .. J + 1) = "--" then
+ Last := J - 1;
+ exit;
+ end if;
+ end loop;
+
+ while Last >= First and then S (Last) = ' ' loop
+ Last := Last - 1;
+ end loop;
+
+ -- Convert "(spec)" or "(body)" to "%s"/"%b", strip trailing blanks
+ -- again.
+
+ declare
+ Body_String : constant String := "(body)";
+ BL : constant Positive := Body_String'Length;
+ Spec_String : constant String := "(spec)";
+ SL : constant Positive := Spec_String'Length;
+
+ Line : String renames S (First .. Last);
+
+ Is_Body : Boolean := False;
+ Is_Spec : Boolean := False;
+
+ begin
+ if Line'Length >= SL
+ and then Line (Last - SL + 1 .. Last) = Spec_String
+ then
+ Is_Spec := True;
+ Last := Last - SL;
+ elsif Line'Length >= BL
+ and then Line (Last - BL + 1 .. Last) = Body_String
+ then
+ Is_Body := True;
+ Last := Last - BL;
+ end if;
+
+ while Last >= First and then S (Last) = ' ' loop
+ Last := Last - 1;
+ end loop;
+
+ -- Skip past LF or CR/LF
+
+ if Cur <= S'Last and then S (Cur) = ASCII.CR then
+ Cur := Cur + 1;
+ end if;
+
+ if Cur <= S'Last and then S (Cur) = ASCII.LF then
+ Cur := Cur + 1;
+ end if;
+
+ if Is_Spec then
+ return Line (First .. Last) & "%s";
+ elsif Is_Body then
+ return Line (First .. Last) & "%b";
+ else
+ return Line;
+ end if;
+ end;
+ end Get_Line;
+
+ -- Local variables
+
+ Empty_Name : constant Unit_Name_Type := Name_Find ("");
+ Prev_Unit : Unit_Id := No_Unit_Id;
+
+ -- Start of processing for Force_Elab_Order
+
+ begin
+ -- Loop through the file content, and build a dependency link for each
+ -- pair of lines. Ignore lines that should be ignored.
+
+ while Cur <= S'Last loop
+ declare
+ Uname : constant Unit_Name_Type := Name_Find (Get_Line);
+
+ begin
+ if Uname = Empty_Name then
+ null; -- silently skip blank lines
+
+ elsif Get_Name_Table_Int (Uname) = 0
+ or else Unit_Id (Get_Name_Table_Int (Uname)) = No_Unit_Id
+ then
+ if Doing_New then
+ Write_Line
+ ("""" & Get_Name_String (Uname)
+ & """: not present; ignored");
+ end if;
+
+ else
+ declare
+ Cur_Unit : constant Unit_Id := Unit_Id_Of (Uname);
+
+ begin
+ if Is_Internal_File_Name (Units.Table (Cur_Unit).Sfile) then
+ if Doing_New then
+ Write_Line
+ ("""" & Get_Name_String (Uname) &
+ """: predefined unit ignored");
+ end if;
+
+ else
+ if Prev_Unit /= No_Unit_Id then
+ if Doing_New then
+ Write_Unit_Name (Units.Table (Prev_Unit).Uname);
+ Write_Str (" <-- ");
+ Write_Unit_Name (Units.Table (Cur_Unit).Uname);
+ Write_Eol;
+ end if;
+
+ Build_Link
+ (Before => Prev_Unit,
+ After => Cur_Unit,
+ R => Forced);
+ end if;
+
+ Prev_Unit := Cur_Unit;
+ end if;
+ end;
+ end if;
+ end;
+ end loop;
+
+ Free (S);
+ end Force_Elab_Order;
-------------------------
-- Gather_Dependencies --
@@ -1199,9 +1967,9 @@ package body Binde is
for U in Units.First .. Units.Last loop
Cur_Unit := U;
- -- If this is not an interface to a stand-alone library and
- -- there is a body and a spec, then spec must be elaborated first
- -- Note that the corresponding spec immediately follows the body
+ -- If this is not an interface to a stand-alone library and there is
+ -- a body and a spec, then spec must be elaborated first. Note that
+ -- the corresponding spec immediately follows the body.
if not Units.Table (U).SAL_Interface
and then Units.Table (U).Utype = Is_Body
@@ -1209,12 +1977,13 @@ package body Binde is
Build_Link (Corresponding_Spec (U), U, Spec_First);
end if;
- -- If this unit is not an interface to a stand-alone library,
- -- process WITH references for this unit ignoring generic units and
- -- interfaces to stand-alone libraries.
+ -- If this unit is not an interface to a stand-alone library, process
+ -- WITH references for this unit ignoring interfaces to stand-alone
+ -- libraries.
if not Units.Table (U).SAL_Interface then
- for W in Units.Table (U).First_With .. Units.Table (U).Last_With
+ for W in Units.Table (U).First_With ..
+ Units.Table (U).Last_With
loop
if Withs.Table (W).Sfile /= No_File
and then (not Withs.Table (W).SAL_Interface)
@@ -1226,9 +1995,12 @@ package body Binde is
-- obsolete unit with's a previous (now disappeared) spec.
if Get_Name_Table_Int (Withs.Table (W).Uname) = 0 then
- Error_Msg_File_1 := Units.Table (U).Sfile;
- Error_Msg_Unit_1 := Withs.Table (W).Uname;
- Error_Msg ("{ depends on $ which no longer exists");
+ if Doing_New then
+ Error_Msg_File_1 := Units.Table (U).Sfile;
+ Error_Msg_Unit_1 := Withs.Table (W).Uname;
+ Error_Msg ("{ depends on $ which no longer exists");
+ end if;
+
goto Next_With;
end if;
@@ -1237,7 +2009,10 @@ package body Binde is
-- Pragma Elaborate_All case, for this we use the recursive
-- Elab_All_Links procedure to establish the links.
- if Withs.Table (W).Elaborate_All then
+ -- Elab_New ignores Elaborate_All and Elab_All_Desirable,
+ -- except for error messages.
+
+ if Withs.Table (W).Elaborate_All and then not Doing_New then
-- Reset flags used to stop multiple visits to a given
-- node.
@@ -1250,14 +2025,15 @@ package body Binde is
Elab_All_Links
(Withed_Unit, U, Elab_All,
- Make_Elab_Entry
+ Make_Elab_All_Entry
(Withs.Table (W).Uname, No_Elab_All_Link));
-- Elaborate_All_Desirable case, for this we establish the
-- same links as above, but with a different reason.
- elsif Withs.Table (W).Elab_All_Desirable then
-
+ elsif Withs.Table (W).Elab_All_Desirable
+ and then not Doing_New
+ then
-- Reset flags used to stop multiple visits to a given
-- node.
@@ -1269,7 +2045,7 @@ package body Binde is
Elab_All_Links
(Withed_Unit, U, Elab_All_Desirable,
- Make_Elab_Entry
+ Make_Elab_All_Entry
(Withs.Table (W).Uname, No_Elab_All_Link));
-- Pragma Elaborate case. We must build a link for the
@@ -1292,8 +2068,8 @@ package body Binde is
(Corresponding_Body (Withed_Unit), U, Elab);
end if;
- -- Elaborate_Desirable case, for this we establish
- -- the same links as above, but with a different reason.
+ -- Elaborate_Desirable case, for this we establish the same
+ -- links as above, but with a different reason.
elsif Withs.Table (W).Elab_Desirable then
Build_Link (Withed_Unit, U, Withed);
@@ -1305,7 +2081,7 @@ package body Binde is
end if;
-- A limited_with does not establish an elaboration
- -- dependence (that's the whole point)..
+ -- dependence (that's the whole point).
elsif Withs.Table (W).Limited_With then
null;
@@ -1323,16 +2099,60 @@ package body Binde is
end loop;
end if;
end loop;
+
+ -- If -f<elab_order> switch was given, take into account dependences
+ -- specified in the file <elab_order>.
+
+ if Force_Elab_Order_File /= null then
+ Force_Elab_Order;
+ end if;
+
+ -- Output elaboration dependencies if option is set
+
+ if Elab_Dependency_Output or Debug_Flag_E then
+ if Doing_New then
+ Write_Dependencies;
+ end if;
+ end if;
end Gather_Dependencies;
+ ----------
+ -- Init --
+ ----------
+
+ procedure Init is
+ begin
+ Num_Chosen := 0;
+ Num_Left := Int (Units.Last - Units.First + 1);
+ Succ.Init;
+ Elab_All_Entries.Init;
+ UNR.Init;
+
+ -- Initialize unit table for elaboration control
+
+ for U in Units.First .. Units.Last loop
+ UNR.Append
+ ((Successors => No_Successor,
+ Num_Pred => 0,
+ Nextnp => No_Unit_Id,
+ Visited => False,
+ Elab_Position => 0,
+ SCC_Root => No_Unit_Id,
+ Nodes => null,
+ SCC_Num_Pred => 0,
+ Validate_Seen => False));
+ end loop;
+ end Init;
+
------------------
-- Is_Body_Unit --
------------------
function Is_Body_Unit (U : Unit_Id) return Boolean is
begin
- return Units.Table (U).Utype = Is_Body
- or else Units.Table (U).Utype = Is_Body_Only;
+ return
+ Units.Table (U).Utype = Is_Body
+ or else Units.Table (U).Utype = Is_Body_Only;
end Is_Body_Unit;
-----------------------------
@@ -1344,16 +2164,14 @@ package body Binde is
-- If we have a body with separate spec, test flags on the spec
if Units.Table (U).Utype = Is_Body then
- return Units.Table (U + 1).Preelab
- or else
- Units.Table (U + 1).Pure;
+ return
+ Units.Table (Corresponding_Spec (U)).Preelab
+ or else Units.Table (Corresponding_Spec (U)).Pure;
-- Otherwise we have a spec or body acting as spec, test flags on unit
else
- return Units.Table (U).Preelab
- or else
- Units.Table (U).Pure;
+ return Units.Table (U).Preelab or else Units.Table (U).Pure;
end if;
end Is_Pure_Or_Preelab_Unit;
@@ -1363,250 +2181,224 @@ package body Binde is
function Is_Waiting_Body (U : Unit_Id) return Boolean is
begin
- return Units.Table (U).Utype = Is_Body
- and then UNR.Table (Corresponding_Spec (U)).Elab_Position /= 0;
+ return
+ Units.Table (U).Utype = Is_Body
+ and then UNR.Table (Corresponding_Spec (U)).Elab_Position /= 0;
end Is_Waiting_Body;
- ---------------------
- -- Make_Elab_Entry --
- ---------------------
+ -------------------------
+ -- Make_Elab_All_Entry --
+ -------------------------
- function Make_Elab_Entry
+ function Make_Elab_All_Entry
(Unam : Unit_Name_Type;
Link : Elab_All_Id) return Elab_All_Id
is
begin
- Elab_All_Entries.Increment_Last;
- Elab_All_Entries.Table (Elab_All_Entries.Last).Needed_By := Unam;
- Elab_All_Entries.Table (Elab_All_Entries.Last).Next_Elab := Link;
+ Elab_All_Entries.Append ((Needed_By => Unam, Next_Elab => Link));
return Elab_All_Entries.Last;
- end Make_Elab_Entry;
+ end Make_Elab_All_Entry;
- -------------------------------
- -- Pessimistic_Better_Choice --
- -------------------------------
+ ----------------
+ -- Unit_Id_Of --
+ ----------------
- function Pessimistic_Better_Choice (U1, U2 : Unit_Id) return Boolean is
- UT1 : Unit_Record renames Units.Table (U1);
- UT2 : Unit_Record renames Units.Table (U2);
+ function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is
+ Info : constant Int := Get_Name_Table_Int (Uname);
begin
- if Debug_Flag_B then
- Write_Str ("Pessimistic_Better_Choice (");
- Write_Unit_Name (UT1.Uname);
- Write_Str (", ");
- Write_Unit_Name (UT2.Uname);
- Write_Line (")");
- end if;
-
- -- Note: the checks here are applied in sequence, and the ordering is
- -- significant (i.e. the more important criteria are applied first).
-
- -- If either unit is predefined or internal, then we use the normal
- -- Better_Choice rule, since we don't want to disturb the elaboration
- -- rules of the language with -p, same treatment for Pure/Preelab.
-
- -- Prefer a predefined unit to a non-predefined unit
-
- if UT1.Predefined and then not UT2.Predefined then
- if Debug_Flag_B then
- Write_Line (" True: u1 is predefined, u2 is not");
- end if;
-
- return True;
-
- elsif UT2.Predefined and then not UT1.Predefined then
- if Debug_Flag_B then
- Write_Line (" False: u2 is predefined, u1 is not");
- end if;
-
- return False;
-
- -- Prefer an internal unit to a non-internal unit
-
- elsif UT1.Internal and then not UT2.Internal then
- if Debug_Flag_B then
- Write_Line (" True: u1 is internal, u2 is not");
- end if;
+ pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id);
+ return Unit_Id (Info);
+ end Unit_Id_Of;
- return True;
+ --------------
+ -- Validate --
+ --------------
- elsif UT2.Internal and then not UT1.Internal then
- if Debug_Flag_B then
- Write_Line (" False: u2 is internal, u1 is not");
- end if;
+ procedure Validate (Order : Unit_Id_Array; Doing_New : Boolean) is
+ Cur_SCC : Unit_Id := No_Unit_Id;
+ OK : Boolean := True;
+ Msg : String := "Old: ";
- return False;
+ begin
+ if Doing_New then
+ Msg := "New: ";
+ end if;
- -- Prefer a pure or preelaborable unit to one that is not
+ -- For each unit, assert that its successors are elaborated after it
- elsif Is_Pure_Or_Preelab_Unit (U1)
- and then not
- Is_Pure_Or_Preelab_Unit (U2)
- then
- if Debug_Flag_B then
- Write_Line (" True: u1 is pure/preelab, u2 is not");
- end if;
+ for J in Order'Range loop
+ declare
+ U : constant Unit_Id := Order (J);
+ S : Successor_Id := UNR.Table (U).Successors;
- return True;
+ begin
+ while S /= No_Successor loop
+ pragma Assert
+ (UNR.Table (Succ.Table (S).After).Elab_Position >
+ UNR.Table (U).Elab_Position,
+ Msg & " elab order failed");
+ S := Succ.Table (S).Next;
+ end loop;
+ end;
+ end loop;
- elsif Is_Pure_Or_Preelab_Unit (U2)
- and then not
- Is_Pure_Or_Preelab_Unit (U1)
- then
- if Debug_Flag_B then
- Write_Line (" False: u2 is pure/preelab, u1 is not");
- end if;
+ -- An SCC of size 2 units necessarily consists of a spec and the
+ -- corresponding body. Assert that the body is elaborated immediately
+ -- after the spec, with nothing in between. (We only have SCCs in the
+ -- new algorithm.)
- return False;
+ if Doing_New then
+ for J in Order'Range loop
+ declare
+ U : constant Unit_Id := Order (J);
- -- Prefer anything else to a waiting body. We want to make bodies wait
- -- as long as possible, till we are forced to choose them.
+ begin
+ if Nodes (U)'Length = 2 then
+ if Units.Table (U).Utype = Is_Spec then
+ if Order (J + 1) /= Corresponding_Body (U) then
+ OK := False;
+ Write_Line (Msg & "Bad spec with SCC of size 2:");
+ Write_SCC (SCC (U));
+ end if;
+ end if;
- elsif Is_Waiting_Body (U1) and then not Is_Waiting_Body (U2) then
- if Debug_Flag_B then
- Write_Line (" False: u1 is waiting body, u2 is not");
- end if;
+ if Units.Table (U).Utype = Is_Body then
+ if Order (J - 1) /= Corresponding_Spec (U) then
+ OK := False;
+ Write_Line (Msg & "Bad body with SCC of size 2:");
+ Write_SCC (SCC (U));
+ end if;
+ end if;
+ end if;
+ end;
+ end loop;
- return False;
+ -- Assert that all units of an SCC are elaborated together, with no
+ -- units from other SCCs in between. The above spec/body case is a
+ -- special case of this general rule.
- elsif Is_Waiting_Body (U2) and then not Is_Waiting_Body (U1) then
- if Debug_Flag_B then
- Write_Line (" True: u2 is waiting body, u1 is not");
- end if;
+ for J in Order'Range loop
+ declare
+ U : constant Unit_Id := Order (J);
- return True;
+ begin
+ if SCC (U) /= Cur_SCC then
+ Cur_SCC := SCC (U);
+ if UNR.Table (Cur_SCC).Validate_Seen then
+ OK := False;
+ Write_Line (Msg & "SCC not elaborated together:");
+ Write_SCC (Cur_SCC);
+ end if;
- -- Prefer a spec to a body (this is mandatory)
+ UNR.Table (Cur_SCC).Validate_Seen := True;
+ end if;
+ end;
+ end loop;
+ end if;
- elsif Is_Body_Unit (U1) and then not Is_Body_Unit (U2) then
- if Debug_Flag_B then
- Write_Line (" False: u1 is body, u2 is not");
- end if;
+ pragma Assert (OK);
+ end Validate;
- return False;
+ -------------------
+ -- Write_Closure --
+ -------------------
- elsif Is_Body_Unit (U2) and then not Is_Body_Unit (U1) then
- if Debug_Flag_B then
- Write_Line (" True: u2 is body, u1 is not");
- end if;
+ procedure Write_Closure (Order : Unit_Id_Array) is
+ package Closure_Sources is new Table.Table
+ (Table_Component_Type => File_Name_Type,
+ Table_Index_Type => Natural,
+ Table_Low_Bound => 1,
+ Table_Initial => 10,
+ Table_Increment => 100,
+ Table_Name => "Gnatbind.Closure_Sources");
+ -- Table to record the sources in the closure, to avoid duplications
+
+ function Put_In_Sources (S : File_Name_Type) return Boolean;
+ -- Check if S is already in table Sources and put in Sources if it is
+ -- not. Return False if the source is already in Sources, and True if
+ -- it is added.
+
+ --------------------
+ -- Put_In_Sources --
+ --------------------
+
+ function Put_In_Sources (S : File_Name_Type) return Boolean is
+ begin
+ for J in 1 .. Closure_Sources.Last loop
+ if Closure_Sources.Table (J) = S then
+ return False;
+ end if;
+ end loop;
+ Closure_Sources.Append (S);
return True;
+ end Put_In_Sources;
- -- If both are waiting bodies, then prefer the one whose spec is
- -- less recently elaborated. Consider the following:
+ -- Local variables
- -- spec of A
- -- spec of B
- -- body of A or B?
+ Source : File_Name_Type;
- -- The normal waiting body preference would have placed the body of
- -- A before the spec of B if it could. Since it could not, there it
- -- must be the case that A depends on B. It is therefore a good idea
- -- to put the body of B last so that if there is an elaboration order
- -- problem, we will find it (that's what pessimistic order is about)
+ -- Start of processing for Write_Closure
- elsif Is_Waiting_Body (U1) and then Is_Waiting_Body (U2) then
- declare
- Result : constant Boolean :=
- UNR.Table (Corresponding_Spec (U1)).Elab_Position <
- UNR.Table (Corresponding_Spec (U2)).Elab_Position;
- begin
- if Debug_Flag_B then
- if Result then
- Write_Line (" True: based on waiting body elab positions");
- else
- Write_Line (" False: based on waiting body elab positions");
- end if;
- end if;
+ begin
+ Closure_Sources.Init;
- return Result;
- end;
+ if not Zero_Formatting then
+ Write_Eol;
+ Write_Str ("REFERENCED SOURCES");
+ Write_Eol;
end if;
- -- Remaining choice rules are disabled by Debug flag -do
+ for J in reverse Order'Range loop
+ Source := Units.Table (Order (J)).Sfile;
- if not Debug_Flag_O then
+ -- Do not include same source more than once
- -- The following deal with the case of specs which have been marked
- -- as Elaborate_Body_Desirable. In the normal case, we generally want
- -- to delay the elaboration of these specs as long as possible, so
- -- that bodies have better chance of being elaborated closer to the
- -- specs. Pessimistic_Better_Choice as usual wants to do the opposite
- -- and elaborate such specs as early as possible.
+ if Put_In_Sources (Source)
- -- If we have two units, one of which is a spec for which this flag
- -- is set, and the other is not, we normally prefer to delay the spec
- -- for which the flag is set, so again Pessimistic_Better_Choice does
- -- the opposite.
+ -- Do not include run-time units unless -Ra switch set
- if not UT1.Elaborate_Body_Desirable
- and then UT2.Elaborate_Body_Desirable
+ and then (List_Closure_All
+ or else not Is_Internal_File_Name (Source))
then
- if Debug_Flag_B then
- Write_Line (" False: u1 is elab body desirable, u2 is not");
+ if not Zero_Formatting then
+ Write_Str (" ");
end if;
- return False;
-
- elsif not UT2.Elaborate_Body_Desirable
- and then UT1.Elaborate_Body_Desirable
- then
- if Debug_Flag_B then
- Write_Line (" True: u1 is elab body desirable, u2 is not");
- end if;
+ Write_Str (Get_Name_String (Source));
+ Write_Eol;
+ end if;
+ end loop;
- return True;
+ -- Subunits do not appear in the elaboration table because they are
+ -- subsumed by their parent units, but we need to list them for other
+ -- tools. For now they are listed after other files, rather than right
+ -- after their parent, since there is no easy link between the
+ -- elaboration table and the ALIs table ??? As subunits may appear
+ -- repeatedly in the list, if the parent unit appears in the context of
+ -- several units in the closure, duplicates are suppressed.
- -- If we have two specs that are both marked as Elaborate_Body
- -- desirable, we normally prefer the one whose body is nearer to
- -- being able to be elaborated, based on the Num_Pred count. This
- -- helps to ensure bodies are as close to specs as possible. As
- -- usual, Pessimistic_Better_Choice does the opposite.
+ for J in Sdep.First .. Sdep.Last loop
+ Source := Sdep.Table (J).Sfile;
- elsif UT1.Elaborate_Body_Desirable
- and then UT2.Elaborate_Body_Desirable
+ if Sdep.Table (J).Subunit_Name /= No_Name
+ and then Put_In_Sources (Source)
+ and then not Is_Internal_File_Name (Source)
then
- declare
- Result : constant Boolean :=
- UNR.Table (Corresponding_Body (U1)).Num_Pred >=
- UNR.Table (Corresponding_Body (U2)).Num_Pred;
- begin
- if Debug_Flag_B then
- if Result then
- Write_Line (" True based on Num_Pred compare");
- else
- Write_Line (" False based on Num_Pred compare");
- end if;
- end if;
+ if not Zero_Formatting then
+ Write_Str (" ");
+ end if;
- return Result;
- end;
+ Write_Str (Get_Name_String (Source));
+ Write_Eol;
end if;
- end if;
-
- -- If we fall through, it means that no preference rule applies, so we
- -- use alphabetical order to at least give a deterministic result. Since
- -- Pessimistic_Better_Choice is in the business of stirring up the
- -- order, we will use reverse alphabetical ordering.
+ end loop;
- if Debug_Flag_B then
- Write_Line (" choose on reverse alpha order");
+ if not Zero_Formatting then
+ Write_Eol;
end if;
-
- return Uname_Less (UT2.Uname, UT1.Uname);
- end Pessimistic_Better_Choice;
-
- ----------------
- -- Unit_Id_Of --
- ----------------
-
- function Unit_Id_Of (Uname : Unit_Name_Type) return Unit_Id is
- Info : constant Int := Get_Name_Table_Int (Uname);
- begin
- pragma Assert (Info /= 0 and then Unit_Id (Info) /= No_Unit_Id);
- return Unit_Id (Info);
- end Unit_Id_Of;
+ end Write_Closure;
------------------------
-- Write_Dependencies --
@@ -1665,8 +2457,8 @@ package body Binde is
else
Error_Msg_Output
- (" which must be elaborated " &
- "along with its spec:",
+ (" which must be elaborated along with its "
+ & "spec:",
Info => True);
end if;
@@ -1693,4 +2485,695 @@ package body Binde is
end if;
end Write_Elab_All_Chain;
+ ----------------------
+ -- Write_Elab_Order --
+ ----------------------
+
+ procedure Write_Elab_Order
+ (Order : Unit_Id_Array; Title : String)
+ is
+ begin
+ if Title /= "" then
+ Write_Eol;
+ Write_Str (Title);
+ Write_Eol;
+ end if;
+
+ for J in Order'Range loop
+ if not Units.Table (Order (J)).SAL_Interface then
+ if not Zero_Formatting then
+ Write_Str (" ");
+ end if;
+
+ Write_Unit_Name (Units.Table (Order (J)).Uname);
+ Write_Eol;
+ end if;
+ end loop;
+
+ if Title /= "" then
+ Write_Eol;
+ end if;
+ end Write_Elab_Order;
+
+ --------------
+ -- Elab_New --
+ --------------
+
+ package body Elab_New is
+
+ generic
+ type Node is (<>);
+ First_Node : Node;
+ Last_Node : Node;
+ type Node_Array is array (Pos range <>) of Node;
+ with function Successors (N : Node) return Node_Array;
+ with procedure Create_SCC (Root : Node; Nodes : Node_Array);
+
+ procedure Compute_Strongly_Connected_Components;
+ -- Compute SCCs for a directed graph. The nodes in the graph are all
+ -- values of type Node in the range First_Node .. Last_Node.
+ -- Successors(N) returns the nodes pointed to by the edges emanating
+ -- from N. Create_SCC is a callback that is called once for each SCC,
+ -- passing in the Root node for that SCC (which is an arbitrary node in
+ -- the SCC used as a representative of that SCC), and the set of Nodes
+ -- in that SCC.
+ --
+ -- This is generic, in case we want to use it elsewhere; then we could
+ -- move this into a separate library unit. Unfortunately, it's not as
+ -- generic as one might like. Ideally, we would have "type Node is
+ -- private;", and pass in iterators to iterate over all nodes, and over
+ -- the successors of a given node. However, that leads to using advanced
+ -- features of Ada that are not allowed in the compiler and binder for
+ -- bootstrapping reasons. It also leads to trampolines, which are not
+ -- allowed in the compiler and binder. Restricting Node to be discrete
+ -- allows us to iterate over all nodes with a 'for' loop, and allows us
+ -- to attach temporary information to nodes by having an array indexed
+ -- by Node.
+
+ procedure Compute_Unit_SCCs;
+ -- Use the above generic procedure to compute the SCCs for the graph of
+ -- units. Store in each Unit_Node_Record the SCC_Root and Nodes
+ -- components. Also initialize the SCC_Num_Pred components.
+
+ procedure Find_Elab_All_Errors;
+ -- Generate an error for illegal Elaborate_All pragmas (explicit or
+ -- implicit). A pragma Elaborate_All (Y) on unit X is legal if and only
+ -- if X and Y are in different SCCs.
+
+ -------------------------------------------
+ -- Compute_Strongly_Connected_Components --
+ -------------------------------------------
+
+ procedure Compute_Strongly_Connected_Components is
+
+ -- This uses Tarjan's algorithm for finding SCCs. Comments here are
+ -- intended to tell what it does, but if you want to know how it
+ -- works, you have to look it up. Please do not modify this code
+ -- without reading up on Tarjan's algorithm.
+
+ subtype Node_Index is Nat;
+ No_Index : constant Node_Index := 0;
+
+ Num_Nodes : constant Nat :=
+ Node'Pos (Last_Node) - Node'Pos (First_Node) + 1;
+ Stack : Node_Array (1 .. Num_Nodes);
+ Top : Node_Index := 0;
+ -- Stack of nodes, pushed when first visited. All nodes of an SCC are
+ -- popped at once when the SCC is found.
+
+ subtype Valid_Node is Node range First_Node .. Last_Node;
+ Node_Indices : array (Valid_Node) of Node_Index :=
+ (others => No_Index);
+ -- Each node has an "index", which is the sequential number in the
+ -- order in which they are visited in the recursive walk. No_Index
+ -- means "not yet visited"; we want to avoid walking any node more
+ -- than once.
+
+ Index : Node_Index := 1;
+ -- Next value to be assigned to a node index
+
+ Low_Links : array (Valid_Node) of Node_Index;
+ -- Low_Links (N) is the smallest index of nodes reachable from N
+
+ On_Stack : array (Valid_Node) of Boolean := (others => False);
+ -- True if the node is currently on the stack
+
+ procedure Walk (N : Valid_Node);
+ -- Recursive depth-first graph walk, with the node index used to
+ -- avoid visiting a node more than once.
+
+ ----------
+ -- Walk --
+ ----------
+
+ procedure Walk (N : Valid_Node) is
+ Stack_Position_Of_N : constant Pos := Top + 1;
+ S : constant Node_Array := Successors (N);
+
+ begin
+ -- Assign the index and low link, increment Index for next call to
+ -- Walk.
+
+ Node_Indices (N) := Index;
+ Low_Links (N) := Index;
+ Index := Index + 1;
+
+ -- Push it on the stack:
+
+ Top := Stack_Position_Of_N;
+ Stack (Top) := N;
+ On_Stack (N) := True;
+
+ -- Walk not-yet-visited subnodes, and update low link for visited
+ -- ones as appropriate.
+
+ for J in S'Range loop
+ if Node_Indices (S (J)) = No_Index then
+ Walk (S (J));
+ Low_Links (N) :=
+ Node_Index'Min (Low_Links (N), Low_Links (S (J)));
+ elsif On_Stack (S (J)) then
+ Low_Links (N) :=
+ Node_Index'Min (Low_Links (N), Node_Indices (S (J)));
+ end if;
+ end loop;
+
+ -- If the index is (still) equal to the low link, we've found an
+ -- SCC. Pop the whole SCC off the stack, and call Create_SCC.
+
+ if Low_Links (N) = Node_Indices (N) then
+ declare
+ SCC : Node_Array renames
+ Stack (Stack_Position_Of_N .. Top);
+ pragma Assert (SCC'Length >= 1);
+ pragma Assert (SCC (SCC'First) = N);
+
+ begin
+ for J in SCC'Range loop
+ On_Stack (SCC (J)) := False;
+ end loop;
+
+ Create_SCC (Root => N, Nodes => SCC);
+ pragma Assert (Top - SCC'Length = Stack_Position_Of_N - 1);
+ Top := Stack_Position_Of_N - 1; -- pop all
+ end;
+ end if;
+ end Walk;
+
+ -- Start of processing for Compute_Strongly_Connected_Components
+
+ begin
+ -- Walk all the nodes that have not yet been walked
+
+ for N in Valid_Node loop
+ if Node_Indices (N) = No_Index then
+ Walk (N);
+ end if;
+ end loop;
+ end Compute_Strongly_Connected_Components;
+
+ -----------------------
+ -- Compute_Unit_SCCs --
+ -----------------------
+
+ procedure Compute_Unit_SCCs is
+ function Successors (U : Unit_Id) return Unit_Id_Array;
+ -- Return all the units that must be elaborated after U. In addition,
+ -- if U is a body, include the corresponding spec; this ensures that
+ -- a spec/body pair are always in the same SCC.
+
+ procedure Create_SCC (Root : Unit_Id; Nodes : Unit_Id_Array);
+ -- Set Nodes of the Root, and set SCC_Root of all the Nodes
+
+ procedure Init_SCC_Num_Pred (U : Unit_Id);
+ -- Initialize the SCC_Num_Pred fields, so that the root of each SCC
+ -- has a count of the number of successors of all the units in the
+ -- SCC, but only for successors outside the SCC.
+
+ procedure Compute_SCCs is new Compute_Strongly_Connected_Components
+ (Node => Unit_Id,
+ First_Node => Units.First,
+ Last_Node => Units.Last,
+ Node_Array => Unit_Id_Array,
+ Successors => Successors,
+ Create_SCC => Create_SCC);
+
+ ----------------
+ -- Create_SCC --
+ ----------------
+
+ procedure Create_SCC (Root : Unit_Id; Nodes : Unit_Id_Array) is
+ begin
+ if Debug_Flag_V then
+ Write_Str ("Root = ");
+ Write_Int (Int (Root));
+ Write_Str (" ");
+ Write_Unit_Name (Units.Table (Root).Uname);
+ Write_Str (" -- ");
+ Write_Int (Nodes'Length);
+ Write_Str (" units:");
+ Write_Eol;
+
+ for J in Nodes'Range loop
+ Write_Str (" ");
+ Write_Int (Int (Nodes (J)));
+ Write_Str (" ");
+ Write_Unit_Name (Units.Table (Nodes (J)).Uname);
+ Write_Eol;
+ end loop;
+ end if;
+
+ pragma Assert (Nodes (Nodes'First) = Root);
+ pragma Assert (UNR.Table (Root).Nodes = null);
+ UNR.Table (Root).Nodes := new Unit_Id_Array'(Nodes);
+
+ for J in Nodes'Range loop
+ pragma Assert (SCC (Nodes (J)) = No_Unit_Id);
+ UNR.Table (Nodes (J)).SCC_Root := Root;
+ end loop;
+ end Create_SCC;
+
+ ----------------
+ -- Successors --
+ ----------------
+
+ function Successors (U : Unit_Id) return Unit_Id_Array is
+ S : Successor_Id := UNR.Table (U).Successors;
+ Tab : Unit_Id_Table;
+
+ begin
+ -- Pretend that a spec is a successor of its body (even though it
+ -- isn't), just so both get included.
+
+ if Units.Table (U).Utype = Is_Body then
+ Append (Tab, Corresponding_Spec (U));
+ end if;
+
+ -- Now include the real successors
+
+ while S /= No_Successor loop
+ pragma Assert (Succ.Table (S).Before = U);
+ Append (Tab, Succ.Table (S).After);
+ S := Succ.Table (S).Next;
+ end loop;
+
+ declare
+ Result : constant Unit_Id_Array := Tab.Table (1 .. Last (Tab));
+
+ begin
+ Free (Tab);
+ return Result;
+ end;
+ end Successors;
+
+ -----------------------
+ -- Init_SCC_Num_Pred --
+ -----------------------
+
+ procedure Init_SCC_Num_Pred (U : Unit_Id) is
+ begin
+ if UNR.Table (U).Visited then
+ return;
+ end if;
+
+ UNR.Table (U).Visited := True;
+
+ declare
+ S : Successor_Id := UNR.Table (U).Successors;
+
+ begin
+ while S /= No_Successor loop
+ pragma Assert (Succ.Table (S).Before = U);
+ Init_SCC_Num_Pred (Succ.Table (S).After);
+
+ if SCC (U) /= SCC (Succ.Table (S).After) then
+ UNR.Table (SCC (Succ.Table (S).After)).SCC_Num_Pred :=
+ UNR.Table (SCC (Succ.Table (S).After)).SCC_Num_Pred + 1;
+ end if;
+
+ S := Succ.Table (S).Next;
+ end loop;
+ end;
+ end Init_SCC_Num_Pred;
+
+ -- Start of processing for Compute_Unit_SCCs
+
+ begin
+ Compute_SCCs;
+
+ for Uref in UNR.First .. UNR.Last loop
+ pragma Assert (not UNR.Table (Uref).Visited);
+ null;
+ end loop;
+
+ for Uref in UNR.First .. UNR.Last loop
+ Init_SCC_Num_Pred (Uref);
+ end loop;
+
+ -- Assert that SCC_Root of all units has been set to a valid unit,
+ -- and that SCC_Num_Pred has not been modified in non-root units.
+
+ for Uref in UNR.First .. UNR.Last loop
+ pragma Assert (UNR.Table (Uref).SCC_Root /= No_Unit_Id);
+ pragma Assert (UNR.Table (Uref).SCC_Root in UNR.First .. UNR.Last);
+
+ if SCC (Uref) /= Uref then
+ pragma Assert (UNR.Table (Uref).SCC_Num_Pred = 0);
+ null;
+ end if;
+ end loop;
+ end Compute_Unit_SCCs;
+
+ --------------------------
+ -- Find_Elab_All_Errors --
+ --------------------------
+
+ procedure Find_Elab_All_Errors is
+ Withed_Unit : Unit_Id;
+
+ begin
+ for U in Units.First .. Units.Last loop
+
+ -- If this unit is not an interface to a stand-alone library,
+ -- process WITH references for this unit ignoring interfaces to
+ -- stand-alone libraries.
+
+ if not Units.Table (U).SAL_Interface then
+ for W in Units.Table (U).First_With ..
+ Units.Table (U).Last_With
+ loop
+ if Withs.Table (W).Sfile /= No_File
+ and then (not Withs.Table (W).SAL_Interface)
+ then
+ -- Check for special case of withing a unit that does not
+ -- exist any more.
+
+ if Get_Name_Table_Int (Withs.Table (W).Uname) = 0 then
+ goto Next_With;
+ end if;
+
+ Withed_Unit := Unit_Id_Of (Withs.Table (W).Uname);
+
+ -- If it's Elaborate_All or Elab_All_Desirable, check
+ -- that the withER and withEE are not in the same SCC.
+
+ if Withs.Table (W).Elaborate_All
+ or else Withs.Table (W).Elab_All_Desirable
+ then
+ if SCC (U) = SCC (Withed_Unit) then
+ Illegal_Elab_All := True; -- ????
+
+ -- We could probably give better error messages
+ -- than Elab_Old here, but for now, to avoid
+ -- disruption, we don't give any error here.
+ -- Instead, we set the Illegal_Elab_All flag above,
+ -- and then run the Elab_Old algorithm to issue the
+ -- error message. Ideally, we would like to print
+ -- multiple errors rather than stopping after the
+ -- first cycle.
+
+ if False then
+ Error_Msg_Output
+ ("illegal pragma Elaborate_All",
+ Info => False);
+ end if;
+ end if;
+ end if;
+ end if;
+
+ <<Next_With>>
+ null;
+ end loop;
+ end if;
+ end loop;
+ end Find_Elab_All_Errors;
+
+ ---------------------
+ -- Find_Elab_Order --
+ ---------------------
+
+ procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table) is
+ Best_So_Far : Unit_Id;
+ U : Unit_Id;
+
+ begin
+ -- Gather dependencies and output them if option set
+
+ Gather_Dependencies;
+
+ Compute_Unit_SCCs;
+
+ -- Initialize the no-predecessor list
+
+ No_Pred := No_Unit_Id;
+ for U in UNR.First .. UNR.Last loop
+ if UNR.Table (U).Num_Pred = 0 then
+ UNR.Table (U).Nextnp := No_Pred;
+ No_Pred := U;
+ end if;
+ end loop;
+
+ -- OK, now we determine the elaboration order proper. All we do is to
+ -- select the best choice from the no-predecessor list until all the
+ -- nodes have been chosen.
+
+ Outer : loop
+
+ -- If there are no nodes with predecessors, then either we are
+ -- done, as indicated by Num_Left being set to zero, or we have
+ -- a circularity. In the latter case, diagnose the circularity,
+ -- removing it from the graph and continue.
+ -- ????But Diagnose_Elaboration_Problem always raises an
+ -- exception.
+
+ Get_No_Pred : while No_Pred = No_Unit_Id loop
+ exit Outer when Num_Left < 1;
+ Diagnose_Elaboration_Problem (Elab_Order);
+ end loop Get_No_Pred;
+
+ U := No_Pred;
+ Best_So_Far := No_Unit_Id;
+
+ -- Loop to choose best entry in No_Pred list
+
+ No_Pred_Search : loop
+ if Debug_Flag_N then
+ Write_Str (" considering choice of ");
+ Write_Unit_Name (Units.Table (U).Uname);
+ Write_Eol;
+
+ if Units.Table (U).Elaborate_Body then
+ Write_Str
+ (" Elaborate_Body = True, Num_Pred for body = ");
+ Write_Int
+ (UNR.Table (Corresponding_Body (U)).Num_Pred);
+ else
+ Write_Str
+ (" Elaborate_Body = False");
+ end if;
+
+ Write_Eol;
+ end if;
+
+ -- Don't even consider units whose SCC is not ready. This
+ -- ensures that all units of an SCC will be elaborated
+ -- together, with no other units in between.
+
+ if SCC_Num_Pred (U) = 0
+ and then Better_Choice (U, Best_So_Far)
+ then
+ if Debug_Flag_N then
+ Write_Str (" tentatively chosen (best so far)");
+ Write_Eol;
+ end if;
+
+ Best_So_Far := U;
+ end if;
+
+ U := UNR.Table (U).Nextnp;
+ exit No_Pred_Search when U = No_Unit_Id;
+ end loop No_Pred_Search;
+
+ -- Choose the best candidate found
+
+ Choose (Elab_Order, Best_So_Far);
+
+ -- If it's a spec with a body, and the body is not yet chosen,
+ -- choose the body if possible. The case where the body is
+ -- already chosen is Elaborate_Body; the above call to Choose
+ -- the spec will also Choose the body.
+
+ if Units.Table (Best_So_Far).Utype = Is_Spec
+ and then UNR.Table
+ (Corresponding_Body (Best_So_Far)).Elab_Position = 0
+ then
+ declare
+ Choose_The_Body : constant Boolean :=
+ UNR.Table (Corresponding_Body
+ (Best_So_Far)).Num_Pred = 0;
+
+ begin
+ if Debug_Flag_B then
+ Write_Str ("Can we choose the body?... ");
+
+ if Choose_The_Body then
+ Write_Line ("Yes!");
+ else
+ Write_Line ("No.");
+ end if;
+ end if;
+
+ if Choose_The_Body then
+ Choose (Elab_Order, Corresponding_Body (Best_So_Far));
+ end if;
+ end;
+ end if;
+
+ -- Finally, choose all the rest of the units in the same SCC as
+ -- Best_So_Far. If it hasn't been chosen (Elab_Position = 0), and
+ -- it's ready to be chosen (Num_Pred = 0), then we can choose it.
+
+ loop
+ declare
+ Chose_One_Or_More : Boolean := False;
+ SCC : Unit_Id_Array renames Nodes (Best_So_Far).all;
+
+ begin
+ for J in SCC'Range loop
+ if UNR.Table (SCC (J)).Elab_Position = 0
+ and then UNR.Table (SCC (J)).Num_Pred = 0
+ then
+ Chose_One_Or_More := True;
+ Choose (Elab_Order, SCC (J));
+ end if;
+ end loop;
+
+ exit when not Chose_One_Or_More;
+ end;
+ end loop;
+ end loop Outer;
+
+ Find_Elab_All_Errors;
+ end Find_Elab_Order;
+
+ -----------
+ -- Nodes --
+ -----------
+
+ function Nodes (U : Unit_Id) return Unit_Id_Array_Ptr is
+ begin
+ return UNR.Table (SCC (U)).Nodes;
+ end Nodes;
+
+ ---------
+ -- SCC --
+ ---------
+
+ function SCC (U : Unit_Id) return Unit_Id is
+ begin
+ return UNR.Table (U).SCC_Root;
+ end SCC;
+
+ ------------------
+ -- SCC_Num_Pred --
+ ------------------
+
+ function SCC_Num_Pred (U : Unit_Id) return Int is
+ begin
+ return UNR.Table (SCC (U)).SCC_Num_Pred;
+ end SCC_Num_Pred;
+
+ ---------------
+ -- Write_SCC --
+ ---------------
+
+ procedure Write_SCC (U : Unit_Id) is
+ pragma Assert (SCC (U) = U);
+ begin
+ for J in Nodes (U)'Range loop
+ Write_Int (Int (UNR.Table (Nodes (U) (J)).Elab_Position));
+ Write_Str (". ");
+ Write_Unit_Name (Units.Table (Nodes (U) (J)).Uname);
+ Write_Eol;
+ end loop;
+
+ Write_Eol;
+ end Write_SCC;
+
+ end Elab_New;
+
+ --------------
+ -- Elab_Old --
+ --------------
+
+ package body Elab_Old is
+
+ ---------------------
+ -- Find_Elab_Order --
+ ---------------------
+
+ procedure Find_Elab_Order (Elab_Order : out Unit_Id_Table) is
+ Best_So_Far : Unit_Id;
+ U : Unit_Id;
+
+ begin
+ -- Gather dependencies and output them if option set
+
+ Gather_Dependencies;
+
+ -- Initialize the no-predecessor list
+
+ No_Pred := No_Unit_Id;
+ for U in UNR.First .. UNR.Last loop
+ if UNR.Table (U).Num_Pred = 0 then
+ UNR.Table (U).Nextnp := No_Pred;
+ No_Pred := U;
+ end if;
+ end loop;
+
+ -- OK, now we determine the elaboration order proper. All we do is to
+ -- select the best choice from the no-predecessor list until all the
+ -- nodes have been chosen.
+
+ Outer : loop
+
+ -- If there are no nodes with predecessors, then either we are
+ -- done, as indicated by Num_Left being set to zero, or we have
+ -- a circularity. In the latter case, diagnose the circularity,
+ -- removing it from the graph and continue.
+ -- ????But Diagnose_Elaboration_Problem always raises an
+ -- exception.
+
+ Get_No_Pred : while No_Pred = No_Unit_Id loop
+ exit Outer when Num_Left < 1;
+ Diagnose_Elaboration_Problem (Elab_Order);
+ end loop Get_No_Pred;
+
+ U := No_Pred;
+ Best_So_Far := No_Unit_Id;
+
+ -- Loop to choose best entry in No_Pred list
+
+ No_Pred_Search : loop
+ if Debug_Flag_N then
+ Write_Str (" considering choice of ");
+ Write_Unit_Name (Units.Table (U).Uname);
+ Write_Eol;
+
+ if Units.Table (U).Elaborate_Body then
+ Write_Str
+ (" Elaborate_Body = True, Num_Pred for body = ");
+ Write_Int
+ (UNR.Table (Corresponding_Body (U)).Num_Pred);
+ else
+ Write_Str
+ (" Elaborate_Body = False");
+ end if;
+
+ Write_Eol;
+ end if;
+
+ -- This is a candididate to be considered for choice
+
+ if Better_Choice (U, Best_So_Far) then
+ if Debug_Flag_N then
+ Write_Str (" tentatively chosen (best so far)");
+ Write_Eol;
+ end if;
+
+ Best_So_Far := U;
+ end if;
+
+ U := UNR.Table (U).Nextnp;
+ exit No_Pred_Search when U = No_Unit_Id;
+ end loop No_Pred_Search;
+
+ -- Choose the best candidate found
+
+ Choose (Elab_Order, Best_So_Far);
+ end loop Outer;
+ end Find_Elab_Order;
+
+ end Elab_Old;
+
end Binde;
diff --git a/gcc/ada/binde.ads b/gcc/ada/binde.ads
index 7ffa13fb64..79d9cdf0c9 100644
--- a/gcc/ada/binde.ads
+++ b/gcc/ada/binde.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -23,30 +23,38 @@
-- --
------------------------------------------------------------------------------
--- This package contains the routines to determine elaboration order
+-- This package contains the routine that determines library-level elaboration
+-- order.
with ALI; use ALI;
-with Table;
+with Namet; use Namet;
with Types; use Types;
+with GNAT.Dynamic_Tables;
+
package Binde is
- -- The following table records the chosen elaboration order. It is used
- -- by Gen_Elab_Call to generate the sequence of elaboration calls. Note
- -- that units are included in this table even if they have no elaboration
- -- routine, since the table is also used to drive the generation of object
- -- files in the binder output. Gen_Elab_Call skips any units that have no
- -- elaboration routine.
+ package Unit_Id_Tables is new GNAT.Dynamic_Tables
+ (Table_Component_Type => Unit_Id,
+ Table_Index_Type => Nat,
+ Table_Low_Bound => 1,
+ Table_Initial => 500,
+ Table_Increment => 200);
+ use Unit_Id_Tables;
- package Elab_Order is new Table.Table (
- Table_Component_Type => Unit_Id,
- Table_Index_Type => Nat,
- Table_Low_Bound => 1,
- Table_Initial => 500,
- Table_Increment => 200,
- Table_Name => "Elab_Order");
+ subtype Unit_Id_Table is Unit_Id_Tables.Instance;
+ subtype Unit_Id_Array is Unit_Id_Tables.Table_Type;
- procedure Find_Elab_Order;
- -- Determine elaboration order
+ procedure Find_Elab_Order
+ (Elab_Order : out Unit_Id_Table;
+ First_Main_Lib_File : File_Name_Type);
+ -- Determine elaboration order.
+ --
+ -- The Elab_Order table records the chosen elaboration order. It is used by
+ -- Gen_Elab_Calls to generate the sequence of elaboration calls. Note that
+ -- units are included in this table even if they have no elaboration
+ -- routine, since the table is also used to drive the generation of object
+ -- files in the binder output. Gen_Elab_Calls skips any units that have no
+ -- elaboration routine.
end Binde;
diff --git a/gcc/ada/binderr.ads b/gcc/ada/binderr.ads
index 46b1846e0e..a6434a0c22 100644
--- a/gcc/ada/binderr.ads
+++ b/gcc/ada/binderr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -31,10 +31,10 @@ with Types; use Types;
package Binderr is
- Errors_Detected : Int;
+ Errors_Detected : Nat;
-- Number of errors detected so far
- Warnings_Detected : Int;
+ Warnings_Detected : Nat;
-- Number of warnings detected
Info_Prefix_Suppress : Boolean := False;
diff --git a/gcc/ada/bindgen.adb b/gcc/ada/bindgen.adb
index c4f8c76c0c..b4d7cecc38 100644
--- a/gcc/ada/bindgen.adb
+++ b/gcc/ada/bindgen.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -24,7 +24,6 @@
------------------------------------------------------------------------------
with ALI; use ALI;
-with Binde; use Binde;
with Casing; use Casing;
with Fname; use Fname;
with Gnatvsn; use Gnatvsn;
@@ -47,12 +46,13 @@ with GNAT.Heap_Sort_A; use GNAT.Heap_Sort_A;
with GNAT.HTable;
package body Bindgen is
+ use Binde.Unit_Id_Tables;
Statement_Buffer : String (1 .. 1000);
-- Buffer used for constructing output statements
- Last : Natural := 0;
- -- Last location in Statement_Buffer currently set
+ Stm_Last : Natural := 0;
+ -- Stm_Last location in Statement_Buffer currently set
With_GNARL : Boolean := False;
-- Flag which indicates whether the program uses the GNARL library
@@ -113,13 +113,13 @@ package body Bindgen is
-- that the information is consistent across units. The entries
-- in this table are n/u/r/s for not set/user/runtime/system.
- package IS_Pragma_Settings is new Table.Table (
- Table_Component_Type => Character,
- Table_Index_Type => Int,
- Table_Low_Bound => 0,
- Table_Initial => 100,
- Table_Increment => 200,
- Table_Name => "IS_Pragma_Settings");
+ package IS_Pragma_Settings is new Table.Table
+ (Table_Component_Type => Character,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 0,
+ Table_Initial => 100,
+ Table_Increment => 200,
+ Table_Name => "IS_Pragma_Settings");
-- This table assembles the Priority_Specific_Dispatching pragma
-- information from all the units in the partition. Note that Bcheck has
@@ -127,13 +127,13 @@ package body Bindgen is
-- The entries in this table are the upper case first character of the
-- policy name, e.g. 'F' for FIFO_Within_Priorities.
- package PSD_Pragma_Settings is new Table.Table (
- Table_Component_Type => Character,
- Table_Index_Type => Int,
- Table_Low_Bound => 0,
- Table_Initial => 100,
- Table_Increment => 200,
- Table_Name => "PSD_Pragma_Settings");
+ package PSD_Pragma_Settings is new Table.Table
+ (Table_Component_Type => Character,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 0,
+ Table_Initial => 100,
+ Table_Increment => 200,
+ Table_Name => "PSD_Pragma_Settings");
----------------------------
-- Bind_Environment Table --
@@ -271,7 +271,7 @@ package body Bindgen is
-- Local Subprograms --
-----------------------
- procedure Gen_Adainit;
+ procedure Gen_Adainit (Elab_Order : Unit_Id_Array);
-- Generates the Adainit procedure
procedure Gen_Adafinal;
@@ -283,27 +283,29 @@ package body Bindgen is
procedure Gen_CodePeer_Wrapper;
-- For CodePeer, generate wrapper which calls user-defined main subprogram
- procedure Gen_Elab_Calls;
+ procedure Gen_Elab_Calls (Elab_Order : Unit_Id_Array);
-- Generate sequence of elaboration calls
- procedure Gen_Elab_Externals;
+ procedure Gen_Elab_Externals (Elab_Order : Unit_Id_Array);
-- Generate sequence of external declarations for elaboration
- procedure Gen_Elab_Order;
+ procedure Gen_Elab_Order (Elab_Order : Unit_Id_Array);
-- Generate comments showing elaboration order chosen
- procedure Gen_Finalize_Library;
+ procedure Gen_Finalize_Library (Elab_Order : Unit_Id_Array);
-- Generate a sequence of finalization calls to elaborated packages
procedure Gen_Main;
-- Generate procedure main
- procedure Gen_Object_Files_Options;
+ procedure Gen_Object_Files_Options (Elab_Order : Unit_Id_Array);
-- Output comments containing a list of the full names of the object
-- files to be linked and the list of linker options supplied by
-- Linker_Options pragmas in the source.
- procedure Gen_Output_File_Ada (Filename : String);
+ procedure Gen_Output_File_Ada
+ (Filename : String;
+ Elab_Order : Unit_Id_Array);
-- Generate Ada output file
procedure Gen_Restrictions;
@@ -335,11 +337,11 @@ package body Bindgen is
-- the encoding method used for the main program source. If there is no
-- main program source (-z switch used), returns brackets ('b').
- function Has_Finalizer return Boolean;
+ function Has_Finalizer (Elab_Order : Unit_Id_Array) return Boolean;
-- Determine whether the current unit has at least one library-level
-- finalizer.
- function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean;
+ function Lt_Linker_Option (Op1 : Natural; Op2 : Natural) return Boolean;
-- Compare linker options, when sorting, first according to
-- Is_Internal_File (internal files come later) and then by
-- elaboration order position (latest to earliest).
@@ -347,21 +349,21 @@ package body Bindgen is
procedure Move_Linker_Option (From : Natural; To : Natural);
-- Move routine for sorting linker options
- procedure Resolve_Binder_Options;
+ procedure Resolve_Binder_Options (Elab_Order : Unit_Id_Array);
-- Set the value of With_GNARL
procedure Set_Char (C : Character);
- -- Set given character in Statement_Buffer at the Last + 1 position
- -- and increment Last by one to reflect the stored character.
+ -- Set given character in Statement_Buffer at the Stm_Last + 1 position
+ -- and increment Stm_Last by one to reflect the stored character.
procedure Set_Int (N : Int);
-- Set given value in decimal in Statement_Buffer with no spaces starting
- -- at the Last + 1 position, and updating Last past the value. A minus sign
- -- is output for a negative value.
+ -- at the Stm_Last + 1 position, and updating Stm_Last past the value. A
+ -- minus sign is output for a negative value.
procedure Set_Boolean (B : Boolean);
- -- Set given boolean value in Statement_Buffer at the Last + 1 position
- -- and update Last past the value.
+ -- Set given boolean value in Statement_Buffer at the Stm_Last + 1 position
+ -- and update Stm_Last past the value.
procedure Set_IS_Pragma_Table;
-- Initializes contents of IS_Pragma_Settings table from ALI table
@@ -369,7 +371,7 @@ package body Bindgen is
procedure Set_Main_Program_Name;
-- Given the main program name in Name_Buffer (length in Name_Len) generate
-- the name of the routine to be used in the call. The name is generated
- -- starting at Last + 1, and Last is updated past it.
+ -- starting at Stm_Last + 1, and Stm_Last is updated past it.
procedure Set_Name_Buffer;
-- Set the value stored in positions 1 .. Name_Len of the Name_Buffer
@@ -379,7 +381,7 @@ package body Bindgen is
procedure Set_String (S : String);
-- Sets characters of given string in Statement_Buffer, starting at the
- -- Last + 1 position, and updating last past the string value.
+ -- Stm_Last + 1 position, and updating last past the string value.
procedure Set_String_Replace (S : String);
-- Replaces the last S'Length characters in the Statement_Buffer with the
@@ -388,8 +390,8 @@ package body Bindgen is
procedure Set_Unit_Name;
-- Given a unit name in the Name_Buffer, copy it into Statement_Buffer,
- -- starting at the Last + 1 position and update Last past the value.
- -- Each dot (.) will be qualified into double underscores (__).
+ -- starting at the Stm_Last + 1 position and update Stm_Last past the
+ -- value. Each dot (.) will be qualified into double underscores (__).
procedure Set_Unit_Number (U : Unit_Id);
-- Sets unit number (first unit is 1, leading zeroes output to line up all
@@ -397,11 +399,12 @@ package body Bindgen is
-- number of units.
procedure Write_Statement_Buffer;
- -- Write out contents of statement buffer up to Last, and reset Last to 0
+ -- Write out contents of statement buffer up to Stm_Last, and reset
+ -- Stm_Last to 0.
procedure Write_Statement_Buffer (S : String);
-- First writes its argument (using Set_String (S)), then writes out the
- -- contents of statement buffer up to Last, and reset Last to 0
+ -- contents of statement buffer up to Stm_Last, and resets Stm_Last to 0.
procedure Write_Bind_Line (S : String);
-- Write S (an LF-terminated string) to the binder file (for use with
@@ -415,7 +418,13 @@ package body Bindgen is
begin
WBI (" procedure " & Ada_Final_Name.all & " is");
- if Bind_Main_Program and not CodePeer_Mode then
+ -- Call s_stalib_adafinal to await termination of tasks and so on. We
+ -- want to do this if there is a main program, either in Ada or in some
+ -- other language. (Note that Bind_Main_Program is True for Ada mains,
+ -- but False for mains in other languages.) We do not want to do this if
+ -- we're binding a library.
+
+ if not Bind_For_Library and not CodePeer_Mode then
WBI (" procedure s_stalib_adafinal;");
Set_String (" pragma Import (C, s_stalib_adafinal, ");
Set_String ("""system__standard_library__adafinal"");");
@@ -442,7 +451,7 @@ package body Bindgen is
-- on whether this is the main program or a library.
if not CodePeer_Mode then
- if Bind_Main_Program then
+ if not Bind_For_Library then
WBI (" s_stalib_adafinal;");
elsif Lib_Final_Built then
WBI (" finalize_library;");
@@ -466,7 +475,7 @@ package body Bindgen is
-- Gen_Adainit --
-----------------
- procedure Gen_Adainit is
+ procedure Gen_Adainit (Elab_Order : Unit_Id_Array) is
Main_Priority : Int renames ALIs.Table (ALIs.First).Main_Priority;
Main_CPU : Int renames ALIs.Table (ALIs.First).Main_CPU;
@@ -495,14 +504,6 @@ package body Bindgen is
if CodePeer_Mode then
WBI (" begin");
- -- When compiling for the AAMP small library, where the standard library
- -- is no longer suppressed, we still want to exclude the setting of the
- -- various imported globals, which aren't present for that library.
-
- elsif AAMP_On_Target and then Configurable_Run_Time_On_Target then
- WBI (" begin");
- WBI (" null;");
-
-- If the standard library is suppressed, then the only global variables
-- that might be needed (by the Ravenscar profile) are the priority and
-- the processor for the environment task.
@@ -894,8 +895,8 @@ package body Bindgen is
Write_Statement_Buffer;
end if;
- -- Initialize stack limit variable of the environment task if the
- -- stack check method is stack limit and stack check is enabled.
+ -- Initialize stack limit variable of the environment task if the stack
+ -- check method is stack limit and stack check is enabled.
if Stack_Check_Limits_On_Target
and then (Stack_Check_Default_On_Target or Stack_Check_Switch_Set)
@@ -914,7 +915,7 @@ package body Bindgen is
-- tasks are non-terminating, so we do not want library-level
-- finalization.
- elsif Bind_Main_Program
+ elsif not Bind_For_Library
and then not Configurable_Run_Time_On_Target
and then not Suppress_Standard_Library_On_Target
then
@@ -936,37 +937,41 @@ package body Bindgen is
WBI ("");
end if;
- Gen_Elab_Calls;
+ Gen_Elab_Calls (Elab_Order);
- -- Call System.Elaboration_Allocators.Mark_Start_Of_Elaboration if
- -- restriction No_Standard_Allocators_After_Elaboration is active.
-
- if Cumulative_Restrictions.Set
- (No_Standard_Allocators_After_Elaboration)
- then
- WBI (" System.Elaboration_Allocators.Mark_End_Of_Elaboration;");
- end if;
+ if not CodePeer_Mode then
- -- From this point, no new dispatching domain can be created
+ -- Call System.Elaboration_Allocators.Mark_Start_Of_Elaboration if
+ -- restriction No_Standard_Allocators_After_Elaboration is active.
- if Dispatching_Domains_Used then
- WBI (" Freeze_Dispatching_Domains;");
- end if;
+ if Cumulative_Restrictions.Set
+ (No_Standard_Allocators_After_Elaboration)
+ then
+ WBI
+ (" System.Elaboration_Allocators.Mark_End_Of_Elaboration;");
+ end if;
- -- Sequential partition elaboration policy
+ -- From this point, no new dispatching domain can be created
- if Partition_Elaboration_Policy_Specified = 'S' then
- if System_Interrupts_Used then
- WBI (" Install_Restricted_Handlers_Sequential;");
+ if Dispatching_Domains_Used then
+ WBI (" Freeze_Dispatching_Domains;");
end if;
- if System_Tasking_Restricted_Stages_Used then
- WBI (" Activate_All_Tasks_Sequential;");
+ -- Sequential partition elaboration policy
+
+ if Partition_Elaboration_Policy_Specified = 'S' then
+ if System_Interrupts_Used then
+ WBI (" Install_Restricted_Handlers_Sequential;");
+ end if;
+
+ if System_Tasking_Restricted_Stages_Used then
+ WBI (" Activate_All_Tasks_Sequential;");
+ end if;
end if;
- end if;
- if System_BB_CPU_Primitives_Multiprocessors_Used then
- WBI (" Start_Slave_CPUs;");
+ if System_BB_CPU_Primitives_Multiprocessors_Used then
+ WBI (" Start_Slave_CPUs;");
+ end if;
end if;
WBI (" end " & Ada_Init_Name.all & ";");
@@ -978,9 +983,6 @@ package body Bindgen is
-------------------------
procedure Gen_Bind_Env_String is
- KN, VN : Name_Id := No_Name;
- Amp : Character;
-
procedure Write_Name_With_Len (Nam : Name_Id);
-- Write Nam as a string literal, prefixed with one
-- character encoding Nam's length.
@@ -1000,10 +1002,17 @@ package body Bindgen is
Write_String_Table_Entry (End_String);
end Write_Name_With_Len;
+ -- Local variables
+
+ Amp : Character;
+ KN : Name_Id := No_Name;
+ VN : Name_Id := No_Name;
+
-- Start of processing for Gen_Bind_Env_String
begin
Bind_Environment.Get_First (KN, VN);
+
if VN = No_Name then
return;
end if;
@@ -1056,15 +1065,15 @@ package body Bindgen is
-- Gen_Elab_Calls --
--------------------
- procedure Gen_Elab_Calls is
+ procedure Gen_Elab_Calls (Elab_Order : Unit_Id_Array) is
Check_Elab_Flag : Boolean;
begin
-- Loop through elaboration order entries
- for E in Elab_Order.First .. Elab_Order.Last loop
+ for E in Elab_Order'Range loop
declare
- Unum : constant Unit_Id := Elab_Order.Table (E);
+ Unum : constant Unit_Id := Elab_Order (E);
U : Unit_Record renames Units.Table (Unum);
Unum_Spec : Unit_Id;
@@ -1116,38 +1125,9 @@ package body Bindgen is
then
Set_String (" E");
Set_Unit_Number (Unum_Spec);
-
- -- The AAMP target has no notion of shared libraries, and
- -- there's no possibility of reelaboration, so we treat the
- -- the elaboration var as a flag instead of a counter and
- -- simply set it.
-
- if AAMP_On_Target then
- Set_String (" := 1;");
-
- -- Otherwise (normal case), increment elaboration counter
-
- else
- Set_String (" := E");
- Set_Unit_Number (Unum_Spec);
- Set_String (" + 1;");
- end if;
-
- Write_Statement_Buffer;
-
- -- In the special case where the target is AAMP and the unit is
- -- a spec with a body, the elaboration entity is initialized
- -- here. This is done because it's the only way to accomplish
- -- initialization of such entities, as there is no mechanism
- -- for load time global variable initialization on AAMP.
-
- elsif AAMP_On_Target
- and then U.Utype = Is_Spec
- and then Units.Table (Unum_Spec).Set_Elab_Entity
- then
- Set_String (" E");
+ Set_String (" := E");
Set_Unit_Number (Unum_Spec);
- Set_String (" := 0;");
+ Set_String (" + 1;");
Write_Statement_Buffer;
end if;
@@ -1171,22 +1151,6 @@ package body Bindgen is
-- variables, only calls to 'Elab* subprograms.
else
- -- In the special case where the target is AAMP and the unit is
- -- a spec with a body, the elaboration entity is initialized
- -- here. This is done because it's the only way to accomplish
- -- initialization of such entities, as there is no mechanism
- -- for load time global variable initialization on AAMP.
-
- if AAMP_On_Target
- and then U.Utype = Is_Spec
- and then Units.Table (Unum_Spec).Set_Elab_Entity
- then
- Set_String (" E");
- Set_Unit_Number (Unum_Spec);
- Set_String (" := 0;");
- Write_Statement_Buffer;
- end if;
-
-- Check incompatibilities with No_Multiple_Elaboration
if not CodePeer_Mode
@@ -1270,23 +1234,9 @@ package body Bindgen is
then
Set_String (" E");
Set_Unit_Number (Unum_Spec);
-
- -- The AAMP target has no notion of shared libraries, and
- -- there's no possibility of reelaboration, so we treat the
- -- the elaboration var as a flag instead of a counter and
- -- simply set it.
-
- if AAMP_On_Target then
- Set_String (" := 1;");
-
- -- Otherwise (normal case), increment elaboration counter
-
- else
- Set_String (" := E");
- Set_Unit_Number (Unum_Spec);
- Set_String (" + 1;");
- end if;
-
+ Set_String (" := E");
+ Set_Unit_Number (Unum_Spec);
+ Set_String (" + 1;");
Write_Statement_Buffer;
end if;
end if;
@@ -1298,15 +1248,15 @@ package body Bindgen is
-- Gen_Elab_Externals --
------------------------
- procedure Gen_Elab_Externals is
+ procedure Gen_Elab_Externals (Elab_Order : Unit_Id_Array) is
begin
if CodePeer_Mode then
return;
end if;
- for E in Elab_Order.First .. Elab_Order.Last loop
+ for E in Elab_Order'Range loop
declare
- Unum : constant Unit_Id := Elab_Order.Table (E);
+ Unum : constant Unit_Id := Elab_Order (E);
U : Unit_Record renames Units.Table (Unum);
begin
@@ -1346,13 +1296,13 @@ package body Bindgen is
-- Gen_Elab_Order --
--------------------
- procedure Gen_Elab_Order is
+ procedure Gen_Elab_Order (Elab_Order : Unit_Id_Array) is
begin
WBI (" -- BEGIN ELABORATION ORDER");
- for J in Elab_Order.First .. Elab_Order.Last loop
+ for J in Elab_Order'Range loop
Set_String (" -- ");
- Get_Name_String (Units.Table (Elab_Order.Table (J)).Uname);
+ Get_Name_String (Units.Table (Elab_Order (J)).Uname);
Set_Name_Buffer;
Write_Statement_Buffer;
end loop;
@@ -1365,12 +1315,7 @@ package body Bindgen is
-- Gen_Finalize_Library --
--------------------------
- procedure Gen_Finalize_Library is
- Count : Int := 1;
- U : Unit_Record;
- Uspec : Unit_Record;
- Unum : Unit_Id;
-
+ procedure Gen_Finalize_Library (Elab_Order : Unit_Id_Array) is
procedure Gen_Header;
-- Generate the header of the finalization routine
@@ -1384,6 +1329,13 @@ package body Bindgen is
WBI (" begin");
end Gen_Header;
+ -- Local variables
+
+ Count : Int := 1;
+ U : Unit_Record;
+ Uspec : Unit_Record;
+ Unum : Unit_Id;
+
-- Start of processing for Gen_Finalize_Library
begin
@@ -1391,8 +1343,8 @@ package body Bindgen is
return;
end if;
- for E in reverse Elab_Order.First .. Elab_Order.Last loop
- Unum := Elab_Order.Table (E);
+ for E in reverse Elab_Order'Range loop
+ Unum := Elab_Order (E);
U := Units.Table (Unum);
-- Dealing with package bodies is a little complicated. In such
@@ -1691,11 +1643,11 @@ package body Bindgen is
end if;
end if;
- -- Generate a reference to Ada_Main_Program_Name. This symbol is
- -- not referenced elsewhere in the generated program, but is needed
- -- by the debugger (that's why it is generated in the first place).
- -- The reference stops Ada_Main_Program_Name from being optimized
- -- away by smart linkers, such as the AiX linker.
+ -- Generate a reference to Ada_Main_Program_Name. This symbol is not
+ -- referenced elsewhere in the generated program, but is needed by
+ -- the debugger (that's why it is generated in the first place). The
+ -- reference stops Ada_Main_Program_Name from being optimized away by
+ -- smart linkers, such as the AiX linker.
-- Because this variable is unused, we make this variable "aliased"
-- with a pragma Volatile in order to tell the compiler to preserve
@@ -1721,9 +1673,9 @@ package body Bindgen is
WBI (" gnat_envp := envp;");
WBI ("");
- -- If configurable run time and no command line args, then nothing
- -- needs to be done since the gnat_argc/argv/envp variables are
- -- suppressed in this case.
+ -- If configurable run time and no command line args, then nothing needs
+ -- to be done since the gnat_argc/argv/envp variables are suppressed in
+ -- this case.
elsif Configurable_Run_Time_On_Target then
null;
@@ -1824,11 +1776,11 @@ package body Bindgen is
-- Gen_Object_Files_Options --
------------------------------
- procedure Gen_Object_Files_Options is
+ procedure Gen_Object_Files_Options (Elab_Order : Unit_Id_Array) is
Lgnat : Natural;
- -- This keeps track of the position in the sorted set of entries
- -- in the Linker_Options table of where the first entry from an
- -- internal file appears.
+ -- This keeps track of the position in the sorted set of entries in the
+ -- Linker_Options table of where the first entry from an internal file
+ -- appears.
Linker_Option_List_Started : Boolean := False;
-- Set to True when "LINKER OPTION LIST" is displayed
@@ -1893,17 +1845,17 @@ package body Bindgen is
Set_List_File (Object_List_Filename.all);
end if;
- for E in Elab_Order.First .. Elab_Order.Last loop
+ for E in Elab_Order'Range loop
-- If not spec that has an associated body, then generate a comment
-- giving the name of the corresponding object file.
- if not Units.Table (Elab_Order.Table (E)).SAL_Interface
- and then Units.Table (Elab_Order.Table (E)).Utype /= Is_Spec
+ if not Units.Table (Elab_Order (E)).SAL_Interface
+ and then Units.Table (Elab_Order (E)).Utype /= Is_Spec
then
Get_Name_String
(ALIs.Table
- (Units.Table (Elab_Order.Table (E)).My_ALI).Ofile_Full_Name);
+ (Units.Table (Elab_Order (E)).My_ALI).Ofile_Full_Name);
-- If the presence of an object file is necessary or if it exists,
-- then use it.
@@ -1931,6 +1883,7 @@ package body Bindgen is
for J in 1 .. Nb_Dir_In_Obj_Search_Path loop
declare
Dir : constant String_Ptr := Dir_In_Obj_Search_Path (J);
+
begin
Name_Len := 0;
Add_Str_To_Name_Buffer ("-L");
@@ -2053,7 +2006,10 @@ package body Bindgen is
-- Gen_Output_File --
---------------------
- procedure Gen_Output_File (Filename : String) is
+ procedure Gen_Output_File
+ (Filename : String;
+ Elab_Order : Unit_Id_Array)
+ is
begin
-- Acquire settings for Interrupt_State pragmas
@@ -2071,8 +2027,8 @@ package body Bindgen is
-- Count number of elaboration calls
- for E in Elab_Order.First .. Elab_Order.Last loop
- if Units.Table (Elab_Order.Table (E)).No_Elab then
+ for E in Elab_Order'Range loop
+ if Units.Table (Elab_Order (E)).No_Elab then
null;
else
Num_Elab_Calls := Num_Elab_Calls + 1;
@@ -2081,21 +2037,23 @@ package body Bindgen is
-- Generate output file in appropriate language
- Gen_Output_File_Ada (Filename);
+ Gen_Output_File_Ada (Filename, Elab_Order);
end Gen_Output_File;
-------------------------
-- Gen_Output_File_Ada --
-------------------------
- procedure Gen_Output_File_Ada (Filename : String) is
-
+ procedure Gen_Output_File_Ada
+ (Filename : String; Elab_Order : Unit_Id_Array)
+ is
Ada_Main : constant String := Get_Ada_Main_Name;
-- Name to be used for generated Ada main program. See the body of
-- function Get_Ada_Main_Name for details on the form of the name.
Needs_Library_Finalization : constant Boolean :=
- not Configurable_Run_Time_On_Target and then Has_Finalizer;
+ not Configurable_Run_Time_On_Target
+ and then Has_Finalizer (Elab_Order);
-- For restricted run-time libraries (ZFP and Ravenscar) tasks are
-- non-terminating, so we do not want finalization.
@@ -2153,7 +2111,7 @@ package body Bindgen is
WBI ("with System.Secondary_Stack;");
end if;
- Resolve_Binder_Options;
+ Resolve_Binder_Options (Elab_Order);
-- Generate standard with's
@@ -2297,7 +2255,7 @@ package body Bindgen is
end if;
Gen_Versions;
- Gen_Elab_Order;
+ Gen_Elab_Order (Elab_Order);
-- Spec is complete
@@ -2380,7 +2338,7 @@ package body Bindgen is
-- Generate externals for elaboration entities
- Gen_Elab_Externals;
+ Gen_Elab_Externals (Elab_Order);
if not CodePeer_Mode then
if not Suppress_Standard_Library_On_Target then
@@ -2432,13 +2390,13 @@ package body Bindgen is
if not Cumulative_Restrictions.Set (No_Finalization) then
if Needs_Library_Finalization then
- Gen_Finalize_Library;
+ Gen_Finalize_Library (Elab_Order);
end if;
Gen_Adafinal;
end if;
- Gen_Adainit;
+ Gen_Adainit (Elab_Order);
if Bind_Main_Program then
Gen_Main;
@@ -2446,7 +2404,7 @@ package body Bindgen is
-- Output object file list and the Ada body is complete
- Gen_Object_Files_Options;
+ Gen_Object_Files_Options (Elab_Order);
WBI ("");
WBI ("end " & Ada_Main & ";");
@@ -2576,8 +2534,8 @@ package body Bindgen is
WBI (" type Version_32 is mod 2 ** 32;");
for U in Units.First .. Units.Last loop
if not Units.Table (U).SAL_Interface
- and then
- (not Bind_For_Library or else Units.Table (U).Directly_Scanned)
+ and then (not Bind_For_Library
+ or else Units.Table (U).Directly_Scanned)
then
Increment_Ubuf;
WBI (" " & Ubuf & " : constant Version_32 := 16#" &
@@ -2637,19 +2595,20 @@ package body Bindgen is
function Get_Ada_Main_Name return String is
Suffix : constant String := "_00";
Name : String (1 .. Opt.Ada_Main_Name.all'Length + Suffix'Length) :=
- Opt.Ada_Main_Name.all & Suffix;
+ Opt.Ada_Main_Name.all & Suffix;
Nlen : Natural;
begin
- -- For CodePeer, we want reproducible names (independent of other
- -- mains that may or may not be present) that don't collide
- -- when analyzing multiple mains and which are easily recognizable
- -- as "ada_main" names.
+ -- For CodePeer, we want reproducible names (independent of other mains
+ -- that may or may not be present) that don't collide when analyzing
+ -- multiple mains and which are easily recognizable as "ada_main" names.
if CodePeer_Mode then
Get_Name_String (Units.Table (First_Unit_Entry).Uname);
- return "ada_main_for_" &
- Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len - 2));
+
+ return
+ "ada_main_for_" &
+ Get_Main_Unit_Name (Name_Buffer (1 .. Name_Len - 2));
end if;
-- This loop tries the following possibilities in order
@@ -2770,13 +2729,13 @@ package body Bindgen is
-- Has_Finalizer --
-------------------
- function Has_Finalizer return Boolean is
+ function Has_Finalizer (Elab_Order : Unit_Id_Array) return Boolean is
U : Unit_Record;
Unum : Unit_Id;
begin
- for E in reverse Elab_Order.First .. Elab_Order.Last loop
- Unum := Elab_Order.Table (E);
+ for E in reverse Elab_Order'Range loop
+ Unum := Elab_Order (E);
U := Units.Table (Unum);
-- We are only interested in non-generic packages
@@ -2806,7 +2765,7 @@ package body Bindgen is
-- Lt_Linker_Option --
----------------------
- function Lt_Linker_Option (Op1, Op2 : Natural) return Boolean is
+ function Lt_Linker_Option (Op1 : Natural; Op2 : Natural) return Boolean is
begin
-- Sort internal files last
@@ -2828,7 +2787,6 @@ package body Bindgen is
return Units.Table (Linker_Options.Table (Op1).Unit).Elab_Position
>
Units.Table (Linker_Options.Table (Op2).Unit).Elab_Position;
-
end if;
end Lt_Linker_Option;
@@ -2845,8 +2803,7 @@ package body Bindgen is
-- Resolve_Binder_Options --
----------------------------
- procedure Resolve_Binder_Options is
-
+ procedure Resolve_Binder_Options (Elab_Order : Unit_Id_Array) is
procedure Check_Package (Var : in out Boolean; Name : String);
-- Set Var to true iff the current identifier in Namet is Name. Do
-- nothing if it doesn't match. This procedure is just a helper to
@@ -2868,8 +2825,8 @@ package body Bindgen is
-- Start of processing for Resolve_Binder_Options
begin
- for E in Elab_Order.First .. Elab_Order.Last loop
- Get_Name_String (Units.Table (Elab_Order.Table (E)).Uname);
+ for E in Elab_Order'Range loop
+ Get_Name_String (Units.Table (Elab_Order (E)).Uname);
-- This is not a perfect approach, but is the current protocol
-- between the run-time and the binder to indicate that tasking is
@@ -2922,7 +2879,7 @@ package body Bindgen is
Osint.Fail ("bind environment value """ & Value & """ too long");
end if;
- Bind_Environment.Set (Name_Find_Str (Key), Name_Find_Str (Value));
+ Bind_Environment.Set (Name_Find (Key), Name_Find (Value));
end Set_Bind_Env;
-----------------
@@ -2930,15 +2887,18 @@ package body Bindgen is
-----------------
procedure Set_Boolean (B : Boolean) is
- True_Str : constant String := "True";
False_Str : constant String := "False";
+ True_Str : constant String := "True";
+
begin
if B then
- Statement_Buffer (Last + 1 .. Last + True_Str'Length) := True_Str;
- Last := Last + True_Str'Length;
+ Statement_Buffer (Stm_Last + 1 .. Stm_Last + True_Str'Length) :=
+ True_Str;
+ Stm_Last := Stm_Last + True_Str'Length;
else
- Statement_Buffer (Last + 1 .. Last + False_Str'Length) := False_Str;
- Last := Last + False_Str'Length;
+ Statement_Buffer (Stm_Last + 1 .. Stm_Last + False_Str'Length) :=
+ False_Str;
+ Stm_Last := Stm_Last + False_Str'Length;
end if;
end Set_Boolean;
@@ -2948,8 +2908,8 @@ package body Bindgen is
procedure Set_Char (C : Character) is
begin
- Last := Last + 1;
- Statement_Buffer (Last) := C;
+ Stm_Last := Stm_Last + 1;
+ Statement_Buffer (Stm_Last) := C;
end Set_Char;
-------------
@@ -2967,8 +2927,8 @@ package body Bindgen is
Set_Int (N / 10);
end if;
- Last := Last + 1;
- Statement_Buffer (Last) :=
+ Stm_Last := Stm_Last + 1;
+ Statement_Buffer (Stm_Last) :=
Character'Val (N mod 10 + Character'Pos ('0'));
end if;
end Set_Int;
@@ -2985,9 +2945,9 @@ package body Bindgen is
loop
declare
Inum : constant Int :=
- Interrupt_States.Table (K).Interrupt_Id;
+ Interrupt_States.Table (K).Interrupt_Id;
Stat : constant Character :=
- Interrupt_States.Table (K).Interrupt_State;
+ Interrupt_States.Table (K).Interrupt_State;
begin
while IS_Pragma_Settings.Last < Inum loop
@@ -3008,8 +2968,8 @@ package body Bindgen is
begin
-- Note that name has %b on the end which we ignore
- -- First we output the initial _ada_ since we know that the main
- -- program is a library level subprogram.
+ -- First we output the initial _ada_ since we know that the main program
+ -- is a library level subprogram.
Set_String ("_ada_");
@@ -3068,8 +3028,8 @@ package body Bindgen is
procedure Set_String (S : String) is
begin
- Statement_Buffer (Last + 1 .. Last + S'Length) := S;
- Last := Last + S'Length;
+ Statement_Buffer (Stm_Last + 1 .. Stm_Last + S'Length) := S;
+ Stm_Last := Stm_Last + S'Length;
end Set_String;
------------------------
@@ -3078,7 +3038,7 @@ package body Bindgen is
procedure Set_String_Replace (S : String) is
begin
- Statement_Buffer (Last - S'Length + 1 .. Last) := S;
+ Statement_Buffer (Stm_Last - S'Length + 1 .. Stm_Last) := S;
end Set_String_Replace;
-------------------
@@ -3133,8 +3093,8 @@ package body Bindgen is
procedure Write_Statement_Buffer is
begin
- WBI (Statement_Buffer (1 .. Last));
- Last := 0;
+ WBI (Statement_Buffer (1 .. Stm_Last));
+ Stm_Last := 0;
end Write_Statement_Buffer;
procedure Write_Statement_Buffer (S : String) is
diff --git a/gcc/ada/bindgen.ads b/gcc/ada/bindgen.ads
index 2f4cc78c48..070c7fc4f1 100644
--- a/gcc/ada/bindgen.ads
+++ b/gcc/ada/bindgen.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -32,9 +32,13 @@
-- See the body for exact details of the file that is generated
+with Binde; use Binde;
+
package Bindgen is
- procedure Gen_Output_File (Filename : String);
+ procedure Gen_Output_File
+ (Filename : String;
+ Elab_Order : Unit_Id_Array);
-- Filename is the full path name of the binder output file
procedure Set_Bind_Env (Key, Value : String);
diff --git a/gcc/ada/bindusg.adb b/gcc/ada/bindusg.adb
index f1a61777bf..9da8ce9bb7 100644
--- a/gcc/ada/bindusg.adb
+++ b/gcc/ada/bindusg.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -113,7 +113,9 @@ package body Bindusg is
Write_Line (" and enable symbolic tracebacks");
Write_Line (" -E Same as -Ea");
- -- The -f switch is voluntarily omitted, because it is obsolete
+ -- Line for -f switch
+
+ Write_Line (" -ffile Force elaboration order from given file");
-- Line for -F switch
diff --git a/gcc/ada/casing.adb b/gcc/ada/casing.adb
index 5ed97be126..d61112e1ed 100644
--- a/gcc/ada/casing.adb
+++ b/gcc/ada/casing.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -30,7 +30,6 @@
------------------------------------------------------------------------------
with Csets; use Csets;
-with Namet; use Namet;
with Opt; use Opt;
with Widechar; use Widechar;
@@ -125,7 +124,11 @@ package body Casing is
-- Set_Casing --
----------------
- procedure Set_Casing (C : Casing_Type; D : Casing_Type := Mixed_Case) is
+ procedure Set_Casing
+ (Buf : in out Bounded_String;
+ C : Casing_Type;
+ D : Casing_Type := Mixed_Case)
+ is
Ptr : Natural;
Actual_Casing : Casing_Type;
@@ -144,7 +147,7 @@ package body Casing is
Ptr := 1;
- while Ptr <= Name_Len loop
+ while Ptr <= Buf.Length loop
-- Wide character. Note that we do nothing with casing in this case.
-- In Ada 2005 mode, required folding of lower case letters happened
@@ -156,29 +159,29 @@ package body Casing is
-- the requested casing operation, beyond folding to upper case
-- when it is mandatory, which does not involve underscores.
- if Name_Buffer (Ptr) = ASCII.ESC
- or else Name_Buffer (Ptr) = '['
+ if Buf.Chars (Ptr) = ASCII.ESC
+ or else Buf.Chars (Ptr) = '['
or else (Upper_Half_Encoding
- and then Name_Buffer (Ptr) in Upper_Half_Character)
+ and then Buf.Chars (Ptr) in Upper_Half_Character)
then
- Skip_Wide (Name_Buffer, Ptr);
+ Skip_Wide (Buf.Chars, Ptr);
After_Und := False;
-- Underscore, or non-identifer character (error case)
- elsif Name_Buffer (Ptr) = '_'
- or else not Identifier_Char (Name_Buffer (Ptr))
+ elsif Buf.Chars (Ptr) = '_'
+ or else not Identifier_Char (Buf.Chars (Ptr))
then
After_Und := True;
Ptr := Ptr + 1;
-- Lower case letter
- elsif Is_Lower_Case_Letter (Name_Buffer (Ptr)) then
+ elsif Is_Lower_Case_Letter (Buf.Chars (Ptr)) then
if Actual_Casing = All_Upper_Case
or else (After_Und and then Actual_Casing = Mixed_Case)
then
- Name_Buffer (Ptr) := Fold_Upper (Name_Buffer (Ptr));
+ Buf.Chars (Ptr) := Fold_Upper (Buf.Chars (Ptr));
end if;
After_Und := False;
@@ -186,11 +189,11 @@ package body Casing is
-- Upper case letter
- elsif Is_Upper_Case_Letter (Name_Buffer (Ptr)) then
+ elsif Is_Upper_Case_Letter (Buf.Chars (Ptr)) then
if Actual_Casing = All_Lower_Case
or else (not After_Und and then Actual_Casing = Mixed_Case)
then
- Name_Buffer (Ptr) := Fold_Lower (Name_Buffer (Ptr));
+ Buf.Chars (Ptr) := Fold_Lower (Buf.Chars (Ptr));
end if;
After_Und := False;
@@ -205,4 +208,9 @@ package body Casing is
end loop;
end Set_Casing;
+ procedure Set_Casing (C : Casing_Type; D : Casing_Type := Mixed_Case) is
+ begin
+ Set_Casing (Global_Name_Buffer, C, D);
+ end Set_Casing;
+
end Casing;
diff --git a/gcc/ada/casing.ads b/gcc/ada/casing.ads
index dec27eed44..e3f7a3a192 100644
--- a/gcc/ada/casing.ads
+++ b/gcc/ada/casing.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,6 +29,7 @@
-- --
------------------------------------------------------------------------------
+with Namet; use Namet;
with Types; use Types;
package Casing is
@@ -68,14 +69,20 @@ package Casing is
-- Case Control Subprograms --
------------------------------
+ procedure Set_Casing
+ (Buf : in out Bounded_String;
+ C : Casing_Type;
+ D : Casing_Type := Mixed_Case);
+ -- Takes the name stored in Buf and modifies it to be consistent with the
+ -- casing given by C, or if C = Unknown, then with the casing given by
+ -- D. The name is basically treated as an identifier, except that special
+ -- separator characters other than underline are permitted and treated like
+ -- underlines (this handles cases like minus and period in unit names,
+ -- apostrophes in error messages, angle brackets in names like <any_type>,
+ -- etc).
+
procedure Set_Casing (C : Casing_Type; D : Casing_Type := Mixed_Case);
- -- Takes the name stored in the first Name_Len positions of Name_Buffer
- -- and modifies it to be consistent with the casing given by C, or if
- -- C = Unknown, then with the casing given by D. The name is basically
- -- treated as an identifier, except that special separator characters
- -- other than underline are permitted and treated like underlines (this
- -- handles cases like minus and period in unit names, apostrophes in error
- -- messages, angle brackets in names like <any_type>, etc).
+ -- Uses Buf => Global_Name_Buffer
procedure Set_All_Upper_Case;
pragma Inline (Set_All_Upper_Case);
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index a3ea4770c6..f0ba9a8ad9 100644
--- a/gcc/ada/checks.adb
+++ b/gcc/ada/checks.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -337,6 +337,10 @@ package body Checks is
-- Like Apply_Selected_Length_Checks, except it doesn't modify
-- anything, just returns a list of nodes as described in the spec of
-- this package for the Range_Check function.
+ -- ??? In fact it does construct the test and insert it into the tree,
+ -- and insert actions in various ways (calling Insert_Action directly
+ -- in particular) so we do not call it in GNATprove mode, contrary to
+ -- Selected_Range_Checks.
function Selected_Range_Checks
(Ck_Node : Node_Id;
@@ -635,41 +639,15 @@ package body Checks is
procedure Apply_Address_Clause_Check (E : Entity_Id; N : Node_Id) is
pragma Assert (Nkind (N) = N_Freeze_Entity);
- AC : constant Node_Id := Address_Clause (E);
- Loc : constant Source_Ptr := Sloc (AC);
- Typ : constant Entity_Id := Etype (E);
- Aexp : constant Node_Id := Expression (AC);
+ AC : constant Node_Id := Address_Clause (E);
+ Loc : constant Source_Ptr := Sloc (AC);
+ Typ : constant Entity_Id := Etype (E);
Expr : Node_Id;
-- Address expression (not necessarily the same as Aexp, for example
-- when Aexp is a reference to a constant, in which case Expr gets
-- reset to reference the value expression of the constant).
- procedure Compile_Time_Bad_Alignment;
- -- Post error warnings when alignment is known to be incompatible. Note
- -- that we do not go as far as inserting a raise of Program_Error since
- -- this is an erroneous case, and it may happen that we are lucky and an
- -- underaligned address turns out to be OK after all.
-
- --------------------------------
- -- Compile_Time_Bad_Alignment --
- --------------------------------
-
- procedure Compile_Time_Bad_Alignment is
- begin
- if Address_Clause_Overlay_Warnings then
- Error_Msg_FE
- ("?o?specified address for& may be inconsistent with alignment",
- Aexp, E);
- Error_Msg_FE
- ("\?o?program execution may be erroneous (RM 13.3(27))",
- Aexp, E);
- Set_Address_Warning_Posted (AC);
- end if;
- end Compile_Time_Bad_Alignment;
-
- -- Start of processing for Apply_Address_Clause_Check
-
begin
-- See if alignment check needed. Note that we never need a check if the
-- maximum alignment is one, since the check will always succeed.
@@ -690,43 +668,11 @@ package body Checks is
-- Obtain expression from address clause
- Expr := Expression (AC);
-
- -- The following loop digs for the real expression to use in the check
-
- loop
- -- For constant, get constant expression
-
- if Is_Entity_Name (Expr)
- and then Ekind (Entity (Expr)) = E_Constant
- then
- Expr := Constant_Value (Entity (Expr));
+ Expr := Address_Value (Expression (AC));
- -- For unchecked conversion, get result to convert
-
- elsif Nkind (Expr) = N_Unchecked_Type_Conversion then
- Expr := Expression (Expr);
-
- -- For (common case) of To_Address call, get argument
-
- elsif Nkind (Expr) = N_Function_Call
- and then Is_Entity_Name (Name (Expr))
- and then Is_RTE (Entity (Name (Expr)), RE_To_Address)
- then
- Expr := First (Parameter_Associations (Expr));
-
- if Nkind (Expr) = N_Parameter_Association then
- Expr := Explicit_Actual_Parameter (Expr);
- end if;
-
- -- We finally have the real expression
-
- else
- exit;
- end if;
- end loop;
-
- -- See if we know that Expr has a bad alignment at compile time
+ -- See if we know that Expr has an acceptable value at compile time. If
+ -- it hasn't or we don't know, we defer issuing the warning until the
+ -- end of the compilation to take into account back end annotations.
if Compile_Time_Known_Value (Expr)
and then (Known_Alignment (E) or else Known_Alignment (Typ))
@@ -735,16 +681,14 @@ package body Checks is
AL : Uint := Alignment (Typ);
begin
- -- The object alignment might be more restrictive than the
- -- type alignment.
+ -- The object alignment might be more restrictive than the type
+ -- alignment.
if Known_Alignment (E) then
AL := Alignment (E);
end if;
- if Expr_Value (Expr) mod AL /= 0 then
- Compile_Time_Bad_Alignment;
- else
+ if Expr_Value (Expr) mod AL = 0 then
return;
end if;
end;
@@ -776,9 +720,9 @@ package body Checks is
-- Generate a check to raise PE if alignment may be inappropriate
else
- -- If the original expression is a non-static constant, use the
- -- name of the constant itself rather than duplicating its
- -- defining expression, which was extracted above.
+ -- If the original expression is a non-static constant, use the name
+ -- of the constant itself rather than duplicating its initialization
+ -- expression, which was extracted above.
-- Note: Expr is empty if the address-clause is applied to in-mode
-- actuals (allowed by 13.1(22)).
@@ -787,8 +731,8 @@ package body Checks is
or else
(Is_Entity_Name (Expression (AC))
and then Ekind (Entity (Expression (AC))) = E_Constant
- and then Nkind (Parent (Entity (Expression (AC))))
- = N_Object_Declaration)
+ and then Nkind (Parent (Entity (Expression (AC)))) =
+ N_Object_Declaration)
then
Expr := New_Copy_Tree (Expression (AC));
else
@@ -803,9 +747,9 @@ package body Checks is
Make_Raise_Program_Error (Loc,
Condition =>
Make_Op_Ne (Loc,
- Left_Opnd =>
+ Left_Opnd =>
Make_Op_Mod (Loc,
- Left_Opnd =>
+ Left_Opnd =>
Unchecked_Convert_To
(RTE (RE_Integer_Address), Expr),
Right_Opnd =>
@@ -813,12 +757,12 @@ package body Checks is
Prefix => New_Occurrence_Of (E, Loc),
Attribute_Name => Name_Alignment)),
Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
- Reason => PE_Misaligned_Address_Value));
+ Reason => PE_Misaligned_Address_Value));
Warning_Msg := No_Error_Msg;
Analyze (First (Actions (N)), Suppress => All_Checks);
- -- If the address clause generated a warning message (for example,
+ -- If the above raise action generated a warning message (for example
-- from Warn_On_Non_Local_Exception mode with the active restriction
-- No_Exception_Propagation).
@@ -832,19 +776,21 @@ package body Checks is
if Compile_Time_Known_Value (Expr) then
Alignment_Warnings.Append
((E => E, A => Expr_Value (Expr), W => Warning_Msg));
- end if;
- -- Add explanation of the warning that is generated by the check
+ -- Add explanation of the warning generated by the check
- Error_Msg_N
- ("\address value may be incompatible with alignment "
- & "of object?X?", AC);
+ else
+ Error_Msg_N
+ ("\address value may be incompatible with alignment of "
+ & "object?X?", AC);
+ end if;
end if;
return;
end if;
exception
+
-- If we have some missing run time component in configurable run time
-- mode then just skip the check (it is not required in any case).
@@ -880,10 +826,10 @@ package body Checks is
-- Apply_Arithmetic_Overflow_Strict --
--------------------------------------
- -- This routine is called only if the type is an integer type, and a
- -- software arithmetic overflow check may be needed for op (add, subtract,
- -- or multiply). This check is performed only if Software_Overflow_Checking
- -- is enabled and Do_Overflow_Check is set. In this case we expand the
+ -- This routine is called only if the type is an integer type and an
+ -- arithmetic overflow check may be needed for op (add, subtract, or
+ -- multiply). This check is performed if Backend_Overflow_Checks_On_Target
+ -- is not enabled and Do_Overflow_Check is set. In this case we expand the
-- operation into a more complex sequence of tests that ensures that
-- overflow is properly caught.
@@ -1505,13 +1451,17 @@ package body Checks is
T_Typ := Typ;
end if;
- -- Nothing to do if discriminant checks are suppressed or else no code
- -- is to be generated
+ -- Only apply checks when generating code and discriminant checks are
+ -- not suppressed. In GNATprove mode, we do not apply the checks, but we
+ -- still analyze the expression to possibly issue errors on SPARK code
+ -- when a run-time error can be detected at compile time.
- if not Expander_Active
- or else Discriminant_Checks_Suppressed (T_Typ)
- then
- return;
+ if not GNATprove_Mode then
+ if not Expander_Active
+ or else Discriminant_Checks_Suppressed (T_Typ)
+ then
+ return;
+ end if;
end if;
-- No discriminant checks necessary for an access when expression is
@@ -1748,6 +1698,12 @@ package body Checks is
end;
end if;
+ -- In GNATprove mode, we do not apply the checks
+
+ if GNATprove_Mode then
+ return;
+ end if;
+
-- Here we need a discriminant check. First build the expression
-- for the comparisons of the discriminants:
@@ -2354,11 +2310,13 @@ package body Checks is
-- Local variables
- Actual_1 : Node_Id;
- Actual_2 : Node_Id;
- Check : Node_Id;
- Formal_1 : Entity_Id;
- Formal_2 : Entity_Id;
+ Actual_1 : Node_Id;
+ Actual_2 : Node_Id;
+ Check : Node_Id;
+ Formal_1 : Entity_Id;
+ Formal_2 : Entity_Id;
+ Orig_Act_1 : Node_Id;
+ Orig_Act_2 : Node_Id;
-- Start of processing for Apply_Parameter_Aliasing_Checks
@@ -2368,37 +2326,43 @@ package body Checks is
Actual_1 := First_Actual (Call);
Formal_1 := First_Formal (Subp);
while Present (Actual_1) and then Present (Formal_1) loop
+ Orig_Act_1 := Original_Actual (Actual_1);
-- Ensure that the actual is an object that is not passed by value.
-- Elementary types are always passed by value, therefore actuals of
-- such types cannot lead to aliasing. An aggregate is an object in
-- Ada 2012, but an actual that is an aggregate cannot overlap with
- -- another actual.
-
- if Nkind (Original_Actual (Actual_1)) = N_Aggregate
- or else
- (Nkind (Original_Actual (Actual_1)) = N_Qualified_Expression
- and then Nkind (Expression (Original_Actual (Actual_1))) =
- N_Aggregate)
+ -- another actual. A type that is By_Reference (such as an array of
+ -- controlled types) is not subject to the check because any update
+ -- will be done in place and a subsequent read will always see the
+ -- correct value, see RM 6.2 (12/3).
+
+ if Nkind (Orig_Act_1) = N_Aggregate
+ or else (Nkind (Orig_Act_1) = N_Qualified_Expression
+ and then Nkind (Expression (Orig_Act_1)) = N_Aggregate)
then
null;
- elsif Is_Object_Reference (Original_Actual (Actual_1))
- and then not Is_Elementary_Type (Etype (Original_Actual (Actual_1)))
+ elsif Is_Object_Reference (Orig_Act_1)
+ and then not Is_Elementary_Type (Etype (Orig_Act_1))
+ and then not Is_By_Reference_Type (Etype (Orig_Act_1))
then
Actual_2 := Next_Actual (Actual_1);
Formal_2 := Next_Formal (Formal_1);
while Present (Actual_2) and then Present (Formal_2) loop
+ Orig_Act_2 := Original_Actual (Actual_2);
-- The other actual we are testing against must also denote
-- a non pass-by-value object. Generate the check only when
-- the mode of the two formals may lead to aliasing.
- if Is_Object_Reference (Original_Actual (Actual_2))
- and then not
- Is_Elementary_Type (Etype (Original_Actual (Actual_2)))
+ if Is_Object_Reference (Orig_Act_2)
+ and then not Is_Elementary_Type (Etype (Orig_Act_2))
and then May_Cause_Aliasing (Formal_1, Formal_2)
then
+ Remove_Side_Effects (Actual_1);
+ Remove_Side_Effects (Actual_2);
+
Overlap_Check
(Actual_1 => Actual_1,
Actual_2 => Actual_2,
@@ -2465,8 +2429,7 @@ package body Checks is
begin
Prag :=
Make_Pragma (Loc,
- Pragma_Identifier =>
- Make_Identifier (Loc, Prag_Nam),
+ Chars => Prag_Nam,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Chars => Name_Check,
@@ -2658,12 +2621,21 @@ package body Checks is
-- Apply_Predicate_Check --
---------------------------
- procedure Apply_Predicate_Check (N : Node_Id; Typ : Entity_Id) is
+ procedure Apply_Predicate_Check
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Fun : Entity_Id := Empty)
+ is
S : Entity_Id;
begin
- if Present (Predicate_Function (Typ)) then
+ if Predicate_Checks_Suppressed (Empty) then
+ return;
+ elsif Predicates_Ignored (Typ) then
+ return;
+
+ elsif Present (Predicate_Function (Typ)) then
S := Current_Scope;
while Present (S) and then not Is_Subprogram (S) loop
S := Scope (S);
@@ -2681,11 +2653,18 @@ package body Checks is
-- is likely to be a common error, and thus deserves a warning.
elsif Present (S) and then S = Predicate_Function (Typ) then
- Error_Msg_N
- ("predicate check includes a function call that "
- & "requires a predicate check??", Parent (N));
+ Error_Msg_NE
+ ("predicate check includes a call to& that requires a "
+ & "predicate check??", Parent (N), Fun);
Error_Msg_N
("\this will result in infinite recursion??", Parent (N));
+
+ if Is_First_Subtype (Typ) then
+ Error_Msg_NE
+ ("\use an explicit subtype of& to carry the predicate",
+ Parent (N), Typ);
+ end if;
+
Insert_Action (N,
Make_Raise_Storage_Error (Sloc (N),
Reason => SE_Infinite_Recursion));
@@ -2698,8 +2677,31 @@ package body Checks is
Check_Expression_Against_Static_Predicate (N, Typ);
- Insert_Action (N,
- Make_Predicate_Check (Typ, Duplicate_Subexpr (N)));
+ if not Expander_Active then
+ return;
+ end if;
+
+ -- For an entity of the type, generate a call to the predicate
+ -- function, unless its type is an actual subtype, which is not
+ -- visible outside of the enclosing subprogram.
+
+ if Is_Entity_Name (N)
+ and then not Is_Actual_Subtype (Typ)
+ then
+ Insert_Action (N,
+ Make_Predicate_Check
+ (Typ, New_Occurrence_Of (Entity (N), Sloc (N))));
+
+ -- If the expression is not an entity it may have side effects,
+ -- and the following call will create an object declaration for
+ -- it. We disable checks during its analysis, to prevent an
+ -- infinite recursion.
+
+ else
+ Insert_Action (N,
+ Make_Predicate_Check
+ (Typ, Duplicate_Subexpr (N)), Suppress => All_Checks);
+ end if;
end if;
end if;
end Apply_Predicate_Check;
@@ -2749,19 +2751,22 @@ package body Checks is
-- Set to True if Expr should be regarded as a real value even though
-- the type of Expr might be discrete.
- procedure Bad_Value;
- -- Procedure called if value is determined to be out of range
+ procedure Bad_Value (Warn : Boolean := False);
+ -- Procedure called if value is determined to be out of range. Warn is
+ -- True to force a warning instead of an error, even when SPARK_Mode is
+ -- On.
---------------
-- Bad_Value --
---------------
- procedure Bad_Value is
+ procedure Bad_Value (Warn : Boolean := False) is
begin
Apply_Compile_Time_Constraint_Error
(Expr, "value not in range of}??", CE_Range_Check_Failed,
- Ent => Target_Typ,
- Typ => Target_Typ);
+ Ent => Target_Typ,
+ Typ => Target_Typ,
+ Warn => Warn);
end Bad_Value;
-- Start of processing for Apply_Scalar_Range_Check
@@ -2968,18 +2973,17 @@ package body Checks is
if Lov > Hiv then
- -- In GNATprove mode, do not issue a message in that case
- -- (which would be an error stopping analysis), as this
- -- likely corresponds to deactivated code based on a
- -- given configuration (say, dead code inside a loop over
- -- the empty range). Instead, we enable the range check
- -- so that GNATprove will issue a message if it cannot be
- -- proved.
+ -- When SPARK_Mode is On, force a warning instead of
+ -- an error in that case, as this likely corresponds
+ -- to deactivated code.
+
+ Bad_Value (Warn => SPARK_Mode = On);
+
+ -- In GNATprove mode, we enable the range check so that
+ -- GNATprove will issue a message if it cannot be proved.
if GNATprove_Mode then
Enable_Range_Check (Expr);
- else
- Bad_Value;
end if;
return;
@@ -3052,15 +3056,11 @@ package body Checks is
-- Floating-point case
-- In the floating-point case, we only do range checks if the type is
-- constrained. We definitely do NOT want range checks for unconstrained
- -- types, since we want to have infinities
+ -- types, since we want to have infinities, except when
+ -- Check_Float_Overflow is set.
elsif Is_Floating_Point_Type (S_Typ) then
-
- -- Normally, we only do range checks if the type is constrained. We do
- -- NOT want range checks for unconstrained types, since we want to have
- -- infinities.
-
- if Is_Constrained (S_Typ) then
+ if Is_Constrained (S_Typ) or else Check_Float_Overflow then
Enable_Range_Check (Expr);
end if;
@@ -3092,8 +3092,10 @@ package body Checks is
or else (not Length_Checks_Suppressed (Target_Typ));
begin
+ -- Only apply checks when generating code
+
-- Note: this means that we lose some useful warnings if the expander
- -- is not active, and we also lose these warnings in SPARK mode ???
+ -- is not active.
if not Expander_Active then
return;
@@ -3203,13 +3205,24 @@ package body Checks is
R_Result : Check_Result;
begin
- if not Expander_Active or not Checks_On then
- return;
+ -- Only apply checks when generating code. In GNATprove mode, we do not
+ -- apply the checks, but we still call Selected_Range_Checks to possibly
+ -- issue errors on SPARK code when a run-time error can be detected at
+ -- compile time.
+
+ if not GNATprove_Mode then
+ if not Expander_Active or not Checks_On then
+ return;
+ end if;
end if;
R_Result :=
Selected_Range_Checks (Ck_Node, Target_Typ, Source_Typ, Empty);
+ if GNATprove_Mode then
+ return;
+ end if;
+
for J in 1 .. 2 loop
R_Cno := R_Result (J);
exit when No (R_Cno);
@@ -3270,9 +3283,7 @@ package body Checks is
-- on, then we want to delete the check, since it is not needed.
-- We do this by replacing the if statement by a null statement
- -- Why are we even generating checks if checks are turned off ???
-
- elsif Do_Static or else not Checks_On then
+ elsif Do_Static then
Remove_Warning_Messages (R_Cno);
Rewrite (R_Cno, Make_Null_Statement (Loc));
end if;
@@ -3382,7 +3393,57 @@ package body Checks is
In_Subrange_Of (Expr_Type, Target_Base, Fixed_Int => Conv_OK)
and then not Float_To_Int
then
- Activate_Overflow_Check (N);
+ -- A small optimization: the attribute 'Pos applied to an
+ -- enumeration type has a known range, even though its type is
+ -- Universal_Integer. So in numeric conversions it is usually
+ -- within range of the target integer type. Use the static
+ -- bounds of the base types to check. Disable this optimization
+ -- in case of a generic formal discrete type, because we don't
+ -- necessarily know the upper bound yet.
+
+ if Nkind (Expr) = N_Attribute_Reference
+ and then Attribute_Name (Expr) = Name_Pos
+ and then Is_Enumeration_Type (Etype (Prefix (Expr)))
+ and then not Is_Generic_Type (Etype (Prefix (Expr)))
+ and then Is_Integer_Type (Target_Type)
+ then
+ declare
+ Enum_T : constant Entity_Id :=
+ Root_Type (Etype (Prefix (Expr)));
+ Int_T : constant Entity_Id := Base_Type (Target_Type);
+ Last_I : constant Uint :=
+ Intval (High_Bound (Scalar_Range (Int_T)));
+ Last_E : Uint;
+
+ begin
+ -- Character types have no explicit literals, so we use
+ -- the known number of characters in the type.
+
+ if Root_Type (Enum_T) = Standard_Character then
+ Last_E := UI_From_Int (255);
+
+ elsif Enum_T = Standard_Wide_Character
+ or else Enum_T = Standard_Wide_Wide_Character
+ then
+ Last_E := UI_From_Int (65535);
+
+ else
+ Last_E :=
+ Enumeration_Pos
+ (Entity (High_Bound (Scalar_Range (Enum_T))));
+ end if;
+
+ if Last_E <= Last_I then
+ null;
+
+ else
+ Activate_Overflow_Check (N);
+ end if;
+ end;
+
+ else
+ Activate_Overflow_Check (N);
+ end if;
end if;
if not Range_Checks_Suppressed (Target_Type)
@@ -4033,26 +4094,30 @@ package body Checks is
if Present (Expr) and then Known_Null (Expr) then
case K is
- when N_Component_Declaration |
- N_Discriminant_Specification =>
+ when N_Component_Declaration
+ | N_Discriminant_Specification
+ =>
Apply_Compile_Time_Constraint_Error
(N => Expr,
- Msg => "(Ada 2005) null not allowed "
- & "in null-excluding components??",
+ Msg =>
+ "(Ada 2005) null not allowed in null-excluding "
+ & "components??",
Reason => CE_Null_Not_Allowed);
when N_Object_Declaration =>
Apply_Compile_Time_Constraint_Error
(N => Expr,
- Msg => "(Ada 2005) null not allowed "
- & "in null-excluding objects??",
+ Msg =>
+ "(Ada 2005) null not allowed in null-excluding "
+ & "objects??",
Reason => CE_Null_Not_Allowed);
when N_Parameter_Specification =>
Apply_Compile_Time_Constraint_Error
(N => Expr,
- Msg => "(Ada 2005) null not allowed "
- & "in null-excluding formals??",
+ Msg =>
+ "(Ada 2005) null not allowed in null-excluding "
+ & "formals??",
Reason => CE_Null_Not_Allowed);
when others =>
@@ -4491,9 +4556,7 @@ package body Checks is
when N_Op_Rem =>
if OK_Operands then
- if Lo_Right = Hi_Right
- and then Lo_Right /= 0
- then
+ if Lo_Right = Hi_Right and then Lo_Right /= 0 then
declare
Dval : constant Uint := (abs Lo_Right) - 1;
@@ -4528,7 +4591,9 @@ package body Checks is
-- For Pos/Val attributes, we can refine the range using the
-- possible range of values of the attribute expression.
- when Name_Pos | Name_Val =>
+ when Name_Pos
+ | Name_Val
+ =>
Determine_Range
(First (Expressions (N)), OK1, Lor, Hir, Assume_Valid);
@@ -5727,6 +5792,14 @@ package body Checks is
elsif Expr_Known_Valid (Expr) then
return;
+ -- No check needed within a generated predicate function. Validity
+ -- of input value will have been checked earlier.
+
+ elsif Ekind (Current_Scope) = E_Function
+ and then Is_Predicate_Function (Current_Scope)
+ then
+ return;
+
-- Ignore case of enumeration with holes where the flag is set not to
-- worry about holes, since no special validity check is needed
@@ -6170,8 +6243,8 @@ package body Checks is
-- twice (once for the check, once for the actual reference). Such a
-- double evaluation is always a potential source of inefficiency, and
-- is functionally incorrect in the volatile case, or when the prefix
- -- may have side-effects. A non-volatile entity or a component of a
- -- non-volatile entity requires no evaluation.
+ -- may have side effects. A nonvolatile entity or a component of a
+ -- nonvolatile entity requires no evaluation.
if Is_Entity_Name (Pref) then
if Treat_As_Volatile (Entity (Pref)) then
@@ -6393,7 +6466,7 @@ package body Checks is
Set_Do_Range_Check (Sub, False);
-- Force evaluation except for the case of a simple name of
- -- a non-volatile entity.
+ -- a nonvolatile entity.
if not Is_Entity_Name (Sub)
or else Treat_As_Volatile (Entity (Sub))
@@ -7136,12 +7209,18 @@ package body Checks is
Force_Evaluation (Exp, Name_Req => False);
end if;
- -- Build the prefix for the 'Valid call
+ -- Build the prefix for the 'Valid call. If the expression denotes
+ -- a name, use a renaming to alias it, otherwise use a constant to
+ -- capture the value of the expression.
+
+ -- Temp : ... renames Expr; -- reference to a name
+ -- Temp : constant ... := Expr; -- all other cases
PV :=
Duplicate_Subexpr_No_Checks
(Exp => Exp,
Name_Req => False,
+ Renaming_Req => Is_Name_Reference (Exp),
Related_Id => Related_Id,
Is_Low_Bound => Is_Low_Bound,
Is_High_Bound => Is_High_Bound);
@@ -7230,12 +7309,22 @@ package body Checks is
function Is_Signed_Integer_Arithmetic_Op (N : Node_Id) return Boolean is
begin
case Nkind (N) is
- when N_Op_Abs | N_Op_Add | N_Op_Divide | N_Op_Expon |
- N_Op_Minus | N_Op_Mod | N_Op_Multiply | N_Op_Plus |
- N_Op_Rem | N_Op_Subtract =>
+ when N_Op_Abs
+ | N_Op_Add
+ | N_Op_Divide
+ | N_Op_Expon
+ | N_Op_Minus
+ | N_Op_Mod
+ | N_Op_Multiply
+ | N_Op_Plus
+ | N_Op_Rem
+ | N_Op_Subtract
+ =>
return Is_Signed_Integer_Type (Etype (N));
- when N_If_Expression | N_Case_Expression =>
+ when N_Case_Expression
+ | N_If_Expression
+ =>
return Is_Signed_Integer_Type (Etype (N));
when others =>
@@ -8452,28 +8541,28 @@ package body Checks is
begin
case Nkind (N) is
- when N_Op_Abs =>
+ when N_Op_Abs =>
Fent := RTE (RE_Big_Abs);
- when N_Op_Add =>
+ when N_Op_Add =>
Fent := RTE (RE_Big_Add);
- when N_Op_Divide =>
+ when N_Op_Divide =>
Fent := RTE (RE_Big_Div);
- when N_Op_Expon =>
+ when N_Op_Expon =>
Fent := RTE (RE_Big_Exp);
- when N_Op_Minus =>
+ when N_Op_Minus =>
Fent := RTE (RE_Big_Neg);
- when N_Op_Mod =>
+ when N_Op_Mod =>
Fent := RTE (RE_Big_Mod);
when N_Op_Multiply =>
Fent := RTE (RE_Big_Mul);
- when N_Op_Rem =>
+ when N_Op_Rem =>
Fent := RTE (RE_Big_Rem);
when N_Op_Subtract =>
@@ -9063,6 +9152,8 @@ package body Checks is
-- Start of processing for Selected_Length_Checks
begin
+ -- Checks will be applied only when generating code
+
if not Expander_Active then
return Ret_Result;
end if;
@@ -9613,7 +9704,12 @@ package body Checks is
-- Start of processing for Selected_Range_Checks
begin
- if not Expander_Active then
+ -- Checks will be applied only when generating code. In GNATprove mode,
+ -- we do not apply the checks, but we still call Selected_Range_Checks
+ -- to possibly issue errors on SPARK code when a run-time error can be
+ -- detected at compile time.
+
+ if not Expander_Active and not GNATprove_Mode then
return Ret_Result;
end if;
@@ -9677,8 +9773,8 @@ package body Checks is
LB : Node_Id := Low_Bound (Ck_Node);
HB : Node_Id := High_Bound (Ck_Node);
- Known_LB : Boolean;
- Known_HB : Boolean;
+ Known_LB : Boolean := False;
+ Known_HB : Boolean := False;
Null_Range : Boolean;
Out_Of_Range_L : Boolean;
@@ -9700,9 +9796,6 @@ package body Checks is
then
LB := T_LB;
Known_LB := True;
-
- else
- Known_LB := False;
end if;
-- Likewise for the high bound
@@ -9715,8 +9808,6 @@ package body Checks is
then
HB := T_HB;
Known_HB := True;
- else
- Known_HB := False;
end if;
end if;
diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads
index 9883c830bf..ff513e667b 100644
--- a/gcc/ada/checks.ads
+++ b/gcc/ada/checks.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -255,9 +255,14 @@ package Checks is
-- verify the proper initialization of scalars in parameters and function
-- results.
- procedure Apply_Predicate_Check (N : Node_Id; Typ : Entity_Id);
- -- N is an expression to which a predicate check may need to be applied
- -- for Typ, if Typ has a predicate function.
+ procedure Apply_Predicate_Check
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Fun : Entity_Id := Empty);
+ -- N is an expression to which a predicate check may need to be applied for
+ -- Typ, if Typ has a predicate function. When N is an actual in a call, Fun
+ -- is the function being called, which is used to generate a better warning
+ -- if the call leads to an infinite recursion.
procedure Apply_Type_Conversion_Checks (N : Node_Id);
-- N is an N_Type_Conversion node. A type conversion actually involves
@@ -949,7 +954,7 @@ private
--
-- For the static case the result is one or two nodes that should cause
-- a Constraint_Error. Typically these will include Expr itself or the
- -- direct descendents of Expr, such as Low/High_Bound (Expr)). It is the
+ -- direct descendants of Expr, such as Low/High_Bound (Expr)). It is the
-- responsibility of the caller to rewrite and substitute the nodes with
-- N_Raise_Constraint_Error nodes.
--
diff --git a/gcc/ada/clean.adb b/gcc/ada/clean.adb
index 805f65393a..615cc48c59 100644
--- a/gcc/ada/clean.adb
+++ b/gcc/ada/clean.adb
@@ -1387,8 +1387,8 @@ package body Clean is
if Project_File_Name /= null then
Put_Line
- ("warning: gnatclean -P is obsolete and will not be available "
- & "in the next release; use gprclean instead.");
+ ("warning: gnatclean -P is obsolete and will not be available" &
+ " in the next release; use gprclean instead.");
end if;
-- A project file was specified by a -P switch
@@ -1619,8 +1619,8 @@ package body Clean is
procedure Parse_Cmd_Line is
Last : constant Natural := Argument_Count;
- Source_Index : Int := 0;
Index : Positive;
+ Source_Index : Int := 0;
procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
@@ -1629,16 +1629,29 @@ package body Clean is
Check_Version_And_Help ("GNATCLEAN", "2003");
- -- First, for native gnatclean, check for switch -P and, if found and
- -- gprclean is available, silently invoke gprclean.
+ -- First, check for switch -P and, if found and gprclean is available,
+ -- silently invoke gprclean, with switch --target if not on a native
+ -- platform.
- Find_Program_Name;
+ declare
+ Arg_Len : Positive := Argument_Count;
+ Call_Gprclean : Boolean := False;
+ Gprclean : String_Access := null;
+ Pos : Natural := 0;
+ Success : Boolean;
+ Target : String_Access := null;
- if Name_Buffer (1 .. Name_Len) = "gnatclean" then
- declare
- Call_Gprclean : Boolean := False;
+ begin
+ Find_Program_Name;
+
+ if Name_Len >= 9
+ and then Name_Buffer (Name_Len - 8 .. Name_Len) = "gnatclean"
+ then
+ if Name_Len > 9 then
+ Target := new String'(Name_Buffer (1 .. Name_Len - 10));
+ Arg_Len := Arg_Len + 1;
+ end if;
- begin
for J in 1 .. Argument_Count loop
declare
Arg : constant String := Argument (J);
@@ -1653,16 +1666,20 @@ package body Clean is
end loop;
if Call_Gprclean then
- declare
- Gprclean : String_Access :=
- Locate_Exec_On_Path (Exec_Name => "gprclean");
- Args : Argument_List (1 .. Argument_Count);
- Success : Boolean;
+ Gprclean := Locate_Exec_On_Path (Exec_Name => "gprclean");
+
+ if Gprclean /= null then
+ declare
+ Args : Argument_List (1 .. Arg_Len);
+ begin
+ if Target /= null then
+ Args (1) := new String'("--target=" & Target.all);
+ Pos := 1;
+ end if;
- begin
- if Gprclean /= null then
for J in 1 .. Argument_Count loop
- Args (J) := new String'(Argument (J));
+ Pos := Pos + 1;
+ Args (Pos) := new String'(Argument (J));
end loop;
Spawn (Gprclean.all, Args, Success);
@@ -1672,11 +1689,11 @@ package body Clean is
if Success then
Exit_Program (E_Success);
end if;
- end if;
- end;
+ end;
+ end if;
end if;
- end;
- end if;
+ end if;
+ end;
Index := 1;
while Index <= Last loop
diff --git a/gcc/ada/comperr.adb b/gcc/ada/comperr.adb
index f32db3267b..0403524183 100644
--- a/gcc/ada/comperr.adb
+++ b/gcc/ada/comperr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -294,7 +294,7 @@ package body Comperr is
if Is_FSF_Version then
Write_Str
("| Please submit a bug report; see" &
- " http://gcc.gnu.org/bugs.html.");
+ " https://gcc.gnu.org/bugs/ .");
End_Line;
elsif Is_GPL_Version then
@@ -467,7 +467,10 @@ package body Comperr is
Main := Unit (Cunit (Main_Unit));
case Nkind (Main) is
- when N_Subprogram_Body | N_Package_Declaration =>
+ when N_Package_Declaration
+ | N_Subprogram_Body
+ | N_Subprogram_Declaration
+ =>
Unit_Name := Defining_Unit_Name (Specification (Main));
when N_Package_Body =>
diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb
index ebaecc0951..d467c942e1 100644
--- a/gcc/ada/contracts.adb
+++ b/gcc/ada/contracts.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2015-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -25,6 +25,7 @@
with Aspects; use Aspects;
with Atree; use Atree;
+with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
@@ -40,12 +41,14 @@ with Sem_Aux; use Sem_Aux;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch12; use Sem_Ch12;
+with Sem_Ch13; use Sem_Ch13;
with Sem_Disp; use Sem_Disp;
with Sem_Prag; use Sem_Prag;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stringt; use Stringt;
+with SCIL_LL; use SCIL_LL;
with Tbuild; use Tbuild;
package body Contracts is
@@ -60,6 +63,11 @@ package body Contracts is
-- is reached. Freeze_Id is the entity of some related context which caused
-- freezing up to node Freeze_Nod.
+ procedure Build_And_Analyze_Contract_Only_Subprograms (L : List_Id);
+ -- (CodePeer): Subsidiary procedure to Analyze_Contracts which builds the
+ -- contract-only subprogram body of eligible subprograms found in L, adds
+ -- them to their corresponding list of declarations, and analyzes them.
+
procedure Expand_Subprogram_Contract (Body_Id : Entity_Id);
-- Expand the contracts of a subprogram body and its correspoding spec (if
-- any). This routine processes all [refined] pre- and postconditions as
@@ -114,16 +122,14 @@ package body Contracts is
-- Local variables
- Prag_Nam : Name_Id;
-
- -- Start of processing for Add_Contract_Item
-
- begin
-- A contract must contain only pragmas
pragma Assert (Nkind (Prag) = N_Pragma);
- Prag_Nam := Pragma_Name (Prag);
+ Prag_Nam : constant Name_Id := Pragma_Name (Prag);
+
+ -- Start of processing for Add_Contract_Item
+ begin
-- Create a new contract when adding the first item
if No (Items) then
@@ -346,6 +352,10 @@ package body Contracts is
procedure Analyze_Contracts (L : List_Id) is
begin
+ if CodePeer_Mode and then Debug_Flag_Dot_KK then
+ Build_And_Analyze_Contract_Only_Subprograms (L);
+ end if;
+
Analyze_Contracts (L, Freeze_Nod => Empty, Freeze_Id => Empty);
end Analyze_Contracts;
@@ -390,7 +400,7 @@ package body Contracts is
(Obj_Id => Defining_Entity (Decl),
Freeze_Id => Freeze_Id);
- -- Protected untis
+ -- Protected units
elsif Nkind_In (Decl, N_Protected_Type_Declaration,
N_Single_Protected_Declaration)
@@ -408,6 +418,22 @@ package body Contracts is
N_Task_Type_Declaration)
then
Analyze_Task_Contract (Defining_Entity (Decl));
+
+ -- For type declarations, we need to do the pre-analysis of
+ -- Iterable aspect specifications.
+ -- Other type aspects need to be resolved here???
+
+ elsif Nkind (Decl) = N_Private_Type_Declaration
+ and then Present (Aspect_Specifications (Decl))
+ then
+ declare
+ E : constant Entity_Id := Defining_Identifier (Decl);
+ It : constant Node_Id := Find_Aspect (E, Aspect_Iterable);
+ begin
+ if Present (It) then
+ Validate_Iterable_Aspect (E, It);
+ end if;
+ end;
end if;
Next (Decl);
@@ -458,10 +484,13 @@ package body Contracts is
-- volatile formal parameter or return type (SPARK RM 7.1.3(9)). This
-- check is relevant only when SPARK_Mode is on, as it is not a standard
-- legality rule. The check is performed here because Volatile_Function
- -- is processed after the analysis of the related subprogram body.
+ -- is processed after the analysis of the related subprogram body. The
+ -- check only applies to source subprograms and not to generated TSS
+ -- subprograms.
if SPARK_Mode = On
and then Ekind_In (Body_Id, E_Function, E_Generic_Function)
+ and then Comes_From_Source (Spec_Id)
and then not Is_Volatile_Function (Body_Id)
then
Check_Nonvolatile_Function_Profile (Body_Id);
@@ -660,7 +689,6 @@ package body Contracts is
Obj_Typ : constant Entity_Id := Etype (Obj_Id);
AR_Val : Boolean := False;
AW_Val : Boolean := False;
- Encap_Id : Entity_Id;
ER_Val : Boolean := False;
EW_Val : Boolean := False;
Items : Node_Id;
@@ -872,28 +900,6 @@ package body Contracts is
Obj_Id);
end if;
end if;
-
- -- A variable whose Part_Of pragma specifies a single concurrent
- -- type as encapsulator must be (SPARK RM 9.4):
- -- * Of a type that defines full default initialization, or
- -- * Declared with a default value, or
- -- * Imported
-
- Encap_Id := Encapsulating_State (Obj_Id);
-
- if Present (Encap_Id)
- and then Is_Single_Concurrent_Object (Encap_Id)
- and then not Has_Full_Default_Initialization (Etype (Obj_Id))
- and then not Has_Initial_Value (Obj_Id)
- and then not Is_Imported (Obj_Id)
- then
- Error_Msg_N ("& requires full default initialization", Obj_Id);
-
- Error_Msg_Name_1 := Chars (Encap_Id);
- Error_Msg_N
- (Fix_Msg (Encap_Id, "\object acts as constituent of single "
- & "protected type %"), Obj_Id);
- end if;
end if;
end if;
@@ -907,13 +913,13 @@ package body Contracts is
if Yields_Synchronized_Object (Obj_Typ) then
Error_Msg_N ("ghost object & cannot be synchronized", Obj_Id);
- -- A Ghost object cannot be effectively volatile (SPARK RM 6.9(8) and
+ -- A Ghost object cannot be effectively volatile (SPARK RM 6.9(7) and
-- SPARK RM 6.9(19)).
elsif Is_Effectively_Volatile (Obj_Id) then
Error_Msg_N ("ghost object & cannot be volatile", Obj_Id);
- -- A Ghost object cannot be imported or exported (SPARK RM 6.9(8)).
+ -- A Ghost object cannot be imported or exported (SPARK RM 6.9(7)).
-- One exception to this is the object that represents the dispatch
-- table of a Ghost tagged type, as the symbol needs to be exported.
@@ -972,15 +978,6 @@ package body Contracts is
if Present (Ref_State) then
Analyze_Refined_State_In_Decl_Part (Ref_State, Freeze_Id);
-
- -- State refinement is required when the package declaration defines at
- -- least one abstract state. Null states are not considered. Refinement
- -- is not enforced when SPARK checks are turned off.
-
- elsif SPARK_Mode /= Off
- and then Requires_State_Refinement (Spec_Id, Body_Id)
- then
- Error_Msg_N ("package & requires state refinement", Spec_Id);
end if;
-- Restore the SPARK_Mode of the enclosing context after all delayed
@@ -1091,8 +1088,10 @@ package body Contracts is
--------------------------------
procedure Analyze_Previous_Contracts (Body_Decl : Node_Id) is
- Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
- Par : Node_Id;
+ Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
+ Orig_Decl : constant Node_Id := Original_Node (Body_Decl);
+
+ Par : Node_Id;
begin
-- A body that is in the process of being inlined appears from source,
@@ -1115,6 +1114,29 @@ package body Contracts is
Freeze_Id => Defining_Entity (Body_Decl));
exit;
+
+ -- Do not look for an enclosing package body when the construct which
+ -- causes freezing is a body generated for an expression function and
+ -- it appears within a package spec. This ensures that the traversal
+ -- will not reach too far up the parent chain and attempt to freeze a
+ -- package body which should not be frozen.
+
+ -- package body Enclosing_Body
+ -- with Refined_State => (State => Var)
+ -- is
+ -- package Nested is
+ -- type Some_Type is ...;
+ -- function Cause_Freezing return ...;
+ -- private
+ -- function Cause_Freezing is (...);
+ -- end Nested;
+ --
+ -- Var : Nested.Some_Type;
+
+ elsif Nkind (Par) = N_Package_Declaration
+ and then Nkind (Orig_Decl) = N_Expression_Function
+ then
+ exit;
end if;
Par := Parent (Par);
@@ -1137,7 +1159,6 @@ package body Contracts is
procedure Analyze_Protected_Contract (Prot_Id : Entity_Id) is
Items : constant Node_Id := Contract (Prot_Id);
- Mode : SPARK_Mode_Type;
begin
-- Do not analyze a contract multiple times
@@ -1149,30 +1170,6 @@ package body Contracts is
Set_Analyzed (Items);
end if;
end if;
-
- -- Due to the timing of contract analysis, delayed pragmas may be
- -- subject to the wrong SPARK_Mode, usually that of the enclosing
- -- context. To remedy this, restore the original SPARK_Mode of the
- -- related protected unit.
-
- Save_SPARK_Mode_And_Set (Prot_Id, Mode);
-
- -- A protected type must define full default initialization
- -- (SPARK RM 9.4). This check is relevant only when SPARK_Mode is on as
- -- it is not a standard Ada legality rule.
-
- if SPARK_Mode = On
- and then not Has_Full_Default_Initialization (Prot_Id)
- then
- Error_Msg_N
- ("protected type & must define full default initialization",
- Prot_Id);
- end if;
-
- -- Restore the SPARK_Mode of the enclosing context after all delayed
- -- pragmas have been analyzed.
-
- Restore_SPARK_Mode (Mode);
end Analyze_Protected_Contract;
-------------------------------------------
@@ -1259,6 +1256,490 @@ package body Contracts is
Restore_SPARK_Mode (Mode);
end Analyze_Task_Contract;
+ -------------------------------------------------
+ -- Build_And_Analyze_Contract_Only_Subprograms --
+ -------------------------------------------------
+
+ procedure Build_And_Analyze_Contract_Only_Subprograms (L : List_Id) is
+ procedure Analyze_Contract_Only_Subprograms;
+ -- Analyze the contract-only subprograms of L
+
+ procedure Append_Contract_Only_Subprograms (Subp_List : List_Id);
+ -- Append the contract-only bodies of Subp_List to its declarations list
+
+ function Build_Contract_Only_Subprogram (E : Entity_Id) return Node_Id;
+ -- If E is an entity for a non-imported subprogram specification with
+ -- pre/postconditions and we are compiling with CodePeer mode, then
+ -- this procedure will create a wrapper to help Gnat2scil process its
+ -- contracts. Return Empty if the wrapper cannot be built.
+
+ function Build_Contract_Only_Subprograms (L : List_Id) return List_Id;
+ -- Build the contract-only subprograms of all eligible subprograms found
+ -- in list L.
+
+ function Has_Private_Declarations (N : Node_Id) return Boolean;
+ -- Return True for package specs, task definitions, and protected type
+ -- definitions whose list of private declarations is not empty.
+
+ ---------------------------------------
+ -- Analyze_Contract_Only_Subprograms --
+ ---------------------------------------
+
+ procedure Analyze_Contract_Only_Subprograms is
+ procedure Analyze_Contract_Only_Bodies;
+ -- Analyze all the contract-only bodies of L
+
+ ----------------------------------
+ -- Analyze_Contract_Only_Bodies --
+ ----------------------------------
+
+ procedure Analyze_Contract_Only_Bodies is
+ Decl : Node_Id;
+
+ begin
+ Decl := First (L);
+ while Present (Decl) loop
+ if Nkind (Decl) = N_Subprogram_Body
+ and then Is_Contract_Only_Body
+ (Defining_Unit_Name (Specification (Decl)))
+ then
+ Analyze (Decl);
+ end if;
+
+ Next (Decl);
+ end loop;
+ end Analyze_Contract_Only_Bodies;
+
+ -- Start of processing for Analyze_Contract_Only_Subprograms
+
+ begin
+ if Ekind (Current_Scope) /= E_Package then
+ Analyze_Contract_Only_Bodies;
+
+ else
+ declare
+ Pkg_Spec : constant Node_Id :=
+ Package_Specification (Current_Scope);
+
+ begin
+ if not Has_Private_Declarations (Pkg_Spec) then
+ Analyze_Contract_Only_Bodies;
+
+ -- For packages with private declarations, the contract-only
+ -- bodies of subprograms defined in the visible part of the
+ -- package are added to its private declarations (to ensure
+ -- that they do not cause premature freezing of types and also
+ -- that they are analyzed with proper visibility). Hence they
+ -- will be analyzed later.
+
+ elsif Visible_Declarations (Pkg_Spec) = L then
+ null;
+
+ elsif Private_Declarations (Pkg_Spec) = L then
+ Analyze_Contract_Only_Bodies;
+ end if;
+ end;
+ end if;
+ end Analyze_Contract_Only_Subprograms;
+
+ --------------------------------------
+ -- Append_Contract_Only_Subprograms --
+ --------------------------------------
+
+ procedure Append_Contract_Only_Subprograms (Subp_List : List_Id) is
+ begin
+ if No (Subp_List) then
+ return;
+ end if;
+
+ if Ekind (Current_Scope) /= E_Package then
+ Append_List (Subp_List, To => L);
+
+ else
+ declare
+ Pkg_Spec : constant Node_Id :=
+ Package_Specification (Current_Scope);
+
+ begin
+ if not Has_Private_Declarations (Pkg_Spec) then
+ Append_List (Subp_List, To => L);
+
+ -- If the package has private declarations then append them to
+ -- its private declarations; they will be analyzed when the
+ -- contracts of its private declarations are analyzed.
+
+ else
+ Append_List
+ (List => Subp_List,
+ To => Private_Declarations (Pkg_Spec));
+ end if;
+ end;
+ end if;
+ end Append_Contract_Only_Subprograms;
+
+ ------------------------------------
+ -- Build_Contract_Only_Subprogram --
+ ------------------------------------
+
+ -- This procedure takes care of building a wrapper to generate better
+ -- analysis results in the case of a call to a subprogram whose body
+ -- is unavailable to CodePeer but whose specification includes Pre/Post
+ -- conditions. The body might be unavailable for any of a number or
+ -- reasons (it is imported, the .adb file is simply missing, or the
+ -- subprogram might be subject to an Annotate (CodePeer, Skip_Analysis)
+ -- pragma). The built subprogram has the following contents:
+ -- * check preconditions
+ -- * call the subprogram
+ -- * check postconditions
+
+ function Build_Contract_Only_Subprogram (E : Entity_Id) return Node_Id is
+ Loc : constant Source_Ptr := Sloc (E);
+
+ Missing_Body_Name : constant Name_Id :=
+ New_External_Name (Chars (E), "__missing_body");
+
+ function Build_Missing_Body_Decls return List_Id;
+ -- Build the declaration of the missing body subprogram and its
+ -- corresponding pragma Import.
+
+ function Build_Missing_Body_Subprogram_Call return Node_Id;
+ -- Build the call to the missing body subprogram
+
+ function Skip_Contract_Only_Subprogram (E : Entity_Id) return Boolean;
+ -- Return True for cases where the wrapper is not needed or we cannot
+ -- build it.
+
+ ------------------------------
+ -- Build_Missing_Body_Decls --
+ ------------------------------
+
+ function Build_Missing_Body_Decls return List_Id is
+ Spec : constant Node_Id := Declaration_Node (E);
+ Decl : Node_Id;
+ Prag : Node_Id;
+
+ begin
+ Decl :=
+ Make_Subprogram_Declaration (Loc, Copy_Subprogram_Spec (Spec));
+ Set_Chars (Defining_Entity (Decl), Missing_Body_Name);
+
+ Prag :=
+ Make_Pragma (Loc,
+ Chars => Name_Import,
+ Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Loc,
+ Expression => Make_Identifier (Loc, Name_Ada)),
+
+ Make_Pragma_Argument_Association (Loc,
+ Expression => Make_Identifier (Loc, Missing_Body_Name))));
+
+ return New_List (Decl, Prag);
+ end Build_Missing_Body_Decls;
+
+ ----------------------------------------
+ -- Build_Missing_Body_Subprogram_Call --
+ ----------------------------------------
+
+ function Build_Missing_Body_Subprogram_Call return Node_Id is
+ Forml : Entity_Id;
+ Parms : List_Id;
+
+ begin
+ Parms := New_List;
+
+ -- Build parameter list that we need
+
+ Forml := First_Formal (E);
+ while Present (Forml) loop
+ Append_To (Parms, Make_Identifier (Loc, Chars (Forml)));
+ Next_Formal (Forml);
+ end loop;
+
+ -- Build the call to the missing body subprogram
+
+ if Ekind_In (E, E_Function, E_Generic_Function) then
+ return
+ Make_Simple_Return_Statement (Loc,
+ Expression =>
+ Make_Function_Call (Loc,
+ Name =>
+ Make_Identifier (Loc, Missing_Body_Name),
+ Parameter_Associations => Parms));
+
+ else
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ Make_Identifier (Loc, Missing_Body_Name),
+ Parameter_Associations => Parms);
+ end if;
+ end Build_Missing_Body_Subprogram_Call;
+
+ -----------------------------------
+ -- Skip_Contract_Only_Subprogram --
+ -----------------------------------
+
+ function Skip_Contract_Only_Subprogram
+ (E : Entity_Id) return Boolean
+ is
+ function Depends_On_Enclosing_Private_Type return Boolean;
+ -- Return True if some formal of E (or its return type) are
+ -- private types defined in an enclosing package.
+
+ function Some_Enclosing_Package_Has_Private_Decls return Boolean;
+ -- Return True if some enclosing package of the current scope has
+ -- private declarations.
+
+ ---------------------------------------
+ -- Depends_On_Enclosing_Private_Type --
+ ---------------------------------------
+
+ function Depends_On_Enclosing_Private_Type return Boolean is
+ function Defined_In_Enclosing_Package
+ (Typ : Entity_Id) return Boolean;
+ -- Return True if Typ is an entity defined in an enclosing
+ -- package of the current scope.
+
+ ----------------------------------
+ -- Defined_In_Enclosing_Package --
+ ----------------------------------
+
+ function Defined_In_Enclosing_Package
+ (Typ : Entity_Id) return Boolean
+ is
+ Scop : Entity_Id := Scope (Current_Scope);
+
+ begin
+ while Scop /= Scope (Typ)
+ and then not Is_Compilation_Unit (Scop)
+ loop
+ Scop := Scope (Scop);
+ end loop;
+
+ return Scop = Scope (Typ);
+ end Defined_In_Enclosing_Package;
+
+ -- Local variables
+
+ Param_E : Entity_Id;
+ Typ : Entity_Id;
+
+ -- Start of processing for Depends_On_Enclosing_Private_Type
+
+ begin
+ Param_E := First_Entity (E);
+ while Present (Param_E) loop
+ Typ := Etype (Param_E);
+
+ if Is_Private_Type (Typ)
+ and then Defined_In_Enclosing_Package (Typ)
+ then
+ return True;
+ end if;
+
+ Next_Entity (Param_E);
+ end loop;
+
+ return
+ Ekind (E) = E_Function
+ and then Is_Private_Type (Etype (E))
+ and then Defined_In_Enclosing_Package (Etype (E));
+ end Depends_On_Enclosing_Private_Type;
+
+ ----------------------------------------------
+ -- Some_Enclosing_Package_Has_Private_Decls --
+ ----------------------------------------------
+
+ function Some_Enclosing_Package_Has_Private_Decls return Boolean is
+ Scop : Entity_Id := Current_Scope;
+ Pkg_Spec : Node_Id := Package_Specification (Scop);
+
+ begin
+ loop
+ if Ekind (Scop) = E_Package
+ and then Has_Private_Declarations
+ (Package_Specification (Scop))
+ then
+ Pkg_Spec := Package_Specification (Scop);
+ end if;
+
+ exit when Is_Compilation_Unit (Scop);
+ Scop := Scope (Scop);
+ end loop;
+
+ return Pkg_Spec /= Package_Specification (Current_Scope);
+ end Some_Enclosing_Package_Has_Private_Decls;
+
+ -- Start of processing for Skip_Contract_Only_Subprogram
+
+ begin
+ if not CodePeer_Mode
+ or else Inside_A_Generic
+ or else not Is_Subprogram (E)
+ or else Is_Abstract_Subprogram (E)
+ or else Is_Imported (E)
+ or else No (Contract (E))
+ or else No (Pre_Post_Conditions (Contract (E)))
+ or else Is_Contract_Only_Body (E)
+ or else Convention (E) = Convention_Protected
+ then
+ return True;
+
+ -- We do not support building the contract-only subprogram if E
+ -- is a subprogram declared in a nested package that has some
+ -- formal or return type depending on a private type defined in
+ -- an enclosing package.
+
+ elsif Ekind (Current_Scope) = E_Package
+ and then Some_Enclosing_Package_Has_Private_Decls
+ and then Depends_On_Enclosing_Private_Type
+ then
+ if Debug_Flag_Dot_KK then
+ declare
+ Saved_Mode : constant Warning_Mode_Type := Warning_Mode;
+
+ begin
+ -- Warnings are disabled by default under CodePeer_Mode
+ -- (see switch-c). Enable them temporarily.
+
+ Warning_Mode := Normal;
+ Error_Msg_N
+ ("cannot generate contract-only subprogram?", E);
+ Warning_Mode := Saved_Mode;
+ end;
+ end if;
+
+ return True;
+ end if;
+
+ return False;
+ end Skip_Contract_Only_Subprogram;
+
+ -- Start of processing for Build_Contract_Only_Subprogram
+
+ begin
+ -- Test cases where the wrapper is not needed and cases where we
+ -- cannot build it.
+
+ if Skip_Contract_Only_Subprogram (E) then
+ return Empty;
+ end if;
+
+ -- Note on calls to Copy_Separate_Tree. The trees we are copying
+ -- here are fully analyzed, but we definitely want fully syntactic
+ -- unanalyzed trees in the body we construct, so that the analysis
+ -- generates the right visibility, and that is exactly what the
+ -- calls to Copy_Separate_Tree give us.
+
+ declare
+ Name : constant Name_Id :=
+ New_External_Name (Chars (E), "__contract_only");
+ Id : Entity_Id;
+ Bod : Node_Id;
+
+ begin
+ Bod :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Copy_Subprogram_Spec (Declaration_Node (E)),
+ Declarations =>
+ Build_Missing_Body_Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Build_Missing_Body_Subprogram_Call),
+ End_Label => Make_Identifier (Loc, Name)));
+
+ Id := Defining_Unit_Name (Specification (Bod));
+
+ -- Copy only the pre/postconditions of the original contract
+ -- since it is what we need, but also because pragmas stored in
+ -- the other fields have N_Pragmas with N_Aspect_Specifications
+ -- that reference their associated pragma (thus causing an endless
+ -- loop when trying to copy the subtree).
+
+ declare
+ New_Contract : constant Node_Id := Make_Contract (Sloc (E));
+
+ begin
+ Set_Pre_Post_Conditions (New_Contract,
+ Copy_Separate_Tree (Pre_Post_Conditions (Contract (E))));
+ Set_Contract (Id, New_Contract);
+ end;
+
+ -- Fix the name of this new subprogram and link the original
+ -- subprogram with its Contract_Only_Body subprogram.
+
+ Set_Chars (Id, Name);
+ Set_Is_Contract_Only_Body (Id);
+ Set_Contract_Only_Body (E, Id);
+
+ return Bod;
+ end;
+ end Build_Contract_Only_Subprogram;
+
+ -------------------------------------
+ -- Build_Contract_Only_Subprograms --
+ -------------------------------------
+
+ function Build_Contract_Only_Subprograms (L : List_Id) return List_Id is
+ Decl : Node_Id;
+ New_Subp : Node_Id;
+ Result : List_Id := No_List;
+ Subp_Id : Entity_Id;
+
+ begin
+ Decl := First (L);
+ while Present (Decl) loop
+ if Nkind (Decl) = N_Subprogram_Declaration then
+ Subp_Id := Defining_Unit_Name (Specification (Decl));
+ New_Subp := Build_Contract_Only_Subprogram (Subp_Id);
+
+ if Present (New_Subp) then
+ if No (Result) then
+ Result := New_List;
+ end if;
+
+ Append_To (Result, New_Subp);
+ end if;
+ end if;
+
+ Next (Decl);
+ end loop;
+
+ return Result;
+ end Build_Contract_Only_Subprograms;
+
+ ------------------------------
+ -- Has_Private_Declarations --
+ ------------------------------
+
+ function Has_Private_Declarations (N : Node_Id) return Boolean is
+ begin
+ if not Nkind_In (N, N_Package_Specification,
+ N_Protected_Definition,
+ N_Task_Definition)
+ then
+ return False;
+ else
+ return
+ Present (Private_Declarations (N))
+ and then Is_Non_Empty_List (Private_Declarations (N));
+ end if;
+ end Has_Private_Declarations;
+
+ -- Local variables
+
+ Subp_List : List_Id;
+
+ -- Start of processing for Build_And_Analyze_Contract_Only_Subprograms
+
+ begin
+ Subp_List := Build_Contract_Only_Subprograms (L);
+ Append_Contract_Only_Subprograms (Subp_List);
+ Analyze_Contract_Only_Subprograms;
+ end Build_And_Analyze_Contract_Only_Subprograms;
+
-----------------------------
-- Create_Generic_Contract --
-----------------------------
@@ -1432,15 +1913,6 @@ package body Contracts is
-- of statements to be checked on exit. Parameter Result is the entity
-- of parameter _Result when Subp_Id denotes a function.
- function Build_Pragma_Check_Equivalent
- (Prag : Node_Id;
- Subp_Id : Entity_Id := Empty;
- Inher_Id : Entity_Id := Empty) return Node_Id;
- -- Transform a [refined] pre- or postcondition denoted by Prag into an
- -- equivalent pragma Check. When the pre- or postcondition is inherited,
- -- the routine corrects the references of all formals of Inher_Id to
- -- point to the formals of Subp_Id.
-
procedure Process_Contract_Cases (Stmts : in out List_Id);
-- Process pragma Contract_Cases. This routine prepends items to the
-- body declarations and appends items to list Stmts.
@@ -1518,73 +1990,10 @@ package body Contracts is
-------------------------
function Invariant_Checks_OK (Typ : Entity_Id) return Boolean is
- function Has_Null_Body (Proc_Id : Entity_Id) return Boolean;
- -- Determine whether the body of procedure Proc_Id contains a sole
- -- null statement, possibly followed by an optional return.
-
function Has_Public_Visibility_Of_Subprogram return Boolean;
-- Determine whether type Typ has public visibility of subprogram
-- Subp_Id.
- -------------------
- -- Has_Null_Body --
- -------------------
-
- function Has_Null_Body (Proc_Id : Entity_Id) return Boolean is
- Body_Id : Entity_Id;
- Decl : Node_Id;
- Spec : Node_Id;
- Stmt1 : Node_Id;
- Stmt2 : Node_Id;
-
- begin
- Spec := Parent (Proc_Id);
- Decl := Parent (Spec);
-
- -- Retrieve the entity of the invariant procedure body
-
- if Nkind (Spec) = N_Procedure_Specification
- and then Nkind (Decl) = N_Subprogram_Declaration
- then
- Body_Id := Corresponding_Body (Decl);
-
- -- The body acts as a spec
-
- else
- Body_Id := Proc_Id;
- end if;
-
- -- The body will be generated later
-
- if No (Body_Id) then
- return False;
- end if;
-
- Spec := Parent (Body_Id);
- Decl := Parent (Spec);
-
- pragma Assert
- (Nkind (Spec) = N_Procedure_Specification
- and then Nkind (Decl) = N_Subprogram_Body);
-
- Stmt1 := First (Statements (Handled_Statement_Sequence (Decl)));
-
- -- Look for a null statement followed by an optional return
- -- statement.
-
- if Nkind (Stmt1) = N_Null_Statement then
- Stmt2 := Next (Stmt1);
-
- if Present (Stmt2) then
- return Nkind (Stmt2) = N_Simple_Return_Statement;
- else
- return True;
- end if;
- end if;
-
- return False;
- end Has_Null_Body;
-
-----------------------------------------
-- Has_Public_Visibility_Of_Subprogram --
-----------------------------------------
@@ -1791,10 +2200,12 @@ package body Contracts is
-- Local variables
- Loc : constant Source_Ptr := Sloc (Body_Decl);
- Params : List_Id := No_List;
- Proc_Bod : Node_Id;
- Proc_Id : Entity_Id;
+ Loc : constant Source_Ptr := Sloc (Body_Decl);
+ Params : List_Id := No_List;
+ Proc_Bod : Node_Id;
+ Proc_Decl : Node_Id;
+ Proc_Id : Entity_Id;
+ Proc_Spec : Node_Id;
-- Start of processing for Build_Postconditions_Procedure
@@ -1809,6 +2220,17 @@ package body Contracts is
Set_Debug_Info_Needed (Proc_Id);
Set_Postconditions_Proc (Subp_Id, Proc_Id);
+ -- Force the front-end inlining of _Postconditions when generating C
+ -- code, since its body may have references to itypes defined in the
+ -- enclosing subprogram, which would cause problems for unnesting
+ -- routines in the absence of inlining.
+
+ if Modify_Tree_For_C then
+ Set_Has_Pragma_Inline (Proc_Id);
+ Set_Has_Pragma_Inline_Always (Proc_Id);
+ Set_Is_Inlined (Proc_Id);
+ end if;
+
-- The related subprogram is a function: create the specification of
-- parameter _Result.
@@ -1820,6 +2242,13 @@ package body Contracts is
New_Occurrence_Of (Etype (Result), Loc)));
end if;
+ Proc_Spec :=
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Proc_Id,
+ Parameter_Specifications => Params);
+
+ Proc_Decl := Make_Subprogram_Declaration (Loc, Proc_Spec);
+
-- Insert _Postconditions before the first source declaration of the
-- body. This ensures that the body will not cause any premature
-- freezing, as it may mention types:
@@ -1838,6 +2267,9 @@ package body Contracts is
-- order reference. The body of _Postconditions must be placed after
-- the declaration of Temp to preserve correct visibility.
+ Insert_Before_First_Source_Declaration (Proc_Decl);
+ Analyze (Proc_Decl);
+
-- Set an explicit End_Label to override the sloc of the implicit
-- RETURN statement, and prevent it from inheriting the sloc of one
-- the postconditions: this would cause confusing debug info to be
@@ -1846,169 +2278,16 @@ package body Contracts is
Proc_Bod :=
Make_Subprogram_Body (Loc,
Specification =>
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Proc_Id,
- Parameter_Specifications => Params),
-
+ Copy_Subprogram_Spec (Proc_Spec),
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts,
End_Label => Make_Identifier (Loc, Chars (Proc_Id))));
- Insert_Before_First_Source_Declaration (Proc_Bod);
- Analyze (Proc_Bod);
+ Insert_After_And_Analyze (Proc_Decl, Proc_Bod);
end Build_Postconditions_Procedure;
- -----------------------------------
- -- Build_Pragma_Check_Equivalent --
- -----------------------------------
-
- function Build_Pragma_Check_Equivalent
- (Prag : Node_Id;
- Subp_Id : Entity_Id := Empty;
- Inher_Id : Entity_Id := Empty) return Node_Id
- is
- function Suppress_Reference (N : Node_Id) return Traverse_Result;
- -- Detect whether node N references a formal parameter subject to
- -- pragma Unreferenced. If this is the case, set Comes_From_Source
- -- to False to suppress the generation of a reference when analyzing
- -- N later on.
-
- ------------------------
- -- Suppress_Reference --
- ------------------------
-
- function Suppress_Reference (N : Node_Id) return Traverse_Result is
- Formal : Entity_Id;
-
- begin
- if Is_Entity_Name (N) and then Present (Entity (N)) then
- Formal := Entity (N);
-
- -- The formal parameter is subject to pragma Unreferenced.
- -- Prevent the generation of a reference by resetting the
- -- Comes_From_Source flag.
-
- if Is_Formal (Formal)
- and then Has_Pragma_Unreferenced (Formal)
- then
- Set_Comes_From_Source (N, False);
- end if;
- end if;
-
- return OK;
- end Suppress_Reference;
-
- procedure Suppress_References is
- new Traverse_Proc (Suppress_Reference);
-
- -- Local variables
-
- Loc : constant Source_Ptr := Sloc (Prag);
- Prag_Nam : constant Name_Id := Pragma_Name (Prag);
- Check_Prag : Node_Id;
- Formals_Map : Elist_Id;
- Inher_Formal : Entity_Id;
- Msg_Arg : Node_Id;
- Nam : Name_Id;
- Subp_Formal : Entity_Id;
-
- -- Start of processing for Build_Pragma_Check_Equivalent
-
- begin
- Formals_Map := No_Elist;
-
- -- When the pre- or postcondition is inherited, map the formals of
- -- the inherited subprogram to those of the current subprogram.
-
- if Present (Inher_Id) then
- pragma Assert (Present (Subp_Id));
-
- Formals_Map := New_Elmt_List;
-
- -- Create a relation <inherited formal> => <subprogram formal>
-
- Inher_Formal := First_Formal (Inher_Id);
- Subp_Formal := First_Formal (Subp_Id);
- while Present (Inher_Formal) and then Present (Subp_Formal) loop
- Append_Elmt (Inher_Formal, Formals_Map);
- Append_Elmt (Subp_Formal, Formals_Map);
-
- Next_Formal (Inher_Formal);
- Next_Formal (Subp_Formal);
- end loop;
- end if;
-
- -- Copy the original pragma while performing substitutions (if
- -- applicable).
-
- Check_Prag :=
- New_Copy_Tree
- (Source => Prag,
- Map => Formals_Map,
- New_Scope => Current_Scope);
-
- -- Mark the pragma as being internally generated and reset the
- -- Analyzed flag.
-
- Set_Analyzed (Check_Prag, False);
- Set_Comes_From_Source (Check_Prag, False);
-
- -- The tree of the original pragma may contain references to the
- -- formal parameters of the related subprogram. At the same time
- -- the corresponding body may mark the formals as unreferenced:
-
- -- procedure Proc (Formal : ...)
- -- with Pre => Formal ...;
-
- -- procedure Proc (Formal : ...) is
- -- pragma Unreferenced (Formal);
- -- ...
-
- -- This creates problems because all pragma Check equivalents are
- -- analyzed at the end of the body declarations. Since all source
- -- references have already been accounted for, reset any references
- -- to such formals in the generated pragma Check equivalent.
-
- Suppress_References (Check_Prag);
-
- if Present (Corresponding_Aspect (Prag)) then
- Nam := Chars (Identifier (Corresponding_Aspect (Prag)));
- else
- Nam := Prag_Nam;
- end if;
-
- -- Convert the copy into pragma Check by correcting the name and
- -- adding a check_kind argument.
-
- Set_Pragma_Identifier
- (Check_Prag, Make_Identifier (Loc, Name_Check));
-
- Prepend_To (Pragma_Argument_Associations (Check_Prag),
- Make_Pragma_Argument_Association (Loc,
- Expression => Make_Identifier (Loc, Nam)));
-
- -- Update the error message when the pragma is inherited
-
- if Present (Inher_Id) then
- Msg_Arg := Last (Pragma_Argument_Associations (Check_Prag));
-
- if Chars (Msg_Arg) = Name_Message then
- String_To_Name_Buffer (Strval (Expression (Msg_Arg)));
-
- -- Insert "inherited" to improve the error message
-
- if Name_Buffer (1 .. 8) = "failed p" then
- Insert_Str_In_Name_Buffer ("inherited ", 8);
- Set_Strval (Expression (Msg_Arg), String_From_Name_Buffer);
- end if;
- end if;
- end if;
-
- return Check_Prag;
- end Build_Pragma_Check_Equivalent;
-
----------------------------
-- Process_Contract_Cases --
----------------------------
@@ -2216,6 +2495,10 @@ package body Contracts is
-- The insertion node after which all pragma Check equivalents are
-- inserted.
+ function Is_Prologue_Renaming (Decl : Node_Id) return Boolean;
+ -- Determine whether arbitrary declaration Decl denotes a renaming of
+ -- a discriminant or protection field _object.
+
procedure 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
@@ -2236,6 +2519,54 @@ package body Contracts is
-- Collect all preconditions of subprogram Subp_Id and prepend their
-- pragma Check equivalents to the declarations of the body.
+ --------------------------
+ -- Is_Prologue_Renaming --
+ --------------------------
+
+ function Is_Prologue_Renaming (Decl : Node_Id) return Boolean is
+ Nam : Node_Id;
+ Obj : Entity_Id;
+ Pref : Node_Id;
+ Sel : Node_Id;
+
+ begin
+ if Nkind (Decl) = N_Object_Renaming_Declaration then
+ Obj := Defining_Entity (Decl);
+ Nam := Name (Decl);
+
+ if Nkind (Nam) = N_Selected_Component then
+ Pref := Prefix (Nam);
+ Sel := Selector_Name (Nam);
+
+ -- A discriminant renaming appears as
+ -- Discr : constant ... := Prefix.Discr;
+
+ if Ekind (Obj) = E_Constant
+ and then Is_Entity_Name (Sel)
+ and then Present (Entity (Sel))
+ and then Ekind (Entity (Sel)) = E_Discriminant
+ then
+ return True;
+
+ -- A protection field renaming appears as
+ -- Prot : ... := _object._object;
+
+ -- A renamed private component is just a component of
+ -- _object, with an arbitrary name.
+
+ elsif Ekind (Obj) = E_Variable
+ and then Nkind (Pref) = N_Identifier
+ and then Chars (Pref) = Name_uObject
+ and then Nkind (Sel) = N_Identifier
+ then
+ return True;
+ end if;
+ end if;
+ end if;
+
+ return False;
+ end Is_Prologue_Renaming;
+
-------------------------
-- Merge_Preconditions --
-------------------------
@@ -2484,15 +2815,41 @@ package body Contracts is
-- Start of processing for Process_Preconditions
begin
- -- Find the last internally generated declaration, starting from the
- -- top of the body declarations. This ensures that discriminals and
- -- subtypes are properly visible to the pragma Check equivalents.
+ -- Find the proper insertion point for all pragma Check equivalents
if Present (Decls) then
Decl := First (Decls);
while Present (Decl) loop
- exit when Comes_From_Source (Decl);
- Insert_Node := Decl;
+
+ -- First source declaration terminates the search, because all
+ -- preconditions must be evaluated prior to it, by definition.
+
+ if Comes_From_Source (Decl) then
+ exit;
+
+ -- Certain internally generated object renamings such as those
+ -- for discriminants and protection fields must be elaborated
+ -- before the preconditions are evaluated, as their expressions
+ -- may mention the discriminants. The renamings include those
+ -- for private components so we need to find the last such.
+
+ elsif Is_Prologue_Renaming (Decl) then
+ while Present (Next (Decl))
+ and then Is_Prologue_Renaming (Next (Decl))
+ loop
+ Next (Decl);
+ end loop;
+
+ Insert_Node := Decl;
+
+ -- Otherwise the declaration does not come from source. This
+ -- also terminates the search, because internal code may raise
+ -- exceptions which should not preempt the preconditions.
+
+ else
+ exit;
+ end if;
+
Next (Decl);
end loop;
end if;
diff --git a/gcc/ada/contracts.ads b/gcc/ada/contracts.ads
index 1059fc6315..d40200e183 100644
--- a/gcc/ada/contracts.ads
+++ b/gcc/ada/contracts.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2015-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -131,7 +131,8 @@ package Contracts is
procedure Analyze_Previous_Contracts (Body_Decl : Node_Id);
-- Analyze the contracts of all source constructs found in the declarative
-- list which contains entry, package, protected, subprogram, or task body
- -- denoted by Body_Decl. The analysis stops once Body_Decl is reached.
+ -- denoted by Body_Decl. The analysis stops once Body_Decl is reached. In
+ -- addition, analyze the contract of the nearest enclosing package body.
procedure Analyze_Protected_Contract (Prot_Id : Entity_Id);
-- Analyze all delayed pragmas chained on the contract of protected unit
diff --git a/gcc/ada/cstreams.c b/gcc/ada/cstreams.c
index 915e4a3db1..f0f826685b 100644
--- a/gcc/ada/cstreams.c
+++ b/gcc/ada/cstreams.c
@@ -39,6 +39,8 @@
#include <stdio.h>
#include <sys/types.h>
+#include <sys/stat.h>
+#include <unistd.h>
#ifdef _AIX
/* needed to avoid conflicting declarations */
@@ -320,6 +322,24 @@ __gnat_fseek64 (FILE *stream, __int64 offset, int origin)
}
#endif
+/* Returns true if the path names a fifo (i.e. a named pipe). */
+int
+__gnat_is_fifo (const char* path)
+{
+/* Posix defines S_ISFIFO as a macro. If the macro doesn't exist, we return
+ false. */
+#ifdef S_ISFIFO
+ struct stat buf;
+ const int status = stat(path, &buf);
+ if (status == 0)
+ return S_ISFIFO(buf.st_mode);
+#endif
+
+ /* S_ISFIFO is not available, or stat got an error (probably
+ file not found). */
+ return 0;
+}
+
#ifdef __cplusplus
}
#endif
diff --git a/gcc/ada/ctrl_c.c b/gcc/ada/ctrl_c.c
index 7f8d177d17..b1bd08527a 100644
--- a/gcc/ada/ctrl_c.c
+++ b/gcc/ada/ctrl_c.c
@@ -92,8 +92,8 @@ __gnat_install_int_handler (void (*proc) (void))
if (sigint_intercepted == 0)
{
act.sa_handler = __gnat_int_handler;
-#if defined (__Lynx__) || defined (VMS)
- /* LynxOS and VMS do not support SA_RESTART. */
+#if defined (__Lynx__) || defined (VMS) || defined(__DJGPP__)
+ /* LynxOS, VMS and DJGPP do not support SA_RESTART. */
act.sa_flags = 0;
#else
act.sa_flags = SA_RESTART;
diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb
index b38b82b102..5fcb6c8dff 100644
--- a/gcc/ada/debug.adb
+++ b/gcc/ada/debug.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -105,11 +105,11 @@ package body Debug is
-- d.l Use Ada 95 semantics for limited function returns
-- d.m For -gnatl, print full source only for main unit
-- d.n Print source file names
- -- d.o
- -- d.p
+ -- d.o Conservative elaboration order for indirect calls
+ -- d.p Use original Ada 95 semantics for Bit_Order (disable AI95-0133)
-- d.q
-- d.r Enable OK_To_Reorder_Components in non-variant records
- -- d.s Disable expansion of slice move, use memmove
+ -- d.s
-- d.t Disable static allocation of library level dispatch tables
-- d.u Enable Modify_Tree_For_C (update tree for c)
-- d.v Enable OK_To_Reorder_Components in variant records
@@ -125,10 +125,10 @@ package body Debug is
-- d.E Turn selected errors into warnings
-- d.F Debug mode for GNATprove
-- d.G Ignore calls through generic formal parameters for elaboration
- -- d.H
+ -- d.H GNSA mode for ASIS
-- d.I Do not ignore enum representation clauses in CodePeer mode
- -- d.J Disable parallel SCIL generation mode
- -- d.K
+ -- d.J
+ -- d.K Enable generation of contract-only procedures in CodePeer mode
-- d.L Depend on back end for limited types in if and case expressions
-- d.M Relaxed RM semantics
-- d.N Add node to all entities
@@ -139,7 +139,7 @@ package body Debug is
-- d.S Force Optimize_Alignment (Space)
-- d.T Force Optimize_Alignment (Time)
-- d.U Ignore indirect calls for static elaboration
- -- d.V
+ -- d.V Do not verify validity of SCIL files (CodePeer mode)
-- d.W Print out debugging information for Walk_Library_Items
-- d.X Old treatment of indexing aspects
-- d.Y
@@ -158,9 +158,9 @@ package body Debug is
-- d.1 Enable unnesting of nested procedures
-- d.2 Allow statements in declarative part
-- d.3 Output debugging information from Exp_Unst
- -- d.4
+ -- d.4 Do not delete generated C file in case of errors
-- d.5 Do not generate imported subprogram definitions in C code
- -- d.6
+ -- d.6 Do not avoid declaring unreferenced itypes in C code
-- d.7
-- d.8
-- d.9
@@ -181,14 +181,14 @@ package body Debug is
-- dl
-- dm
-- dn List details of manipulation of Num_Pred values
- -- do Use old preference for elaboration order
- -- dp
+ -- do Use older preference for elaboration order
+ -- dp Use old preference for elaboration order
-- dq
-- dr
-- ds
-- dt
-- du List units as they are acquired
- -- dv
+ -- dv Verbose debugging printouts
-- dw
-- dx Force binder to read xref information from ali files
-- dy
@@ -376,8 +376,7 @@ package body Debug is
-- general Elaborate_All is still required because of nested calls.
-- dE Apply compile time elaboration checking for with relations between
- -- predefined units. Normally no checks are made (it seems that at
- -- least on the SGI, such checks run into trouble).
+ -- predefined units. Normally no checks are made.
-- dF Front end data layout enabled. Normally front end data layout
-- is only enabled if the target parameter Backend_Layout is False.
@@ -407,7 +406,7 @@ package body Debug is
-- dL Output trace information on elaboration checking. This debug
-- switch causes output to be generated showing each call or
-- instantiation as it is checked, and the progress of the recursive
- -- trace through calls at elaboration time.
+ -- trace through elaboration calls at compile time.
-- dM Assume all variables have been modified, and ignore current value
-- indications. This debug flag disconnects the tracking of constant
@@ -556,14 +555,16 @@ package body Debug is
-- compiler has a bug -- these are the files that need to be included
-- in a bug report.
+ -- d.o Conservative elaboration order for indirect calls. This causes
+ -- P'Access to be treated as a call in more cases.
+
+ -- d.p In Ada 95 (or 83) mode, use original Ada 95 behavior for the
+ -- interpretation of component clauses crossing byte boundaries when
+ -- using the non-default bit order (i.e. ignore AI95-0133).
+
-- d.r Forces the flag OK_To_Reorder_Components to be set in all record
-- base types that have no discriminants.
- -- d.s Normally the compiler expands slice moves into loops if overlap
- -- might be possible. This debug flag inhibits that expansion, and
- -- the back end is expected to use an appropriate routine to handle
- -- overlap, based on Forward_OK and Backwards_OK flags.
-
-- d.t The compiler has been modified (a fairly extensive modification)
-- to generate static dispatch tables for library level tagged types.
-- This debug switch disables this modification and reverts to the
@@ -585,11 +586,10 @@ package body Debug is
-- code generation step.
-- d.z Restore previous front-end support for Inline_Always. In default
- -- mode, for targets that use the GCC back end (i.e. currently all
- -- targets except AAMP and GNATprove), Inline_Always is handled by the
- -- back end. Use of this switch restores the previous 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.
+ -- mode, for targets that use the GCC back end, Inline_Always is
+ -- handled by the back end. Use of this switch restores the previous
+ -- 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 There seems to be a problem with ASIS if we activate the circuit
-- for reading and writing the aspect specification hash table, so
@@ -636,15 +636,21 @@ package body Debug is
-- now fixed, but we provide this debug flag to revert to the previous
-- situation of ignoring such calls to aid in transition.
+ -- d.H Sets ASIS_GNSA_Mode to True. This signals the front end to suppress
+ -- the call to gigi in ASIS_Mode.
+
-- d.I Do not ignore enum representation clauses in CodePeer mode.
-- The default of ignoring representation clauses for enumeration
-- types in CodePeer is good for the majority of Ada code, but in some
-- cases being able to change this default might be useful to remove
-- some false positives.
- -- d.J Disable parallel SCIL generation. Normally SCIL file generation is
- -- done in parallel to speed processing. This switch disables this
- -- behavior.
+ -- d.K Enable generation of contract-only procedures in CodePeer mode and
+ -- report a warning on subprograms for which the contract-only body
+ -- cannot be built. Currently reported on subprograms defined in
+ -- nested package specs that have some formal (or return type) whose
+ -- type is a private type defined in some enclosing package and that
+ -- have pre/postconditions.
-- d.L Normally the front end generates special expansion for conditional
-- expressions of a limited type. This debug flag removes this special
@@ -689,6 +695,12 @@ package body Debug is
-- reverts to the behavior of earlier compilers, which ignored
-- indirect calls.
+ -- d.V Do not verify the validity of SCIL files (CodePeer mode). When
+ -- generating SCIL files for CodePeer, by default we verify that the
+ -- SCIL is well formed before saving it on disk. This switch can be
+ -- used to disable this checking, either to improve speed or to shut
+ -- down a false positive detected during the verification.
+
-- d.W Print out debugging information for Walk_Library_Items, including
-- the order in which units are walked. This is primarily for use in
-- debugging CodePeer mode.
@@ -762,10 +774,17 @@ package body Debug is
-- d.3 Output debugging information from Exp_Unst, including the name of
-- any unreachable subprograms that get deleted.
+ -- d.4 By default in case of an error during C generation, the .c or .h
+ -- file is deleted. This flag keeps the C file.
+
-- d.5 By default a subprogram imported generates a subprogram profile.
-- This debug flag disables this generation when generating C code,
-- assuming a proper #include will be used instead.
+ -- d.6 By default the C back-end avoids declaring itypes that are not
+ -- referenced by the generated C code. This debug flag restores the
+ -- output of all the itypes.
+
------------------------------------------
-- Documentation for Binder Debug Flags --
------------------------------------------
@@ -798,14 +817,24 @@ package body Debug is
-- the algorithm used to determine a correct order of elaboration. This
-- is useful in diagnosing any problems in its behavior.
- -- do Use old elaboration order preference. The new preference rules
+ -- do Use older elaboration order preference. The new preference rules
-- prefer specs with no bodies to specs with bodies, and between two
-- specs with bodies, prefers the one whose body is closer to being
-- able to be elaborated. This is a clear improvement, but we provide
- -- this debug flag in case of regressions.
+ -- this debug flag in case of regressions. Note: -do is even older than
+ -- -dp.
+
+ -- dp Use old elaboration order preference. The new preference rules
+ -- elaborate all units within a strongly connected component together,
+ -- with no other units in between. In particular, if a spec/body pair
+ -- can be elaborated together, it will be. In the new order, the binder
+ -- behaves as if every pragma Elaborate_All that would be legal is
+ -- present, even if it does not appear in the source code.
-- du List unit name and file name for each unit as it is read in
+ -- dv Verbose debugging printouts
+
-- dx Force the binder to read (and then ignore) the xref information
-- in ali files (used to check that read circuit is working OK).
diff --git a/gcc/ada/doc/Makefile b/gcc/ada/doc/Makefile
index 9ac33c50b6..df10fca169 100644
--- a/gcc/ada/doc/Makefile
+++ b/gcc/ada/doc/Makefile
@@ -24,26 +24,23 @@ help:
@echo " DOC_NAME.html to make standalone HTML files"
@echo " DOC_NAME.pdf to make LaTeX files and run them through pdflatex"
@echo " DOC_NAME.txt to make text files"
- @echo " DOC_NAME.texinfo to make Texinfo files"
@echo " DOC_NAME.info to make info files"
+ @echo " DOC_NAME.texinfo to make Texinfo files"
@echo " DOC_NAME.all to build DOC_NAME for all previous formats"
@echo " all to build all documentations in all formats"
@echo " html-all same as previous rule but only for HTML format"
@echo " pdf-all same as previous rule but only for PDF format"
@echo " txt-all same as previous rule but only for text format"
- @echo " texinfo-all same as previous rule but only for texinfo format"
@echo " info-all same as previous rule but only for info format"
+ @echo " texinfo-all same as previous rule but only for texinfo format"
@echo ""
@echo "DOC_NAME should be a documentation name in the following list:"
@echo " $(DOC_LIST)"
@echo ""
- @echo "source and location can be overriden using SOURCEDIR and BUILDDIR variables"
+ @echo "source and location can be overridden using SOURCEDIR and BUILDDIR variables"
clean:
- -rm -rf $(BUILDDIR)/*/html \
- $(BUILDDIR)/*/pdf \
- $(BUILDDIR)/*/txt \
- $(BUILDDIR)/*/info
+ -rm -rf $(BUILDDIR)
%.html:
$(SPHINXBUILD) -b html $(ALLSPHINXOPTS) $(BUILDDIR)/$*/html
@@ -65,16 +62,23 @@ clean:
$(SPHINXBUILD) -b texinfo $(ALLSPHINXOPTS) $(BUILDDIR)/$*/texinfo
sed -e 's/^@dircategory/@dircategory GNU Ada Tools/g' < $(BUILDDIR)/$*/texinfo/$*.texi > $(BUILDDIR)/../../$*.texi
+.PHONY: html-all
html-all: $(foreach doc, $(DOC_LIST), $(doc).html)
+.PHONY: pdf-all
pdf-all: $(foreach doc, $(DOC_LIST), $(doc).pdf)
+.PHONY: txt-all
txt-all: $(foreach doc, $(DOC_LIST), $(doc).txt)
+.PHONY: info-all
+info-all: $(foreach doc, $(DOC_LIST), $(doc).info)
+
+.PHONY: texinfo-all
texinfo-all: $(foreach doc, $(DOC_LIST), $(doc).texinfo)
%.all:
$(MAKE) $(foreach fmt, $(FMT_LIST), $*.$(fmt))
-all: $(foreach fmt, $(FMT_LIST), $(fmt).all)
-
+.PHONY: all
+all: $(foreach fmt, $(FMT_LIST), $(fmt)-all)
diff --git a/gcc/ada/doc/gnat_rm.rst b/gcc/ada/doc/gnat_rm.rst
index a9ea40d679..e18d1785d3 100644
--- a/gcc/ada/doc/gnat_rm.rst
+++ b/gcc/ada/doc/gnat_rm.rst
@@ -4,23 +4,23 @@ GNAT Reference Manual
*GNAT, The GNU Ada Development Environment*
.. only:: PRO
-
+
*GNAT Pro Edition*
-
+
| Version |version|
| Date: |today|
.. only:: GPL
-
+
*GNAT GPL Edition*
-
+
| Version |version|
| Date: |today|
.. only:: FSF
-
+
.. raw:: texinfo
-
+
@include gcc-common.texi
GCC version @value{version-GCC}@*
diff --git a/gcc/ada/doc/gnat_rm/about_this_guide.rst b/gcc/ada/doc/gnat_rm/about_this_guide.rst
index 11450c421b..8071b4235d 100644
--- a/gcc/ada/doc/gnat_rm/about_this_guide.rst
+++ b/gcc/ada/doc/gnat_rm/about_this_guide.rst
@@ -114,7 +114,7 @@ This reference manual contains the following chapters:
.. index:: Ada 2005 Language Reference Manual
This reference manual assumes a basic familiarity with the Ada 95 language, as
-described in the
+described in the
:title:`International Standard ANSI/ISO/IEC-8652:1995`.
It does not require knowledge of the new features introduced by Ada 2005 or
Ada 2012.
@@ -148,10 +148,10 @@ in this guide:
::
and then shown this way.
-
+
* Commands that are entered by the user are shown as preceded by a prompt string
comprising the ``$`` character followed by a space.
-
+
Related Information
===================
diff --git a/gcc/ada/doc/gnat_rm/compatibility_and_porting_guide.rst b/gcc/ada/doc/gnat_rm/compatibility_and_porting_guide.rst
index 5d699f585f..a859761585 100644
--- a/gcc/ada/doc/gnat_rm/compatibility_and_porting_guide.rst
+++ b/gcc/ada/doc/gnat_rm/compatibility_and_porting_guide.rst
@@ -22,7 +22,7 @@ For example, if we write
.. code-block:: ada
type F1 is delta 1.0 range -128.0 .. +128.0;
-
+
then the implementation is allowed to choose -128.0 .. +127.0 if it
likes, but is not required to do so.
@@ -45,7 +45,7 @@ representation. Let's take another example:
.. code-block:: ada
type F2 is delta 2.0**(-15) range -1.0 .. +1.0;
-
+
Looking at this declaration, it seems casually as though
it should fit in 16 bits, but again that extra positive value
+1.0 has the scaled integer equivalent of 2**15 which is one too
@@ -54,7 +54,7 @@ big for signed 16 bits. The implementation can treat this as:
.. code-block:: ada
type F2 is delta 2.0**(-15) range -1.0 .. +1.0-(2.0**(-15));
-
+
and the Ada language design team felt that this was too annoying
to require. We don't need to debate this decision at this point,
since it is well established (the rule about narrowing the ranges
@@ -77,14 +77,14 @@ approach: to narrow all the time, e.g. to treat
.. code-block:: ada
type F3 is delta 1.0 range -10.0 .. +23.0;
-
+
as though it had been written:
.. code-block:: ada
type F3 is delta 1.0 range -9.0 .. +22.0;
-
+
But although technically allowed, such a behavior would be hostile and silly,
and no real compiler would do this. All real compilers will fall into one of
the categories (a), (b) or (c) above.
@@ -101,14 +101,14 @@ E.g., for `F2` above, we will write:
My_Last : constant := +1.0 - My_Small;
type F2 is delta My_Small range My_First .. My_Last;
-
+
and then add
.. code-block:: ada
for F2'Small use my_Small;
for F2'Size use 16;
-
+
In practice all compilers will do the same thing here and will give you
what you want, so the above declarations are fully portable. If you really
want to play language lawyer and guard against ludicrous behavior by the
@@ -118,7 +118,7 @@ compiler you could add
Test1 : constant := 1 / Boolean'Pos (F2'First = My_First);
Test2 : constant := 1 / Boolean'Pos (F2'Last = My_Last);
-
+
One or other or both are allowed to be illegal if the compiler is
behaving in a silly manner, but at least the silly compiler will not
get away with silently messing with your (very clear) intentions.
@@ -176,7 +176,7 @@ Ada 95 and later versions of the standard:
.. code-block:: ada
for Char in Character range 'A' .. 'Z' loop ... end loop;
-
+
* *New reserved words*
The identifiers `abstract`, `aliased`, `protected`,
@@ -368,7 +368,7 @@ for a complete description please see the
Rule changes in this area have led to some incompatibilities; for example,
constrained subtypes of some access types are not permitted in Ada 2005.
-
+
* *Aggregates for limited types.*
The allowance of aggregates for limited types in Ada 2005 raises the
@@ -517,7 +517,7 @@ Compatibility with Other Ada Systems
====================================
If programs avoid the use of implementation dependent and
-implementation defined features, as documented in the
+implementation defined features, as documented in the
:title:`Ada Reference Manual`, there should be a high degree of portability between
GNAT and other Ada systems. The following are specific items which
have proved troublesome in moving Ada 95 programs from GNAT to other Ada 95
@@ -618,7 +618,7 @@ the cases most likely to arise in existing Ada 83 code.
type X is access all String;
for X'Size use Standard'Address_Size;
-
+
which will cause the type X to be represented using a single pointer.
When using this representation, the bounds are right behind the array.
This representation is slightly less efficient, and does not allow quite
@@ -658,4 +658,3 @@ applicable to GNAT.
that contains the additional definitions, and a special pragma,
Extend_System allows this package to be treated transparently as an
extension of package System.
-
diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst b/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst
index b0c5ef68b9..8d1cf7468b 100644
--- a/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_defined_aspects.rst
@@ -64,14 +64,15 @@ Aspect Abstract_State
.. index:: Abstract_State
-This aspect is equivalent to pragma `Abstract_State`.
+This aspect is equivalent to :ref:`pragma Abstract_State<Pragma-Abstract_State>`.
Annotate
========
.. index:: Annotate
There are three forms of this aspect (where ID is an identifier,
-and ARG is a general expression).
+and ARG is a general expression),
+corresponding to :ref:`pragma Annotate<Pragma-Annotate>`.
@@ -90,25 +91,25 @@ Aspect Async_Readers
====================
.. index:: Async_Readers
-This boolean aspect is equivalent to pragma `Async_Readers`.
+This boolean aspect is equivalent to :ref:`pragma Async_Readers<Pragma-Async_Readers>`.
Aspect Async_Writers
====================
.. index:: Async_Writers
-This boolean aspect is equivalent to pragma `Async_Writers`.
+This boolean aspect is equivalent to :ref:`pragma Async_Writers<Pragma-Async_Writers>`.
Aspect Constant_After_Elaboration
=================================
.. index:: Constant_After_Elaboration
-This aspect is equivalent to pragma `Constant_After_Elaboration`.
+This aspect is equivalent to :ref:`pragma Constant_After_Elaboration<Pragma-Constant_After_Elaboration>`.
Aspect Contract_Cases
=====================
.. index:: Contract_Cases
-This aspect is equivalent to pragma `Contract_Cases`, the sequence
+This aspect is equivalent to :ref:`pragma Contract_Cases<Pragma-Contract_Cases>`, the sequence
of clauses being enclosed in parentheses so that syntactically it is an
aggregate.
@@ -116,13 +117,13 @@ Aspect Depends
==============
.. index:: Depends
-This aspect is equivalent to pragma `Depends`.
+This aspect is equivalent to :ref:`pragma Depends<Pragma-Depends>`.
Aspect Default_Initial_Condition
================================
.. index:: Default_Initial_Condition
-This aspect is equivalent to pragma `Default_Initial_Condition`.
+This aspect is equivalent to :ref:`pragma Default_Initial_Condition<Pragma-Default_Initial_Condition>`.
Aspect Dimension
================
@@ -227,61 +228,61 @@ Aspect Effective_Reads
======================
.. index:: Effective_Reads
-This aspect is equivalent to pragma `Effective_Reads`.
+This aspect is equivalent to :ref:`pragma Effective_Reads<Pragma-Effective_Reads>`.
Aspect Effective_Writes
=======================
.. index:: Effective_Writes
-This aspect is equivalent to pragma `Effective_Writes`.
+This aspect is equivalent to :ref:`pragma Effective_Writes<Pragma-Effective_Writes>`.
Aspect Extensions_Visible
=========================
.. index:: Extensions_Visible
-This aspect is equivalent to pragma `Extensions_Visible`.
+This aspect is equivalent to :ref:`pragma Extensions_Visible<Pragma-Extensions_Visible>`.
Aspect Favor_Top_Level
======================
.. index:: Favor_Top_Level
-This boolean aspect is equivalent to pragma `Favor_Top_Level`.
+This boolean aspect is equivalent to :ref:`pragma Favor_Top_Level<Pragma-Favor_Top_Level>`.
Aspect Ghost
=============
.. index:: Ghost
-This aspect is equivalent to pragma `Ghost`.
+This aspect is equivalent to :ref:`pragma Ghost<Pragma-Ghost>`.
Aspect Global
=============
.. index:: Global
-This aspect is equivalent to pragma `Global`.
+This aspect is equivalent to :ref:`pragma Global<Pragma-Global>`.
Aspect Initial_Condition
========================
.. index:: Initial_Condition
-This aspect is equivalent to pragma `Initial_Condition`.
+This aspect is equivalent to :ref:`pragma Initial_Condition<Pragma-Initial_Condition>`.
Aspect Initializes
==================
.. index:: Initializes
-This aspect is equivalent to pragma `Initializes`.
+This aspect is equivalent to :ref:`pragma Initializes<Pragma-Initializes>`.
Aspect Inline_Always
====================
.. index:: Inline_Always
-This boolean aspect is equivalent to pragma `Inline_Always`.
+This boolean aspect is equivalent to :ref:`pragma Inline_Always<Pragma-Inline_Always>`.
Aspect Invariant
================
.. index:: Invariant
-This aspect is equivalent to pragma `Invariant`. It is a
+This aspect is equivalent to :ref:`pragma Invariant<Pragma-Invariant>`. It is a
synonym for the language defined aspect `Type_Invariant` except
that it is separately controllable using pragma `Assertion_Policy`.
@@ -289,7 +290,7 @@ Aspect Invariant'Class
======================
.. index:: Invariant'Class
-This aspect is equivalent to pragma `Type_Invariant_Class`. It is a
+This aspect is equivalent to :ref:`pragma Type_Invariant_Class<Pragma-Type_Invariant_Class>`. It is a
synonym for the language defined aspect `Type_Invariant'Class` except
that it is separately controllable using pragma `Assertion_Policy`.
@@ -350,26 +351,33 @@ Aspect Linker_Section
=====================
.. index:: Linker_Section
-This aspect is equivalent to an `Linker_Section` pragma.
+This aspect is equivalent to :ref:`pragma Linker_Section<Pragma-Linker_Section>`.
Aspect Lock_Free
================
.. index:: Lock_Free
-This boolean aspect is equivalent to pragma `Lock_Free`.
+This boolean aspect is equivalent to :ref:`pragma Lock_Free<Pragma-Lock_Free>`.
+
+Aspect Max_Queue_Length
+=======================
+
+.. index:: Max_Queue_Length
+
+This aspect is equivalent to :ref:`pragma Max_Queue_Length<Pragma-Max_Queue_Length>`.
Aspect No_Elaboration_Code_All
==============================
.. index:: No_Elaboration_Code_All
-This aspect is equivalent to a `pragma No_Elaboration_Code_All`
-statement for a program unit.
+This aspect is equivalent to :ref:`pragma No_Elaboration_Code_All<Pragma-No_Elaboration_Code_All>`
+for a program unit.
Aspect No_Tagged_Streams
========================
.. index:: No_Tagged_Streams
-This aspect is equivalent to a `pragma No_Tagged_Streams` with an
+This aspect is equivalent to :ref:`pragma No_Tagged_Streams<Pragma-No_Tagged_Streams>` with an
argument specifying a root tagged type (thus this aspect can only be
applied to such a type).
@@ -377,14 +385,13 @@ Aspect Object_Size
==================
.. index:: Object_Size
-This aspect is equivalent to an `Object_Size` attribute definition
-clause.
+This aspect is equivalent to :ref:`attribute Object_Size<Attribute-Object_Size>`.
Aspect Obsolescent
==================
.. index:: Obsolsecent
-This aspect is equivalent to an `Obsolescent` pragma. Note that the
+This aspect is equivalent to :ref:`pragma Obsolescent<Pragma_Obsolescent>`. Note that the
evaluation of this aspect happens at the point of occurrence, it is not
delayed until the freeze point.
@@ -392,19 +399,19 @@ Aspect Part_Of
==============
.. index:: Part_Of
-This aspect is equivalent to pragma `Part_Of`.
+This aspect is equivalent to :ref:`pragma Part_Of<Pragma-Part_Of>`.
Aspect Persistent_BSS
=====================
.. index:: Persistent_BSS
-This boolean aspect is equivalent to pragma `Persistent_BSS`.
+This boolean aspect is equivalent to :ref:`pragma Persistent_BSS<Pragma-Persistent_BSS>`.
Aspect Predicate
================
.. index:: Predicate
-This aspect is equivalent to pragma `Predicate`. It is thus
+This aspect is equivalent to :ref:`pragma Predicate<Pragma-Predicate>`. It is thus
similar to the language defined aspects `Dynamic_Predicate`
and `Static_Predicate` except that whether the resulting
predicate is static or dynamic is controlled by the form of the
@@ -415,70 +422,76 @@ Aspect Pure_Function
====================
.. index:: Pure_Function
-This boolean aspect is equivalent to pragma `Pure_Function`.
+This boolean aspect is equivalent to :ref:`pragma Pure_Function<Pragma-Pure_Function>`.
Aspect Refined_Depends
======================
.. index:: Refined_Depends
-This aspect is equivalent to pragma `Refined_Depends`.
+This aspect is equivalent to :ref:`pragma Refined_Depends<Pragma-Refined_Depends>`.
Aspect Refined_Global
=====================
.. index:: Refined_Global
-This aspect is equivalent to pragma `Refined_Global`.
+This aspect is equivalent to :ref:`pragma Refined_Global<Pragma-Refined_Global>`.
Aspect Refined_Post
===================
.. index:: Refined_Post
-This aspect is equivalent to pragma `Refined_Post`.
+This aspect is equivalent to :ref:`pragma Refined_Post<Pragma-Refined_Post>`.
Aspect Refined_State
====================
.. index:: Refined_State
-This aspect is equivalent to pragma `Refined_State`.
+This aspect is equivalent to :ref:`pragma Refined_State<Pragma-Refined_State>`.
Aspect Remote_Access_Type
=========================
.. index:: Remote_Access_Type
-This aspect is equivalent to pragma `Remote_Access_Type`.
+This aspect is equivalent to :ref:`pragma Remote_Access_Type<Pragma-Remote_Access_Type>`.
+
+Aspect Secondary_Stack_Size
+===========================
+
+.. index:: Secondary_Stack_Size
+
+This aspect is equivalent to :ref:`pragma Secondary_Stack_Size<Pragma-Secondary_Stack_Size>`.
+
Aspect Scalar_Storage_Order
===========================
.. index:: Scalar_Storage_Order
-This aspect is equivalent to a `Scalar_Storage_Order`
-attribute definition clause.
+This aspect is equivalent to a :ref:`attribute Scalar_Storage_Order<Attribute-Scalar_Storage_Order>`.
Aspect Shared
=============
.. index:: Shared
-This boolean aspect is equivalent to pragma `Shared`,
+This boolean aspect is equivalent to :ref:`pragma Shared<Pragma-Shared>`
and is thus a synonym for aspect `Atomic`.
Aspect Simple_Storage_Pool
==========================
.. index:: Simple_Storage_Pool
-This aspect is equivalent to a `Simple_Storage_Pool`
-attribute definition clause.
+This aspect is equivalent to :ref:`attribute Simple_Storage_Pool<Attribute_Simple_Storage_Pool>`.
Aspect Simple_Storage_Pool_Type
===============================
.. index:: Simple_Storage_Pool_Type
-This boolean aspect is equivalent to pragma `Simple_Storage_Pool_Type`.
+This boolean aspect is equivalent to :ref:`pragma Simple_Storage_Pool_Type<Pragma-Simple_Storage_Pool_Type>`.
Aspect SPARK_Mode
=================
.. index:: SPARK_Mode
-This aspect is equivalent to pragma `SPARK_Mode` and
+This aspect is equivalent to :ref:`pragma SPARK_Mode<Pragma-SPARK_Mode>` and
may be specified for either or both of the specification and body
of a subprogram or package.
@@ -486,49 +499,49 @@ Aspect Suppress_Debug_Info
==========================
.. index:: Suppress_Debug_Info
-This boolean aspect is equivalent to pragma `Suppress_Debug_Info`.
+This boolean aspect is equivalent to :ref:`pragma Suppress_Debug_Info<Pragma-Suppress_Debug_Info>`.
Aspect Suppress_Initialization
==============================
.. index:: Suppress_Initialization
-This boolean aspect is equivalent to pragma `Suppress_Initialization`.
+This boolean aspect is equivalent to :ref:`pragma Suppress_Initialization<Pragma-Suppress_Initialization>`.
Aspect Test_Case
================
.. index:: Test_Case
-This aspect is equivalent to pragma `Test_Case`.
+This aspect is equivalent to :ref:`pragma Test_Case<Pragma-Test_Case>`.
Aspect Thread_Local_Storage
===========================
.. index:: Thread_Local_Storage
-This boolean aspect is equivalent to pragma `Thread_Local_Storage`.
+This boolean aspect is equivalent to :ref:`pragma Thread_Local_Storage<Pragma-Thread_Local_Storage>`.
Aspect Universal_Aliasing
=========================
.. index:: Universal_Aliasing
-This boolean aspect is equivalent to pragma `Universal_Aliasing`.
+This boolean aspect is equivalent to :ref:`pragma Universal_Aliasing<Pragma-Universal_Aliasing>`.
Aspect Universal_Data
=====================
.. index:: Universal_Data
-This aspect is equivalent to pragma `Universal_Data`.
+This aspect is equivalent to :ref:`pragma Universal_Data<Pragma-Universal_Data>`.
Aspect Unmodified
=================
.. index:: Unmodified
-This boolean aspect is equivalent to pragma `Unmodified`.
+This boolean aspect is equivalent to :ref:`pragma Unmodified<Pragma-Unmodified>`.
Aspect Unreferenced
===================
.. index:: Unreferenced
-This boolean aspect is equivalent to pragma `Unreferenced`. Note that
+This boolean aspect is equivalent to :ref:`pragma Unreferenced<Pragma-Unreferenced>`. Note that
in the case of formal parameters, it is not permitted to have aspects for
a formal parameter, so in this case the pragma form must be used.
@@ -536,31 +549,30 @@ Aspect Unreferenced_Objects
===========================
.. index:: Unreferenced_Objects
-This boolean aspect is equivalent to pragma `Unreferenced_Objects`.
+This boolean aspect is equivalent to :ref:`pragma Unreferenced_Objects<Pragma-Unreferenced_Objects>`.
Aspect Value_Size
=================
.. index:: Value_Size
-This aspect is equivalent to a `Value_Size`
-attribute definition clause.
+This aspect is equivalent to :ref:`attribute Value_Size<Attribute-Value_Size>`.
Aspect Volatile_Full_Access
===========================
.. index:: Volatile_Full_Access
-This boolean aspect is equivalent to pragma `Volatile_Full_Access`.
+This boolean aspect is equivalent to :ref:`pragma Volatile_Full_Access<Pragma-Volatile_Full_Access>`.
Aspect Volatile_Function
===========================
.. index:: Volatile_Function
-This boolean aspect is equivalent to pragma `Volatile_Function`.
+This boolean aspect is equivalent to :ref:`pragma Volatile_Function<Pragma-Volatile_Function>`.
Aspect Warnings
===============
.. index:: Warnings
-This aspect is equivalent to the two argument form of pragma `Warnings`,
+This aspect is equivalent to the two argument form of :ref:`pragma Warnings<Pragma_Warnings>`,
where the first argument is `ON` or `OFF` and the second argument
is the entity.
diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst
index 601ca78e6a..c813afd597 100644
--- a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst
@@ -404,6 +404,21 @@ Attribute Fast_Math
prefix) yields a static Boolean value that is True if pragma
`Fast_Math` is active, and False otherwise.
+Attribute Finalization_Size
+===========================
+.. index:: Finalization_Size
+
+The prefix of attribute `Finalization_Size` must be an object or
+a non-class-wide type. This attribute returns the size of any hidden data
+reserved by the compiler to handle finalization-related actions. The type of
+the attribute is `universal_integer`.
+
+`Finalization_Size` yields a value of zero for a type with no controlled
+parts, an object whose type has no controlled parts, or an object of a
+class-wide type whose tag denotes a type with no controlled parts.
+
+Note that only heap-allocated objects contain finalization data.
+
Attribute Fixed_Value
=====================
.. index:: Fixed_Value
@@ -670,6 +685,8 @@ passed for a record or other composite object passed by reference.
There is no way of indicating this without the `Null_Parameter`
attribute.
+.. _Attribute-Object_Size:
+
Attribute Object_Size
=====================
.. index:: Size, used for objects
@@ -901,6 +918,8 @@ The `Safe_Small` attribute is provided for compatibility with Ada 83. See
the Ada 83 reference manual for an exact description of the semantics of
this attribute.
+.. _Attribute-Scalar_Storage_Order:
+
Attribute Scalar_Storage_Order
==============================
.. index:: Endianness
@@ -962,10 +981,7 @@ types. This may be overridden for the derived type by giving an explicit scalar
storage order for the derived type. For a record extension, the derived type
must have the same scalar storage order as the parent type.
-If a component of `T` is of a record or array type, then that type must
-also have a `Scalar_Storage_Order` attribute definition clause.
-
-A component of a record or array type that is a packed array, or that
+A component of a record or array type that is a bit-packed array, or that
does not start on a byte boundary, must have the same scalar storage order
as the enclosing record or array type.
@@ -1001,6 +1017,11 @@ inheritance in the case of a derived type), then the default is normally
the native ordering of the target, but this default can be overridden using
pragma `Default_Scalar_Storage_Order`.
+Note that if a component of `T` is itself of a record or array type,
+the specfied `Scalar_Storage_Order` does *not* apply to that nested type:
+an explicit attribute definition clause must be provided for the component
+type as well if desired.
+
Note that the scalar storage order only affects the in-memory data
representation. It has no effect on the representation used by stream
attributes.
@@ -1556,6 +1577,8 @@ typical machines). In addition `'VADS_Size` applied to an object
gives the result that would be obtained by applying the attribute to
the corresponding type.
+.. _Attribute-Value_Size:
+
Attribute Value_Size
====================
.. index:: Size, setting for not-first subtype
diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
index 2c76213278..b243c8ed1c 100644
--- a/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_defined_pragmas.rst
@@ -37,6 +37,8 @@ the effect of deferring aborts for the sequence of statements (but not
for the declarations or handlers, if any, associated with this statement
sequence).
+.. _Pragma-Abstract_State:
+
Pragma Abstract_State
=====================
@@ -194,7 +196,7 @@ Ada 83, Ada 95, or Ada 2005 programs.
The one argument form, which is not a configuration pragma,
is used for managing the transition from Ada
2005 to Ada 2012 in the run-time library. If an entity is marked
-as Ada_201 only, then referencing the entity in any pre-Ada_2012
+as Ada_2012 only, then referencing the entity in any pre-Ada_2012
mode will generate a warning. In addition, in any pre-Ada_2012
mode, a preference rule is established which does not choose
such an entity unless it is unambiguously specified. This avoids
@@ -266,6 +268,8 @@ this pragma serves no purpose but is ignored
rather than rejected to allow common sets of sources to be used
in the two situations.
+.. _Pragma-Annotate:
+
Pragma Annotate
===============
@@ -423,7 +427,7 @@ Syntax::
Refined_Post |
Statement_Assertions
- POLICY_IDENTIFIER ::= Check | Disable | Ignore
+ POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
This is a standard Ada 2012 pragma that is available as an
@@ -446,6 +450,8 @@ If the policy is `IGNORE`, then assertions are ignored, i.e.
the corresponding pragma or aspect is deactivated.
This pragma overrides the effect of the *-gnata* switch on the
command line.
+If the policy is `SUPPRESSIBLE`, then assertions are enabled by default,
+however, if the *-gnatp* switch is specified all assertions are ignored.
The implementation defined policy `DISABLE` is like
`IGNORE` except that it completely disables semantic
@@ -549,6 +555,8 @@ values will generally give an exception, though formally the program
is erroneous so there are no guarantees that this will always be the
case, and it is recommended that these two options not be used together.
+.. _Pragma-Async_Readers:
+
Pragma Async_Readers
====================
@@ -561,6 +569,8 @@ Syntax:
For the semantics of this pragma, see the entry for aspect `Async_Readers` in
the SPARK 2014 Reference Manual, section 7.1.2.
+.. _Pragma-Async_Writers:
+
Pragma Async_Writers
====================
@@ -1100,6 +1110,8 @@ If the alignment for a record or array type is not specified (using
pragma `Pack`, pragma `Component_Alignment`, or a record rep
clause), the GNAT uses the default alignment as described previously.
+.. _Pragma-Constant_After_Elaboration:
+
Pragma Constant_After_Elaboration
=================================
@@ -1112,6 +1124,8 @@ Syntax:
For the semantics of this pragma, see the entry for aspect
`Constant_After_Elaboration` in the SPARK 2014 Reference Manual, section 3.3.1.
+.. _Pragma-Contract_Cases:
+
Pragma Contract_Cases
=====================
.. index:: Contract cases
@@ -1366,6 +1380,8 @@ This pragma is standard in Ada 2012, but is available in all earlier
versions of Ada as an implementation-defined pragma.
See Ada 2012 Reference Manual for details.
+.. _Pragma-Default_Initial_Condition:
+
Pragma Default_Initial_Condition
================================
@@ -1513,6 +1529,8 @@ This pragma is standard in Ada 2012, but is available in all earlier
versions of Ada as an implementation-defined pragma.
See Ada 2012 Reference Manual for details.
+.. _Pragma-Depends:
+
Pragma Depends
==============
@@ -1601,6 +1619,8 @@ This pragma is standard in Ada 2012, but is available in all earlier
versions of Ada as an implementation-defined pragma.
See Ada 2012 Reference Manual for details.
+.. _Pragma-Effective_Reads:
+
Pragma Effective_Reads
======================
@@ -1613,6 +1633,8 @@ Syntax:
For the semantics of this pragma, see the entry for aspect `Effective_Reads` in
the SPARK 2014 Reference Manual, section 7.1.2.
+.. _Pragma-Effective_Writes:
+
Pragma Effective_Writes
=======================
@@ -2066,6 +2088,7 @@ of GNAT specific extensions are recognized as follows:
generic types. The result indicates if the corresponding actual
is constrained.
+.. _Pragma-Extensions_Visible:
Pragma Extensions_Visible
=========================
@@ -2212,6 +2235,8 @@ following operations are affected:
must instantiate your own version of `Ada.Numerics.Generic_Complex_Types`
under control of the pragma, rather than use the preinstantiated versions.
+.. _Pragma-Favor_Top_Level:
+
Pragma Favor_Top_Level
======================
@@ -2275,6 +2300,8 @@ be `IEEE_Float` to specify the use of IEEE format, as follows:
*
No other value of digits is permitted.
+.. _Pragma-Ghost:
+
Pragma Ghost
============
@@ -2287,6 +2314,8 @@ Syntax:
For the semantics of this pragma, see the entry for aspect `Ghost` in the SPARK
2014 Reference Manual, section 6.9.
+.. _Pragma-Global:
+
Pragma Global
=============
@@ -2354,7 +2383,7 @@ Syntax:
pragma Implementation_Defined (local_NAME);
-This pragma marks a previously declared entioty as implementation-defined.
+This pragma marks a previously declared entity as implementation-defined.
For an overloaded entity, applies to the most recent homonym.
@@ -2704,6 +2733,8 @@ manipulate separate components in the composite object. This may place
constraints on the representation of the object (for instance prohibiting
tight packing).
+.. _Pragma-Initial_Condition:
+
Pragma Initial_Condition
========================
@@ -2778,6 +2809,8 @@ of stack required, so it is probably a good idea to turn on stack
checking (see description of stack checking in the GNAT
User's Guide) when using this pragma.
+.. _Pragma-Initializes:
+
Pragma Initializes
==================
@@ -2803,6 +2836,8 @@ Syntax:
For the semantics of this pragma, see the entry for aspect `Initializes` in the
SPARK 2014 Reference Manual, section 7.1.5.
+.. _Pragma-Inline_Always:
+
Pragma Inline_Always
====================
@@ -2978,6 +3013,8 @@ Overriding the default state of signals used by the Ada runtime may interfere
with an application's runtime behavior in the cases of the synchronous signals,
and in the case of the signal used to implement the `abort` statement.
+.. _Pragma-Invariant:
+
Pragma Invariant
================
@@ -3245,6 +3282,8 @@ after the Ada run-time environment is shut down.
See `pragma Linker_Constructor` for the set of restrictions that apply
because of these specific contexts.
+.. _Pragma-Linker_Section:
+
Pragma Linker_Section
=====================
@@ -3320,6 +3359,7 @@ section). See also `pragma Persistent_BSS`.
procedure Q with Linker_Section => "Qsection";
end IO_Card;
+.. _Pragma-Lock_Free:
Pragma Lock_Free
================
@@ -3523,6 +3563,19 @@ Syntax::
This pragma is provided for compatibility with OpenVMS VAX Systems. It has
no effect in GNAT, other than being syntax checked.
+Pragma Max_Queue_Length
+=======================
+
+Syntax::
+
+ pragma Max_Entry_Queue (static_integer_EXPRESSION);
+
+
+This pragma is used to specify the maximum callers per entry queue for
+individual protected entries and entry families. It accepts a single
+positive integer as a parameter and must appear after the declaration
+of an entry.
+
Pragma No_Body
==============
@@ -3546,6 +3599,8 @@ such a way that a body needed before is no longer needed. The provision of a
dummy body with a No_Body pragma ensures that there is no interference from
earlier versions of the package body.
+.. _Pragma-No_Elaboration_Code_All:
+
Pragma No_Elaboration_Code_All
==============================
@@ -3648,6 +3703,8 @@ in the :title:`GNAT User's Guide`.
This pragma currently has no effects on access to unconstrained array types.
+.. _Pragma-No_Tagged_Streams:
+
Pragma No_Tagged_Streams
========================
@@ -4143,6 +4200,8 @@ This pragma is standard in Ada 2005, but is available in all earlier
versions of Ada as an implementation-defined pragma.
See Ada 2012 Reference Manual for details.
+.. _Pragma-Part_Of:
+
Pragma Part_Of
==============
@@ -4181,6 +4240,8 @@ optimized. GNAT does not attempt to optimize any tasks in this manner
For more information on the subject of passive tasks, see the section
'Passive Task Optimization' in the GNAT Users Guide.
+.. _Pragma-Persistent_BSS:
+
Pragma Persistent_BSS
=====================
@@ -4484,6 +4545,43 @@ aspects, but is prepared to ignore the pragmas. The assertion
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
@@ -4568,6 +4666,8 @@ use of the pragma identifier `Check`. Historically, pragma
Ada 2012, and has been retained in its original form for
compatibility purposes.
+.. _Pragma-Predicate:
+
Pragma Predicate
================
@@ -4889,6 +4989,9 @@ is defined in the following sections.
The ``Simple_Barriers`` restriction has been replaced by
``Pure_Barriers``.
+ The ``Max_Protected_Entries``, ``Max_Entry_Queue_Length``, and
+ ``No_Relative_Delay`` restrictions have been removed.
+
* Pragma Profile (Restricted)
This profile corresponds to the GNAT restricted run time. It
@@ -5002,6 +5105,8 @@ Syntax:
This pragma is identical in effect to pragma `Common_Object`.
+.. _Pragma-Pure_Function:
+
Pragma Pure_Function
====================
@@ -5106,6 +5211,8 @@ compatibility purposes. It is equivalent to:
which is the preferred method of setting the `Ravenscar` profile.
+.. _Pragma-Refined_Depends:
+
Pragma Refined_Depends
======================
@@ -5137,6 +5244,8 @@ Syntax:
For the semantics of this pragma, see the entry for aspect `Refined_Depends` in
the SPARK 2014 Reference Manual, section 6.1.5.
+.. _Pragma-Refined_Global:
+
Pragma Refined_Global
=====================
@@ -5160,6 +5269,8 @@ Syntax:
For the semantics of this pragma, see the entry for aspect `Refined_Global` in
the SPARK 2014 Reference Manual, section 6.1.4.
+.. _Pragma-Refined_Post:
+
Pragma Refined_Post
===================
@@ -5172,6 +5283,8 @@ Syntax:
For the semantics of this pragma, see the entry for aspect `Refined_Post` in
the SPARK 2014 Reference Manual, section 7.2.7.
+.. _Pragma-Refined_State:
+
Pragma Refined_State
====================
@@ -5211,6 +5324,8 @@ This pragma is standard in Ada 2005, but is available in all earlier
versions of Ada as an implementation-defined pragma.
See Ada 2012 Reference Manual for details.
+.. _Pragma-Remote_Access_Type:
+
Pragma Remote_Access_Type
=========================
@@ -5410,6 +5525,41 @@ run with various special switches as follows:
comprehensive messages identifying possible problems based on this
information.
+.. _Pragma-Secondary_Stack_Size:
+
+Pragma Secondary_Stack_Size
+===========================
+
+Syntax:
+
+.. code-block:: ada
+
+ pragma Secondary_Stack_Size (integer_EXPRESSION);
+
+This pragma appears within the task definition of a single task declaration
+or a task type declaration (like pragma `Storage_Size`) and applies to all
+task objects of that type. The argument specifies the size of the secondary
+stack to be used by these task objects, and must be of an integer type. The
+secondary stack is used to handle functions that return a variable-sized
+result, for example a function returning an unconstrained String.
+
+Note this pragma only applies to targets using fixed secondary stacks, like
+VxWorks 653 and bare board targets, where a fixed block for the
+secondary stack is allocated from the primary stack of the task. By default,
+these targets assign a percentage of the primary stack for the secondary stack,
+as defined by `System.Parameter.Sec_Stack_Percentage`. With this pragma,
+an `integer_EXPRESSION` of bytes is assigned from the primary stack instead.
+
+For most targets, the pragma does not apply as the secondary stack grows on
+demand: allocated as a chain of blocks in the heap. The default size of these
+blocks can be modified via the `-D` binder option as described in
+:title:`GNAT User's Guide`.
+
+Note that no check is made to see if the secondary stack can fit inside the
+primary stack.
+
+Note the pragma cannot appear when the restriction `No_Secondary_Stack`
+is in effect.
Pragma Share_Generic
====================
@@ -5429,6 +5579,8 @@ no effect in `GNAT` (which does not implement shared generics), other
than to check that the given names are all names of generic units or
generic instances.
+.. _Pragma-Shared:
+
Pragma Shared
=============
@@ -5468,6 +5620,8 @@ Syntax:
This pragma is provided for compatibility with other Ada implementations. It
is recognized but ignored by all current versions of GNAT.
+.. _Pragma-Simple_Storage_Pool_Type:
+
Pragma Simple_Storage_Pool_Type
===============================
.. index:: Storage pool, simple
@@ -5688,6 +5842,8 @@ The second argument must be a string literal, it cannot be a static
string expression other than a string literal. This is because its value
is needed for error messages issued by all phases of the compiler.
+.. _Pragma-SPARK_Mode:
+
Pragma SPARK_Mode
=================
@@ -6047,6 +6203,8 @@ with Rational Ada, where it appears as a program unit pragma.
The use of the standard Ada pragma `Suppress (All_Checks)`
as a normal configuration pragma is the preferred usage in GNAT.
+.. _Pragma-Suppress_Debug_Info:
+
Pragma Suppress_Debug_Info
==========================
@@ -6085,6 +6243,8 @@ usual. It is not required that this pragma be used consistently within
a partition, so it is fine to have some units within a partition compiled
with this pragma and others compiled in normal mode without it.
+.. _Pragma-Suppress_Initialization:
+
Pragma Suppress_Initialization
==============================
.. index:: Suppressing initialization
@@ -6205,6 +6365,8 @@ created, depending on the target. This pragma can appear anywhere a
`Storage_Size` attribute definition clause is allowed for a task
type.
+.. _Pragma-Test_Case:
+
Pragma Test_Case
================
.. index:: Test cases
@@ -6263,6 +6425,8 @@ precondition of the subprogram, and the output context should also satisfy its
postcondition. Mode `Robustness` indicates that the precondition and
postcondition of the subprogram should be ignored for this test case.
+.. _Pragma-Thread_Local_Storage:
+
Pragma Thread_Local_Storage
===========================
.. index:: Task specific storage
@@ -6358,6 +6522,8 @@ does not permit a string parameter, and it is
controlled by the assertion identifier `Type_Invariant`
rather than `Invariant`.
+.. _Pragma-Type_Invariant_Class:
+
Pragma Type_Invariant_Class
===========================
@@ -6482,6 +6648,8 @@ a clean manner.
The abort only happens if code is being generated. Thus you can use
specs of unimplemented packages in syntax or semantic checking mode.
+.. _Pragma-Universal_Aliasing:
+
Pragma Universal_Aliasing
=========================
@@ -6501,6 +6669,8 @@ For a detailed description of the strict aliasing optimization, and the
situations in which it must be suppressed, see the section on
`Optimization and Strict Aliasing` in the :title:`GNAT User's Guide`.
+.. _Pragma-Universal_Data:
+
Pragma Universal_Data
=====================
@@ -6525,6 +6695,8 @@ a library unit pragma, but can also be used as a configuration pragma
of this pragma is also available by applying the -univ switch on the
compilations of units where universal addressing of the data is desired.
+.. _Pragma-Unmodified:
+
Pragma Unmodified
=================
.. index:: Warnings, unmodified
@@ -6557,6 +6729,8 @@ are typically to be used in cases where such warnings are expected.
Thus it is never necessary to use `pragma Unmodified` for such
variables, though it is harmless to do so.
+.. _Pragma-Unreferenced:
+
Pragma Unreferenced
===================
.. index:: Warnings, unreferenced
@@ -6615,6 +6789,8 @@ are typically to be used in cases where such warnings are expected.
Thus it is never necessary to use `pragma Unreferenced` for such
variables, though it is harmless to do so.
+.. _Pragma-Unreferenced_Objects:
+
Pragma Unreferenced_Objects
===========================
.. index:: Warnings, unreferenced
@@ -6735,6 +6911,40 @@ the handling of existing code which depends on the interpretation of Size
as implemented in the VADS compiler. See description of the VADS_Size
attribute for further details.
+.. _Pragma-Unused:
+
+Pragma Unused
+=============
+.. index:: Warnings, unused
+
+Syntax:
+
+
+::
+
+ pragma Unused (LOCAL_NAME {, LOCAL_NAME});
+
+
+This pragma signals that the assignable entities (variables,
+`out` parameters, and `in out` parameters) whose names are listed
+deliberately do not get assigned or referenced in the current source unit
+after the occurrence of the pragma in the current source unit. This
+suppresses warnings about the entities that are unreferenced and/or not
+assigned, and, in addition, a warning will be generated if one of these
+entities gets assigned or subsequently referenced in the same unit as the
+pragma (in the corresponding body or one of its subunits).
+
+This is particularly useful for clearly signaling that a particular
+parameter is not modified or referenced, even though the spec suggests
+that it might be.
+
+For the variable case, warnings are never given for unreferenced
+variables whose name contains one of the substrings
+`DISCARD, DUMMY, IGNORE, JUNK, UNUSED` in any casing. Such names
+are typically to be used in cases where such warnings are expected.
+Thus it is never necessary to use `pragma Unmodified` for such
+variables, though it is harmless to do so.
+
Pragma Validity_Checks
======================
@@ -6812,6 +7022,8 @@ in some Ada 83 compilers, including DEC Ada 83. The Ada 95 / Ada 2005
implementation of pragma Volatile is upwards compatible with the
implementation in DEC Ada 83.
+.. _Pragma-Volatile_Full_Access:
+
Pragma Volatile_Full_Access
===========================
@@ -6844,6 +7056,8 @@ the same object.
It is not permissible to specify `Volatile_Full_Access` for a composite
(record or array) type or object that has at least one `Aliased` component.
+.. _Pragma-Volatile_Function:
+
Pragma Volatile_Function
========================
diff --git a/gcc/ada/doc/gnat_rm/implementation_of_ada_2012_features.rst b/gcc/ada/doc/gnat_rm/implementation_of_ada_2012_features.rst
index 303b425c45..22ef54a959 100644
--- a/gcc/ada/doc/gnat_rm/implementation_of_ada_2012_features.rst
+++ b/gcc/ada/doc/gnat_rm/implementation_of_ada_2012_features.rst
@@ -114,48 +114,48 @@ Supported Aspect Source
================================== ===========
`Ada_2005` -- GNAT
`Ada_2012` -- GNAT
- `Address`
- `Alignment`
- `Atomic`
- `Atomic_Components`
- `Bit_Order`
- `Component_Size`
+ `Address`
+ `Alignment`
+ `Atomic`
+ `Atomic_Components`
+ `Bit_Order`
+ `Component_Size`
`Contract_Cases` -- GNAT
- `Discard_Names`
- `External_Tag`
+ `Discard_Names`
+ `External_Tag`
`Favor_Top_Level` -- GNAT
- `Inline`
+ `Inline`
`Inline_Always` -- GNAT
`Invariant` -- GNAT
- `Machine_Radix`
- `No_Return`
+ `Machine_Radix`
+ `No_Return`
`Object_Size` -- GNAT
- `Pack`
+ `Pack`
`Persistent_BSS` -- GNAT
- `Post`
- `Pre`
- `Predicate`
- `Preelaborable_Initialization`
+ `Post`
+ `Pre`
+ `Predicate`
+ `Preelaborable_Initialization`
`Pure_Function` -- GNAT
`Remote_Access_Type` -- GNAT
`Shared` -- GNAT
- `Size`
- `Storage_Pool`
- `Storage_Size`
- `Stream_Size`
- `Suppress`
+ `Size`
+ `Storage_Pool`
+ `Storage_Size`
+ `Stream_Size`
+ `Suppress`
`Suppress_Debug_Info` -- GNAT
`Test_Case` -- GNAT
`Thread_Local_Storage` -- GNAT
- `Type_Invariant`
- `Unchecked_Union`
+ `Type_Invariant`
+ `Unchecked_Union`
`Universal_Aliasing` -- GNAT
`Unmodified` -- GNAT
`Unreferenced` -- GNAT
`Unreferenced_Objects` -- GNAT
- `Unsuppress`
+ `Unsuppress`
`Value_Size` -- GNAT
- `Volatile`
+ `Volatile`
`Volatile_Components`
`Warnings` -- GNAT
================================== ===========
@@ -436,7 +436,7 @@ Supported Aspect Source
::
(if expr then expr {elsif expr then expr} [else expr])
-
+
The parentheses can be omitted in contexts where parentheses are present
anyway, such as subprogram arguments and pragma arguments. If the **else**
clause is omitted, **else** *True* is assumed;
@@ -500,7 +500,7 @@ Supported Aspect Source
.. code-block:: ada
X := (case Y is when 1 => 2, when 2 => 3, when others => 31)
-
+
RM References: 4.05.07 (0) 4.05.08 (0) 4.09 (12) 4.09 (33)
.. index:: AI-0104 (Ada 2012 feature)
diff --git a/gcc/ada/doc/gnat_rm/interfacing_to_other_languages.rst b/gcc/ada/doc/gnat_rm/interfacing_to_other_languages.rst
index 32403e1990..63fd5ffa34 100644
--- a/gcc/ada/doc/gnat_rm/interfacing_to_other_languages.rst
+++ b/gcc/ada/doc/gnat_rm/interfacing_to_other_languages.rst
@@ -15,9 +15,9 @@ Interfacing to C
Interfacing to C with GNAT can use one of two approaches:
-*
+*
The types in the package `Interfaces.C` may be used.
-*
+*
Standard Ada types may be used directly. This may be less portable to
other compilers, but will work on all GNAT compilers, which guarantee
correspondence between the C and Ada types.
@@ -44,7 +44,7 @@ Ada Type C Type
Additionally, there are the following general correspondences between Ada
and C types:
-*
+*
Ada enumeration types map to C enumeration types directly if pragma
`Convention C` is specified, which causes them to have int
length. Without pragma `Convention C`, Ada enumeration types map to
@@ -53,17 +53,17 @@ and C types:
This is the only case in which pragma `Convention C` affects the
representation of an Ada type.
-*
+*
Ada access types map to C pointers, except for the case of pointers to
unconstrained types in Ada, which have no direct C equivalent.
-*
+*
Ada arrays map directly to C arrays.
-*
+*
Ada records map directly to C structures.
-*
+*
Packed Ada records map to C structures where all members are bit fields
of the length corresponding to the ``type'Size`` value in Ada.
@@ -116,7 +116,7 @@ It is also possible to import a C++ exception using the following syntax:
pragma Import (Cpp,
[Entity =>] LOCAL_NAME,
[External_Name =>] static_string_EXPRESSION);
-
+
The `External_Name` is the name of the C++ RTTI symbol. You can then
cover a specific C++ exception in an exception handler.
@@ -162,4 +162,3 @@ case in which it is possible to import foreign units of this type,
provided that the data items passed are restricted to simple scalar
values or simple record types without variants, or simple array
types with fixed bounds.
-
diff --git a/gcc/ada/doc/gnat_rm/obsolescent_features.rst b/gcc/ada/doc/gnat_rm/obsolescent_features.rst
index f5ea188a34..6c9b61ed70 100644
--- a/gcc/ada/doc/gnat_rm/obsolescent_features.rst
+++ b/gcc/ada/doc/gnat_rm/obsolescent_features.rst
@@ -56,7 +56,7 @@ Syntax
.. code-block:: ada
pragma Task_Info (EXPRESSION);
-
+
This pragma appears within a task definition (like pragma
`Priority`) and applies to the task in which it appears. The
argument must be of type `System.Task_Info.Task_Info_Type`.
diff --git a/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst b/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst
index b9eee2f6c1..0af4ce74cc 100644
--- a/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst
+++ b/gcc/ada/doc/gnat_rm/representation_clauses_and_pragmas.rst
@@ -32,9 +32,9 @@ GNAT requires that all alignment clauses specify a power of 2, and all
default alignments are always a power of 2. The default alignment
values are as follows:
-* *Primitive Types*.
+* *Elementary Types*.
- For primitive types, the alignment is the minimum of the actual size of
+ For elementary types, the alignment is the minimum of the actual size of
objects of the type divided by `Storage_Unit`,
and the maximum alignment supported by the target.
(This maximum alignment is given by the GNAT-specific attribute
@@ -53,10 +53,11 @@ values are as follows:
For arrays, the alignment is equal to the alignment of the component type
for the normal case where no packing or component size is given. If the
array is packed, and the packing is effective (see separate section on
- packed arrays), then the alignment will be one for long packed arrays,
- or arrays whose length is not known at compile time. For short packed
+ packed arrays), then the alignment will be either 4, 2, or 1 for long packed
+ arrays or arrays whose length is not known at compile time, depending on
+ whether the component size is divisible by 4, 2, or is odd. For short packed
arrays, which are handled internally as modular types, the alignment
- will be as described for primitive types, e.g., a packed array of length
+ will be as described for elementary types, e.g. a packed array of length
31 bits will have an object size of four bytes, and an alignment of 4.
* *Records*.
@@ -489,7 +490,7 @@ discrete types are as follows:
The `Object_Size` for base subtypes reflect the natural hardware
size in bits (run the compiler with *-gnatS* to find those values
for numeric types). Enumeration types and fixed-point base subtypes have
- 8, 16, 32 or 64 bits for this size, depending on the range of values
+ 8, 16, 32, or 64 bits for this size, depending on the range of values
to be stored.
*
@@ -789,7 +790,7 @@ restrictions placed on component clauses as follows:
little-endian machines, this must be explicitly programmed. This capability
is not provided by `Bit_Order`.
-* Components that are positioned across byte boundaries
+* Components that are positioned across byte boundaries.
but do not occupy an integral number of bytes. Given that bytes are not
reordered, such fields would occupy a non-contiguous sequence of bits
@@ -1069,22 +1070,23 @@ Pragma Pack for Arrays
.. index:: Pragma Pack (for arrays)
-Pragma `Pack` applied to an array has no effect unless the component type
-is packable. For a component type to be packable, it must be one of the
-following cases:
+Pragma `Pack` applied to an array has an effect that depends upon whether the
+component type is *packable*. For a component type to be *packable*, it must
+be one of the following cases:
-*
- Any scalar type
-*
- Any type whose size is specified with a size clause
-*
- Any packed array type with a static size
-*
- Any record type padded because of its default alignment
+* Any elementary type.
+
+* Any small packed array type with a static size.
+
+* Any small simple record type with a static size.
For all these cases, if the component subtype size is in the range
-1 through 63, then the effect of the pragma `Pack` is exactly as though a
+1 through 64, then the effect of the pragma `Pack` is exactly as though a
component size were specified giving the component subtype size.
+
+All other types are non-packable, they occupy an integral number of storage
+units and the only effect of pragma Pack is to remove alignment gaps.
+
For example if we have:
.. code-block:: ada
@@ -1095,7 +1097,7 @@ For example if we have:
pragma Pack (ar);
Then the component size of `ar` will be set to 5 (i.e., to `r'size`,
-and the size of the array `ar` will be exactly 40 bits.
+and the size of the array `ar` will be exactly 40 bits).
Note that in some cases this rather fierce approach to packing can produce
unexpected effects. For example, in Ada 95 and Ada 2005,
@@ -1184,23 +1186,21 @@ taken by components. We distinguish between *packable* components and
*non-packable* components.
Components of the following types are considered packable:
-*
- Components of a primitive type are packable unless they are aliased
- or of an atomic type.
+* Components of an elementary type are packable unless they are aliased,
+ independent, or of an atomic type.
-*
- Small packed arrays, whose size does not exceed 64 bits, and where the
- size is statically known at compile time, are represented internally
- as modular integers, and so they are also packable.
+* Small packed arrays, where the size is statically known, are represented
+ internally as modular integers, and so they are also packable.
+* Small simple records, where the size is statically known, are also packable.
-All packable components occupy the exact number of bits corresponding to
-their `Size` value, and are packed with no padding bits, i.e., they
-can start on an arbitrary bit boundary.
+For all these cases, if the 'Size value is in the range 1 through 64, the
+components occupy the exact number of bits corresponding to this value
+and are packed with no padding bits, i.e. they can start on an arbitrary
+bit boundary.
-All other types are non-packable, they occupy an integral number of
-storage units, and
-are placed at a boundary corresponding to their alignment requirements.
+All other types are non-packable, they occupy an integral number of storage
+units and the only effect of pragma Pack is to remove alignment gaps.
For example, consider the record
@@ -1331,7 +1331,7 @@ so for example, the following is permitted:
Note: the above rules apply to recent releases of GNAT 5.
In GNAT 3, there are more severe restrictions on larger components.
-For non-primitive types, including packed arrays with a size greater than
+For composite types, including packed arrays with a size greater than
64 bits, component clauses must respect the alignment requirement of the
type, in particular, always starting on a byte boundary, and the length
must be a multiple of the storage unit.
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 f338f0f2f4..78c489b2d1 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
@@ -445,20 +445,6 @@ No_Implicit_Heap_Allocations
[RM D.7] No constructs are allowed to cause implicit heap allocation.
-No_Implicit_Loops
------------------
-.. index:: No_Implicit_Loops
-
-[GNAT] This restriction ensures that the generated code does not contain any
-implicit `for` loops, either by modifying
-the generated code where possible,
-or by rejecting any construct that would otherwise generate an implicit
-`for` loop. If this restriction is active, it is possible to build
-large array aggregates with all static components without generating an
-intermediate temporary, and without generating a loop to initialize individual
-components. Otherwise, a loop is created for arrays larger than about 5000
-scalar components.
-
No_Implicit_Protected_Object_Allocations
----------------------------------------
.. index:: No_Implicit_Protected_Object_Allocations
@@ -524,19 +510,15 @@ No_Multiple_Elaboration
-----------------------
.. index:: No_Multiple_Elaboration
-[GNAT] Normally each package contains a 16-bit counter used to check for access
-before elaboration, and to control multiple elaboration attempts.
-This counter is eliminated for units compiled with the static model
-of elaboration if restriction `No_Elaboration_Code`
-is active but because of
-the need to check for multiple elaboration in the general case, these
-counters cannot be eliminated if elaboration code may be present. The
-restriction `No_Multiple_Elaboration`
-allows suppression of these counters
-in static elaboration units even if they do have elaboration code. If this
-restriction is used, then the situations in which multiple elaboration is
-possible, including non-Ada main programs, and Stand Alone libraries, are not
-permitted, and will be diagnosed by the binder.
+[GNAT] When this restriction is active, we are not requesting control-flow
+preservation with -fpreserve-control-flow, and the static elaboration model is
+used, the compiler is allowed to suppress the elaboration counter normally
+associated with the unit, even if the unit has elaboration code. This counter
+is typically used to check for access before elaboration and to control
+multiple elaboration attempts. If the restriction is used, then the
+situations in which multiple elaboration is possible, including non-Ada main
+programs and Stand Alone libraries, are not permitted and will be diagnosed
+by the binder.
No_Nested_Finalization
----------------------
@@ -602,7 +584,8 @@ No_Secondary_Stack
[GNAT] This restriction ensures at compile time that the generated code
does not contain any reference to the secondary stack. The secondary
stack is used to implement functions returning unconstrained objects
-(arrays or records) on some targets.
+(arrays or records) on some targets. Suppresses the allocation of
+secondary stacks for tasks (excluding the environment task) at run time.
No_Select_Statements
--------------------
@@ -880,6 +863,12 @@ Note that this the implementation of this restriction requires full
code generation. If it is used in conjunction with "semantics only"
checking, then some cases of violations may be missed.
+When this restriction is active, we are not requesting control-flow
+preservation with -fpreserve-control-flow, and the static elaboration model is
+used, the compiler is allowed to suppress the elaboration counter normally
+associated with the unit. This counter is typically used to check for access
+before elaboration and to control multiple elaboration attempts.
+
No_Dynamic_Sized_Objects
------------------------
.. index:: No_Dynamic_Sized_Objects
@@ -967,6 +956,20 @@ Unrestricted_Access is forbidden is that it would require the prefix
to be aliased, and in such cases, it can always be replaced by
the standard attribute Unchecked_Access which is preferable.
+No_Implicit_Loops
+-----------------
+.. index:: No_Implicit_Loops
+
+[GNAT] This restriction ensures that the generated code of the unit marked
+with this restriction does not contain any implicit `for` loops, either by
+modifying the generated code where possible, or by rejecting any construct
+that would otherwise generate an implicit `for` loop. If this restriction is
+active, it is possible to build large array aggregates with all static
+components without generating an intermediate temporary, and without generating
+a loop to initialize individual components. Otherwise, a loop is created for
+arrays larger than about 5000 scalar components. Note that if this restriction
+is set in the spec of a package, it will not apply to its body.
+
No_Obsolescent_Features
-----------------------
.. index:: No_Obsolescent_Features
diff --git a/gcc/ada/doc/gnat_rm/standard_library_routines.rst b/gcc/ada/doc/gnat_rm/standard_library_routines.rst
index 8b8d3c2798..6c9ac9fc49 100644
--- a/gcc/ada/doc/gnat_rm/standard_library_routines.rst
+++ b/gcc/ada/doc/gnat_rm/standard_library_routines.rst
@@ -317,7 +317,7 @@ the unit is not implemented.
The following predefined instantiations of this package are provided:
* ``Short_Float``
-
+
`Ada.Numerics.Short_Complex_Elementary_Functions`
* ``Float``
@@ -706,4 +706,3 @@ the unit is not implemented.
For packages in Interfaces and System, all the RM defined packages are
available in GNAT, see the Ada 2012 RM for full details.
-
diff --git a/gcc/ada/doc/gnat_rm/the_gnat_library.rst b/gcc/ada/doc/gnat_rm/the_gnat_library.rst
index 6220bc2800..57607fe8bd 100644
--- a/gcc/ada/doc/gnat_rm/the_gnat_library.rst
+++ b/gcc/ada/doc/gnat_rm/the_gnat_library.rst
@@ -930,7 +930,7 @@ obtaining information about exceptions provided by Ada 83 compilers.
.. index:: Memory corruption debugging
Provide a debugging storage pools that helps tracking memory corruption
-problems.
+problems.
See `The GNAT Debug_Pool Facility` section in the :title:`GNAT User's Guide`.
.. _`GNAT.Debug_Utilities_(g-debuti.ads)`:
@@ -1735,6 +1735,18 @@ introduction to the binding contents and use.
SSE vector types for use with SSE related intrinsics.
+.. _`GNAT.String_Hash(g-strhas.ads)`:
+
+`GNAT.String_Hash` (:file:`g-strhas.ads`)
+=========================================
+
+.. index:: GNAT.String_Hash (g-strhas.ads)
+
+.. index:: Hash functions
+
+Provides a generic hash function working on arrays of scalars. Both the scalar
+type and the hash result type are parameters.
+
.. _`GNAT.Strings_(g-string.ads)`:
`GNAT.Strings` (:file:`g-string.ads`)
@@ -1984,6 +1996,21 @@ This package provides a limited binding to the VxWorks API.
In particular, it interfaces with the
VxWorks hardware interrupt facilities.
+.. _`Interfaces.VxWorks.Int_Connection_(i-vxinco.ads)`:
+
+`Interfaces.VxWorks.Int_Connection` (:file:`i-vxinco.ads`)
+==========================================================
+
+.. index:: Interfaces.VxWorks.Int_Connection (i-vxinco.ads)
+
+.. index:: Interfacing to VxWorks
+
+.. index:: VxWorks, interfacing
+
+This package provides a way for users to replace the use of
+intConnect() with a custom routine for installing interrupt
+handlers.
+
.. _`Interfaces.VxWorks.IO_(i-vxwoio.ads)`:
`Interfaces.VxWorks.IO` (:file:`i-vxwoio.ads`)
@@ -2228,4 +2255,3 @@ This package provides definitions and descriptions of
the various methods used for encoding wide characters
in ordinary strings. These definitions are used by
the package `System.Wch_Cnv`.
-
diff --git a/gcc/ada/doc/gnat_rm/the_implementation_of_standard_i_o.rst b/gcc/ada/doc/gnat_rm/the_implementation_of_standard_i_o.rst
index 3d39876c2d..e04fb9a335 100644
--- a/gcc/ada/doc/gnat_rm/the_implementation_of_standard_i_o.rst
+++ b/gcc/ada/doc/gnat_rm/the_implementation_of_standard_i_o.rst
@@ -39,37 +39,37 @@ Standard I/O Packages
The Standard I/O packages described in Annex A for
-*
+*
Ada.Text_IO
-*
+*
Ada.Text_IO.Complex_IO
-*
+*
Ada.Text_IO.Text_Streams
-*
+*
Ada.Wide_Text_IO
-*
+*
Ada.Wide_Text_IO.Complex_IO
-*
+*
Ada.Wide_Text_IO.Text_Streams
-*
+*
Ada.Wide_Wide_Text_IO
-*
+*
Ada.Wide_Wide_Text_IO.Complex_IO
-*
+*
Ada.Wide_Wide_Text_IO.Text_Streams
-*
+*
Ada.Stream_IO
-*
+*
Ada.Sequential_IO
-*
+*
Ada.Direct_IO
are implemented using the C
library streams facility; where
-*
+*
All files are opened using `fopen`.
-*
+*
All input/output operations use `fread`/`fwrite`.
There is no internal buffering of any kind at the Ada library level. The only
@@ -94,7 +94,7 @@ The format of a FORM string in GNAT is:
::
"keyword=value,keyword=value,...,keyword=value"
-
+
where letters may be in upper or lower case, and there are no spaces
between values. The order of the entries is not important. Currently
@@ -107,7 +107,7 @@ the following keywords defined.
SHARED=[YES|NO]
WCEM=[n|h|u|s|e|8|b]
ENCODING=[UTF8|8BITS]
-
+
The use of these parameters is described later in this section. If an
unrecognized keyword appears in a form string, it is silently ignored
@@ -173,7 +173,7 @@ arrays. For example, the following will raise `Data_Error`:
IO.Read (F, S);
Put_Line (S);
-
+
On some Ada implementations, this will print `hell`, but the program is
clearly incorrect, since there is only one element in the file, and that
@@ -196,21 +196,21 @@ special control characters:
LF (line feed, 16#0A#) Line Mark
FF (form feed, 16#0C#) Page Mark
-
+
A canonical Text_IO file is defined as one in which the following
conditions are met:
-*
+*
The character `LF` is used only as a line mark, i.e., to mark the end
of the line.
-*
+*
The character `FF` is used only as a page mark, i.e., to mark the
end of a page and consequently can appear only immediately following a
`LF` (line mark) character.
-*
+*
The file ends with either `LF` (line mark) or `LF`-`FF`
(line mark, page mark). In the former case, the page mark is implicitly
assumed to be present.
@@ -229,16 +229,16 @@ Manual, and all the routines in Text_IO are fully implemented.
A text file that does not meet the requirements for a canonical Text_IO
file has one of the following:
-*
+*
The file contains `FF` characters not immediately following a
`LF` character.
-*
+*
The file contains `LF` or `FF` characters written by
`Put` or `Put_Line`, which are not logically considered to be
line marks or page marks.
-*
+*
The file ends in a character other than `LF` or `FF`,
i.e., there is no explicit line mark or page mark at the end of the file.
@@ -260,14 +260,14 @@ is being read. No internal buffering occurs in Text_IO, and usually the
physical position in the stream used to implement the file corresponds
to this logical position defined by Text_IO. There are two exceptions:
-*
+*
After a call to `End_Of_Page` that returns `True`, the stream
is positioned past the `LF` (line mark) that precedes the page
mark. Text_IO maintains an internal flag so that subsequent read
operations properly handle the logical position which is unchanged by
the `End_Of_Page` call.
-*
+*
After a call to `End_Of_File` that returns `True`, if the
Text_IO file was positioned before the line mark at the end of file
before the call, then the logical position is unchanged, but the stream
@@ -298,19 +298,19 @@ marks. Any `Ascii.FF` characters (the character normally used for a
page mark) appearing in the file are considered to be data
characters. In particular:
-*
+*
`Get_Line` and `Skip_Line` do not test for a page mark
following a line mark. If a page mark appears, it will be treated as a
data character.
-*
+*
This avoids the need to wait for an extra character to be typed or
entered from the pipe to complete one of these operations.
-*
+*
`End_Of_Page` always returns `False`
-*
+*
`End_Of_File` will return `False` if there is a page mark at
the end of the file.
@@ -440,7 +440,7 @@ specified using a FORM parameter:
::
WCEM=`x`
-
+
as part of the FORM string (WCEM = wide character encoding method),
where `x` is one of the following characters
@@ -477,7 +477,7 @@ being brackets encoding if no coding method was specified with -gnatW).
::
ESC a b c d
-
+
..
where `a`, `b`, `c`, `d` are the four hexadecimal
@@ -524,7 +524,7 @@ being brackets encoding if no coding method was specified with -gnatW).
16#0000#-16#007f#: 2#0xxxxxxx#
16#0080#-16#07ff#: 2#110xxxxx# 2#10xxxxxx#
16#0800#-16#ffff#: 2#1110xxxx# 2#10xxxxxx# 2#10xxxxxx#
-
+
..
where the `xxx` bits correspond to the left-padded bits of the
@@ -545,7 +545,7 @@ being brackets encoding if no coding method was specified with -gnatW).
::
[ " a b c d " ]
-
+
..
where `a`, `b`, `c`, `d` are the four hexadecimal
@@ -590,7 +590,7 @@ being brackets encoding if no coding method was specified with -gnatW).
::
Start of output ["5B"]first run]
-
+
..
In practice brackets encoding is reasonably useful for normal Put_Line use
@@ -623,7 +623,7 @@ normal lower ASCII set (i.e., a character in the range:
.. code-block:: ada
Wide_Character'Val (16#0080#) .. Wide_Character'Val (16#FFFF#)
-
+
then although the logical position of the file pointer is unchanged by
the `Look_Ahead` call, the stream is physically positioned past the
@@ -658,7 +658,7 @@ specified using a FORM parameter:
::
WCEM=`x`
-
+
as part of the FORM string (WCEM = wide character encoding method),
where `x` is one of the following characters
@@ -701,7 +701,7 @@ being brackets encoding if no coding method was specified with -gnatW).
16#000080#-16#0007ff#: 2#110xxxxx# 2#10xxxxxx#
16#000800#-16#00ffff#: 2#1110xxxx# 2#10xxxxxx# 2#10xxxxxx#
16#010000#-16#10ffff#: 2#11110xxx# 2#10xxxxxx# 2#10xxxxxx# 2#10xxxxxx#
-
+
..
where the `xxx` bits correspond to the left-padded bits of the
@@ -719,7 +719,7 @@ being brackets encoding if no coding method was specified with -gnatW).
::
[ " a b c d " ]
-
+
..
and by the following ten character sequence if not
@@ -728,7 +728,7 @@ being brackets encoding if no coding method was specified with -gnatW).
::
[ " a b c d e f " ]
-
+
..
where `a`, `b`, `c`, `d`, `e`, and `f`
@@ -767,7 +767,7 @@ normal lower ASCII set (i.e., a character in the range:
.. code-block:: ada
Wide_Wide_Character'Val (16#0080#) .. Wide_Wide_Character'Val (16#10FFFF#)
-
+
then although the logical position of the file pointer is unchanged by
the `Look_Ahead` call, the stream is physically positioned past the
@@ -798,11 +798,11 @@ written to the file as described in the Ada Reference Manual. The type
`Stream_Element` is simply a byte. There are two ways to read or
write a stream file.
-*
+*
The operations `Read` and `Write` directly read or write a
sequence of stream elements with no control information.
-*
+*
The stream attributes applied to a stream file transfer data in the
manner described for stream attributes.
@@ -816,7 +816,7 @@ passed to Text_IO.Create and Text_IO.Open. ``Text_Translation=xxx``
has no effect on Unix systems. Possible values are:
-*
+*
``Yes`` or ``Text`` is the default, which means to
translate LF to/from CR/LF on Windows systems.
@@ -825,15 +825,15 @@ has no effect on Unix systems. Possible values are:
may be used to create Unix-style files on
Windows.
-*
+*
``wtext`` translation enabled in Unicode mode.
(corresponds to _O_WTEXT).
-*
+*
``u8text`` translation enabled in Unicode UTF-8 mode.
(corresponds to O_U8TEXT).
-*
+*
``u16text`` translation enabled in Unicode UTF-16
mode. (corresponds to_O_U16TEXT).
@@ -851,21 +851,21 @@ To provide a full range of functionality, while at the same time
minimizing the problems of portability caused by this implementation
dependence, GNAT handles file sharing as follows:
-*
+*
In the absence of a ``shared=xxx`` form parameter, an attempt
to open two or more files with the same full name is considered an error
and is not supported. The exception `Use_Error` will be
raised. Note that a file that is not explicitly closed by the program
remains open until the program terminates.
-*
+*
If the form parameter ``shared=no`` appears in the form string, the
file can be opened or created with its own separate stream identifier,
regardless of whether other files sharing the same external file are
opened. The exact effect depends on how the C stream routines handle
multiple accesses to the same external files using separate streams.
-*
+*
If the form parameter ``shared=yes`` appears in the form string for
each of two or more files opened using the same full name, the same
stream is shared between these files, and the semantics are as described
@@ -905,11 +905,11 @@ Filenames encoding
An encoding form parameter can be used to specify the filename
encoding ``encoding=xxx``.
-*
+*
If the form parameter ``encoding=utf8`` appears in the form string, the
filename must be encoded in UTF-8.
-*
+*
If the form parameter ``encoding=8bits`` appears in the form
string, the filename must be a standard 8bits string.
@@ -979,7 +979,7 @@ using the mode shown in the following table:
+----------------------------+---------------+------------------+
| Inout_File | "r+" | "w+" |
+----------------------------+---------------+------------------+
-
+
If text file translation is required, then either ``b`` or ``t``
is added to the mode, depending on the setting of Text. Text file
@@ -1153,7 +1153,7 @@ access to the C library functions for operations on C streams:
-- Maximum length of an allowable full path name on the
-- system, including a terminating NUL character.
end Interfaces.C_Streams;
-
+
.. _Interfacing_to_C_Streams:
@@ -1231,7 +1231,7 @@ operations.
C_Stream : in Interfaces.C_Streams.FILEs;
Form : in String := "");
end Ada.Stream_IO.C_Streams;
-
+
In each of these six packages, the `C_Stream` function obtains the
`FILE` pointer from a currently opened Ada file. It is then
@@ -1249,4 +1249,3 @@ The `Open` procedures in these packages open a file giving an
existing C Stream instead of a file name. Typically this stream is
imported from a C program, allowing an Ada file to operate on an
existing C file.
-
diff --git a/gcc/ada/doc/gnat_ugn.rst b/gcc/ada/doc/gnat_ugn.rst
index 7892160b47..d6d2ba9756 100644
--- a/gcc/ada/doc/gnat_ugn.rst
+++ b/gcc/ada/doc/gnat_ugn.rst
@@ -42,8 +42,6 @@ included in the section entitled :ref:`gnu_fdl`.
gnat_ugn/getting_started_with_gnat
gnat_ugn/the_gnat_compilation_model
gnat_ugn/building_executable_programs_with_gnat
- gnat_ugn/gnat_project_manager
- gnat_ugn/tools_supporting_project_files
gnat_ugn/gnat_utility_programs
gnat_ugn/gnat_and_program_execution
diff --git a/gcc/ada/doc/gnat_ugn/about_this_guide.rst b/gcc/ada/doc/gnat_ugn/about_this_guide.rst
index 467d3366b6..079b20ba31 100644
--- a/gcc/ada/doc/gnat_ugn/about_this_guide.rst
+++ b/gcc/ada/doc/gnat_ugn/about_this_guide.rst
@@ -37,12 +37,6 @@ This guide contains the following chapters:
main GNAT tools to build executable programs, and it also gives examples of
using the GNU make utility with GNAT.
-* :ref:`GNAT_Project_Manager` describes how to use project files
- to organize large projects.
-
-* :ref:`Tools_Supporting_Project_Files` described how to use the project
- facility in conjunction with various GNAT tools.
-
* :ref:`GNAT_Utility_Programs` explains the various utility programs that
are included in the GNAT environment
@@ -51,11 +45,11 @@ This guide contains the following chapters:
with GNAT
Appendices cover several additional topics:
-
+
* :ref:`Platform_Specific_Information` describes the different run-time
library implementations and also presents information on how to use
GNAT on several specific platforms
-
+
* :ref:`Example_of_Binder_Output_File` shows the source code for the binder
output file for a sample program.
@@ -142,7 +136,7 @@ the new document structure.
* :ref:`GNAT_Utility_Programs` is a new chapter consolidating the information about several
GNAT tools:
-
+
.. only:: PRO or GPL
- :ref:`The_File_Cleanup_Utility_gnatclean`
@@ -155,7 +149,7 @@ the new document structure.
- :ref:`The_GNAT_Pretty-Printer_gnatpp`
- :ref:`The_Body_Stub_Generator_gnatstub`
- :ref:`The_Unit_Test_Generator_gnattest`
-
+
.. only:: FSF
- :ref:`The_File_Cleanup_Utility_gnatclean`
@@ -212,7 +206,7 @@ in this guide:
::
and then shown this way.
-
+
* Commands that are entered by the user are shown as preceded by a prompt string
comprising the ``$`` character followed by a space.
@@ -220,4 +214,3 @@ in this guide:
as the directory separator; e.g., :file:`parent-dir/subdir/myfile.adb`.
If you are using GNAT on a Windows platform, please note that
the '\\' character should be used instead.
-
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 c6344132ab..5b8d930bf7 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
@@ -27,6 +27,15 @@ Finally, this chapter provides examples of
how to make use of the general GNU make mechanism
in a GNAT context (see :ref:`Using_the_GNU_make_Utility`).
+.. only:: PRO or GPL
+
+ For building large systems with components possibly written
+ in different languages (such as Ada, C, C++ and Fortran)
+ and organized into subsystems and libraries, the GPRbuild
+ tool can be used. This tool, and the Project Manager
+ facility that it is based upon, is described in
+ *GPRbuild and GPR Companion Tools User's Guide*.
+
.. _The_GNAT_Make_Program_gnatmake:
@@ -67,8 +76,9 @@ changes to the source program cause corresponding changes in
dependencies, they will always be tracked exactly correctly by
*gnatmake*.
-Note that for advanced description of project structure, we recommend creating
-a project file as explained in :ref:`GNAT_Project_Manager` and use the
+Note that for advanced forms of project structure, we recommend creating
+a project file as explained in the *GNAT_Project_Manager* chapter in the
+*GPRbuild User's Guide*, and using the
*gprbuild* tool which supports building with project files and works similarly
to *gnatmake*.
@@ -516,6 +526,8 @@ You may specify any of the following switches to *gnatmake*:
:samp:`-P{project}`
Use project file `project`. Only one such switch can be used.
+
+.. -- Comment:
:ref:`gnatmake_and_Project_Files`.
@@ -545,8 +557,10 @@ You may specify any of the following switches to *gnatmake*:
:samp:`-u`
Unique. Recompile at most the main files. It implies -c. Combined with
-f, it is equivalent to calling the compiler directly. Note that using
- -u with a project file and no main has a special meaning
- (:ref:`Project_Files_and_Main_Subprograms`).
+ -u with a project file and no main has a special meaning.
+
+.. --Comment:
+ (See :ref:`Project_Files_and_Main_Subprograms`.)
.. index:: -U (gnatmake)
@@ -1431,9 +1445,7 @@ Alphabetical List of All Switches
*-gnatc* as a builder switch (before *-cargs* or in package
Builder of the project file) then *gnatmake* will not fail because
it will not look for the object files after compilation, and it will not try
- to build and link. This switch may not be given if a previous `-gnatR`
- switch has been given, since `-gnatR` requires that the code generator
- be called to complete determination of representation information.
+ to build and link.
.. index:: -gnatC (gcc)
@@ -1462,7 +1474,7 @@ Alphabetical List of All Switches
:samp:`-gnatD`
Create expanded source files for source level debugging. This switch
- also suppress generation of cross-reference information
+ also suppresses generation of cross-reference information
(see *-gnatx*). Note that this switch is not allowed if a previous
-gnatR switch has been given, since these two switches are not compatible.
@@ -1903,8 +1915,8 @@ Alphabetical List of All Switches
.. index:: -gnatn (gcc)
:samp:`-gnatn[12]`
- Activate inlining for subprograms for which pragma `Inline` is
- specified. This inlining is performed by the GCC back-end. An optional
+ Activate inlining across modules for subprograms for which pragma `Inline`
+ is specified. This inlining is performed by the GCC back-end. An optional
digit sets the inlining level: 1 for moderate inlining across modules
or 2 for full inlining across modules. If no inlining level is specified,
the compiler will pick it based on the optimization level.
@@ -3055,11 +3067,10 @@ of the pragma in the :title:`GNAT_Reference_manual`).
.. index:: Hiding of Declarations
- This switch activates warnings on hiding declarations.
- A declaration is considered hiding
- if it is for a non-overloadable entity, and it declares an entity with the
- same name as some other entity that is directly or use-visible. The default
- is that such warnings are not generated.
+ This switch activates warnings on hiding declarations that are considered
+ potentially confusing. Not all cases of hiding cause warnings; for example an
+ overriding declaration hides an implicit declaration, which is just normal
+ code. The default is that warnings on hiding are not generated.
.. index:: -gnatwH (gcc)
@@ -5404,16 +5415,16 @@ Subprogram Inlining Control
.. index:: -gnatn (gcc)
:samp:`-gnatn[12]`
- The `n` here is intended to suggest the first syllable of the
- word 'inline'.
- GNAT recognizes and processes `Inline` pragmas. However, for the
- inlining to actually occur, optimization must be enabled and, in order
- to enable inlining of subprograms specified by pragma `Inline`,
+ The `n` here is intended to suggest the first syllable of the word 'inline'.
+ GNAT recognizes and processes `Inline` pragmas. However, for inlining to
+ actually occur, optimization must be enabled and, by default, inlining of
+ subprograms across modules is not performed. If you want to additionally
+ enable inlining of subprograms specified by pragma `Inline` across modules,
you must also specify this switch.
- In the absence of this switch, GNAT does not attempt
- inlining and does not need to access the bodies of
- subprograms for which `pragma Inline` is specified if they are not
- in the current unit.
+
+ In the absence of this switch, GNAT does not attempt inlining across modules
+ and does not access the bodies of subprograms for which `pragma Inline` is
+ specified if they are not in the current unit.
You can optionally specify the inlining level: 1 for moderate inlining across
modules, which is a good compromise between compilation times and performances
@@ -5646,7 +5657,7 @@ Debugging Control
you to do source level debugging using the generated code which is
sometimes useful for complex code, for example to find out exactly
which part of a complex construction raised an exception. This switch
- also suppress generation of cross-reference information (see
+ also suppresses generation of cross-reference information (see
*-gnatx*) since otherwise the cross-reference information
would refer to the :file:`.dg` file, which would cause
confusion since this is not the original source file.
@@ -5714,12 +5725,6 @@ Debugging Control
this case, the component clause uses an obvious extension of permitted
Ada syntax, for example `at 0 range 0 .. -1`.
- Representation information requires that code be generated (since it is the
- code generator that lays out complex data structures). If an attempt is made
- to output representation information when no code is generated, for example
- when a subunit is compiled on its own, then no information can be generated
- and the compiler outputs a message to this effect.
-
.. index:: -gnatS (gcc)
@@ -5888,6 +5893,21 @@ there is no point in using *-m* switches to improve performance
unless you actually see a performance improvement.
+.. _Linker_Switches:
+
+Linker Switches
+===============
+
+Linker switches can be specified after :samp:`-largs` builder switch.
+
+.. index:: -fuse-ld=name
+
+:samp:`-fuse-ld={name}`
+ Linker to be used. The default is ``bfd`` for :file:`ld.bfd`,
+ the alternative being ``gold`` for :file:`ld.gold`. The later is
+ a more recent and faster linker, but only available on GNU/Linux
+ platforms.
+
.. _Binding_with_gnatbind:
Binding with `gnatbind`
@@ -6100,10 +6120,12 @@ be presented in subsequent sections.
blocks (whose size is the minimum of the default secondary stack size value,
and the actual size needed for the current allocation request).
- For certain targets, notably VxWorks 653,
- the secondary stack is allocated by carving off a fixed ratio chunk of the
- primary task stack. The -D option is used to define the
- size of the environment task's secondary stack.
+ For certain targets, notably VxWorks 653 and bare board targets,
+ the secondary stack is allocated by carving off a chunk of the primary task
+ stack. By default this is a fixed percentage of the primary task stack as
+ defined by System.Parameter.Sec_Stack_Percentage. This can be overridden per
+ task using the Secondary_Stack_Size pragma/aspect. The -D option is used to
+ define the size of the environment task's secondary stack.
.. index:: -e (gnatbind)
@@ -6138,6 +6160,11 @@ be presented in subsequent sections.
Currently the same as `-Ea`.
+.. index:: -f (gnatbind)
+
+:samp:`-f{elab-order}`
+ Force elaboration order.
+
.. index:: -F (gnatbind)
:samp:`-F`
@@ -6587,6 +6614,47 @@ The following switches provide additional control over the elaboration
order. For full details see :ref:`Elaboration_Order_Handling_in_GNAT`.
+.. index:: -f (gnatbind)
+
+:samp:`-f{elab-order}`
+ Force elaboration order.
+
+ `elab-order` should be the name of a "forced elaboration order file", that
+ is, a text file containing library item names, one per line. A name of the
+ form "some.unit%s" or "some.unit (spec)" denotes the spec of Some.Unit. A
+ name of the form "some.unit%b" or "some.unit (body)" denotes the body of
+ Some.Unit. Each pair of lines is taken to mean that there is an elaboration
+ dependence of the second line on the first. For example, if the file
+ contains:
+
+ .. code-block:: ada
+
+ this (spec)
+ this (body)
+ that (spec)
+ that (body)
+
+ then the spec of This will be elaborated before the body of This, and the
+ body of This will be elaborated before the spec of That, and the spec of That
+ will be elaborated before the body of That. The first and last of these three
+ dependences are already required by Ada rules, so this file is really just
+ forcing the body of This to be elaborated before the spec of That.
+
+ The given order must be consistent with Ada rules, or else `gnatbind` will
+ give elaboration cycle errors. For example, if you say x (body) should be
+ elaborated before x (spec), there will be a cycle, because Ada rules require
+ x (spec) to be elaborated before x (body); you can't have the spec and body
+ both elaborated before each other.
+
+ If you later add "with That;" to the body of This, there will be a cycle, in
+ which case you should erase either "this (body)" or "that (spec)" from the
+ above forced elaboration order file.
+
+ Blank lines and Ada-style comments are ignored. Unit names that do not exist
+ in the program are ignored. Units in the GNAT predefined library are also
+ ignored.
+
+
.. index:: -p (gnatbind)
:samp:`-p`
diff --git a/gcc/ada/doc/gnat_ugn/elaboration_order_handling_in_gnat.rst b/gcc/ada/doc/gnat_ugn/elaboration_order_handling_in_gnat.rst
index 90b64a7f17..1e96e31111 100644
--- a/gcc/ada/doc/gnat_ugn/elaboration_order_handling_in_gnat.rst
+++ b/gcc/ada/doc/gnat_ugn/elaboration_order_handling_in_gnat.rst
@@ -75,7 +75,7 @@ of that unit before elaborating the unit doing the |withing|:
with Unit_1;
package Unit_2 is ...
-
+
would require that both the body and spec of `Unit_1` be elaborated
before the spec of `Unit_2`. However, a rule like that would be far too
restrictive. In particular, it would make it impossible to have routines
@@ -94,7 +94,7 @@ of the body of `Unit_1`:
.. code-block:: ada
Sqrt_1 : Float := Sqrt (0.1);
-
+
The elaboration code of the body of `Unit_1` also contains:
.. code-block:: ada
@@ -111,7 +111,7 @@ the body `Unit_2`:
.. code-block:: ada
Sqrt_2 : Float := Sqrt (0.1);
-
+
The elaboration code of the body of `Unit_2` also contains:
.. code-block:: ada
@@ -119,7 +119,7 @@ The elaboration code of the body of `Unit_2` also contains:
if expression_2 = 2 then
Q := Unit_1.Func_1;
end if;
-
+
Now the question is, which of the following orders of elaboration is
acceptable:
@@ -129,7 +129,7 @@ acceptable:
Spec of Unit_2
Body of Unit_1
Body of Unit_2
-
+
or
::
@@ -138,7 +138,7 @@ or
Spec of Unit_1
Body of Unit_2
Body of Unit_1
-
+
If you carefully analyze the flow here, you will see that you cannot tell
at compile time the answer to this question.
If `expression_1` is not equal to 1,
@@ -378,7 +378,7 @@ order of elaboration of the servers on which they depend:
Unit A |withs| unit B and calls B.Func in elab code
Unit B |withs| unit C, and B.Func calls C.Func
-
+
Now if we put a pragma `Elaborate (B)`
in unit `A`, this ensures that the
@@ -481,14 +481,14 @@ example writing:
.. code-block:: ada
function One return Float;
-
+
Q : Float := One;
-
+
function One return Float is
begin
return 1.0;
end One;
-
+
will obviously raise `Program_Error` at run time, because function
One will be called before its body is elaborated. In this case GNAT will
generate a warning that the call will raise `Program_Error`::
@@ -510,7 +510,7 @@ generate a warning that the call will raise `Program_Error`::
11. begin
12. null;
13. end;
-
+
Note that in this particular case, it is likely that the call is safe, because
the function `One` does not access any global variables.
@@ -527,7 +527,7 @@ would prevent this reordering, and if we write:
.. code-block:: ada
function One return Float;
-
+
function One return Float is
begin
return 1.0;
@@ -586,7 +586,7 @@ raised at the point of the call. Let's look at the warning::
13. begin
14. null;
15. end;
-
+
Note that the message here says 'may raise', instead of the direct case,
where the message says 'will be raised'. That's because whether
@@ -677,7 +677,7 @@ Consider the following:
begin
...
end Main;
-
+
where `Main` is the main program. When this program is executed, the
elaboration code must first be executed, and one of the jobs of the
binder is to determine the order in which the units of a program are
@@ -813,7 +813,7 @@ switch, then the compiler outputs an information message::
|
>>> info: call to "r" may raise Program_Error
>>> info: missing pragma Elaborate_All for "k"
-
+
4. end;
and these messages can be used as a guide for supplying manually
@@ -840,7 +840,7 @@ the *-gnatE* switch on the compiler (*gcc* or
.. code-block:: ada
pragma Elaboration_Checks (DYNAMIC);
-
+
Either approach will cause the unit affected to be compiled using the
standard dynamic run-time elaboration checks described in the Ada
Reference Manual. The static model is generally preferable, since it
@@ -976,7 +976,7 @@ the following example
begin
Decls.Lib_Task.Start;
end;
-
+
If the above example is compiled in the default static elaboration
mode, then a circularity occurs. The circularity comes from the call
`Utils.Put_Val` in the task body of `Decls.Lib_Task`. Since
@@ -1112,7 +1112,7 @@ We have four possible answers to this question:
begin
Decls1.Lib_Task.Start;
end;
-
+
All we have done is to split `Decls` into two packages, one
containing the library task, and one containing everything else. Now
@@ -1179,7 +1179,7 @@ We have four possible answers to this question:
begin
Declst.Lib_Task.Start;
end;
-
+
What we have done here is to replace the `task` declaration in
package `Decls` with a `task type` declaration. Then we
@@ -1227,7 +1227,7 @@ We have four possible answers to this question:
.. code-block:: ada
pragma Restrictions (No_Entry_Calls_In_Elaboration_Code);
-
+
This pragma can be placed in the :file:`gnat.adc` file in the usual
manner. If we take our original unmodified program and compile it
in the presence of a :file:`gnat.adc` containing the above pragma,
@@ -1288,7 +1288,7 @@ similar to that in the following example::
warning: "x.ads" has dynamic elaboration checks and with's
warning: "y.ads" which has static elaboration checks
-
+
These warnings indicate that the rule has been violated, and that as a result
elaboration checks may be missed in the resulting executable file.
This warning may be suppressed using the *-ws* binder switch
@@ -1456,7 +1456,7 @@ Faced with a circularity of this kind, you have three different options.
begin
Ada.Text_IO.Put_Line(Pack1.X1'Img); -- 101
end Proc3;
-
+
In the absence of any pragmas, an attempt to bind this program produces
the following diagnostics::
@@ -1473,7 +1473,7 @@ Faced with a circularity of this kind, you have three different options.
info: "pack2 (spec)"
info: which is withed by:
info: "pack1 (body)"
-
+
The sources of the circularity are the two calls to `Pack2.Pure` and
`Pack2.F2` in the body of `Pack1`. We can see that the call to
F2 is safe, even though F2 calls F1, because the call appears after the
@@ -1541,19 +1541,24 @@ fall back to run-time checks; premature calls to any primitive
operation of a tagged type before the body of the operation has been
elaborated will raise `Program_Error`.
-Access-to-subprogram types, however, are handled conservatively, and
-do not require run-time checks. This was not true in earlier versions
-of the compiler; you can use the *-gnatd.U* debug switch to
-revert to the old behavior if the new conservative behavior causes
-elaboration cycles. Here, 'conservative' means that if you do
-`P'Access` during elaboration, the compiler will assume that you
-might call `P` indirectly during elaboration, so it adds an
-implicit `pragma Elaborate_All` on the library unit containing
-`P`. The *-gnatd.U* switch is safe if you know there are
-no such calls. If the program worked before, it will continue to work
-with *-gnatd.U*. But beware that code modifications such as
-adding an indirect call can cause erroneous behavior in the presence
-of *-gnatd.U*.
+Access-to-subprogram types, however, are handled conservatively in many
+cases. This was not true in earlier versions of the compiler; you can use
+the *-gnatd.U* debug switch to revert to the old behavior if the new
+conservative behavior causes elaboration cycles. Here, 'conservative' means
+that if you do `P'Access` during elaboration, the compiler will normally
+assume that you might call `P` indirectly during elaboration, so it adds an
+implicit `pragma Elaborate_All` on the library unit containing `P`. The
+*-gnatd.U* switch is safe if you know there are no such calls. If the
+program worked before, it will continue to work with *-gnatd.U*. But beware
+that code modifications such as adding an indirect call can cause erroneous
+behavior in the presence of *-gnatd.U*.
+
+These implicit Elaborate_All pragmas are not added in all cases, because
+they cause elaboration cycles in certain common code patterns. If you want
+even more conservative handling of P'Access, you can use the *-gnatd.o*
+switch.
+
+See `debug.adb` for documentation on the *-gnatd...* debug switches.
.. _Summary_of_Procedures_for_Elaboration_Control:
@@ -1564,7 +1569,7 @@ Summary of Procedures for Elaboration Control
.. index:: Elaboration control
First, compile your program with the default options, using none of
-the special elaboration control switches. If the binder successfully
+the special elaboration-control switches. If the binder successfully
binds your program, then you can be confident that, apart from issues
raised by the use of access-to-subprogram types and dynamic dispatching,
the program is free of elaboration errors. If it is important that the
@@ -1621,7 +1626,7 @@ requirements. Consider this example:
package Init_Constants is
procedure P; --* require a body*
end Init_Constants;
-
+
with Constants;
package body Init_Constants is
procedure P is begin null; end;
@@ -1641,7 +1646,7 @@ requirements. Consider this example:
begin
Put_Line (Calc.Z'Img);
end Main;
-
+
In this example, there is more than one valid order of elaboration. For
example both the following are correct orders::
@@ -1654,13 +1659,13 @@ example both the following are correct orders::
and
::
-
+
Init_Constants spec
- Init_Constants body
Constants spec
+ Init_Constants body
Calc spec
Main body
-
+
There is no language rule to prefer one or the other, both are correct
from an order of elaboration point of view. But the programmatic effects
of the two orders are very different. In the first, the elaboration routine
@@ -1684,7 +1689,7 @@ case, that could have been achieved by adding to the spec of Calc:
.. code-block:: ada
pragma Elaborate_All (Constants);
-
+
which requires that the body (if any) and spec of `Constants`,
as well as the body and spec of any unit |withed| by
`Constants` be elaborated before `Calc` is elaborated.
@@ -1698,7 +1703,7 @@ compilers can choose different orders.
However, GNAT does attempt to diagnose the common situation where there
are uninitialized variables in the visible part of a package spec, and the
corresponding package body has an elaboration block that directly or
-indirectly initialized one or more of these variables. This is the situation
+indirectly initializes one or more of these variables. This is the situation
in which a pragma Elaborate_Body is usually desirable, and GNAT will generate
a warning that suggests this addition if it detects this situation.
@@ -1719,7 +1724,7 @@ following output:
$ gnatmake -f -q main -bargs -p
$ main
0
-
+
It is of course quite unlikely that both these results are correct, so
it is up to you in a case like this to investigate the source of the
difference, by looking at the two elaboration orders that are chosen,
@@ -1768,7 +1773,7 @@ the last part of the file:`b~xxx.adb` binder output file. Here is an example::
Ada.Text_Io'Elab_Spec;
Ada.Text_Io'Elab_Body;
E07 := True;
-
+
Here Elab_Spec elaborates the spec
and Elab_Body elaborates the body. The assignments to the :samp:`E{xx}` flags
flag that the corresponding body is now elaborated.
diff --git a/gcc/ada/doc/gnat_ugn/example_of_binder_output.rst b/gcc/ada/doc/gnat_ugn/example_of_binder_output.rst
index b2c34c0b82..4e78164a0c 100644
--- a/gcc/ada/doc/gnat_ugn/example_of_binder_output.rst
+++ b/gcc/ada/doc/gnat_ugn/example_of_binder_output.rst
@@ -727,7 +727,7 @@ Comments have been added for clarification purposes.
-- END Object file/option list
end ada_main;
-
+
The Ada code in the above example is exactly what is generated by the
binder. We have added comments to more clearly indicate the function
@@ -743,8 +743,7 @@ you can place a breakpoint on the call:
.. code-block:: ada
Ada.Text_Io'Elab_Body;
-
+
and trace the elaboration routine for this package to find out where
the problem might be (more usually of course you would be debugging
elaboration code in your own application).
-
diff --git a/gcc/ada/doc/gnat_ugn/getting_started_with_gnat.rst b/gcc/ada/doc/gnat_ugn/getting_started_with_gnat.rst
index fcfb07875e..f34b701ac0 100644
--- a/gcc/ada/doc/gnat_ugn/getting_started_with_gnat.rst
+++ b/gcc/ada/doc/gnat_ugn/getting_started_with_gnat.rst
@@ -75,7 +75,7 @@ as the command prompt in the examples in this document):
.. code-block:: sh
$ gcc -c hello.adb
-
+
*gcc* is the command used to run the compiler. This compiler is
capable of compiling programs in several languages, including Ada and
@@ -273,4 +273,3 @@ Ada make tools, *gnatmake* does not rely on the dependencies that were
found by the compiler on a previous compilation, which may possibly
be wrong when sources change. *gnatmake* determines the exact set of
dependencies from scratch each time it is run.
-
diff --git a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst
index a1094e567c..37c077e92d 100644
--- a/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst
+++ b/gcc/ada/doc/gnat_ugn/gnat_and_program_execution.rst
@@ -1740,10 +1740,9 @@ following conditions are met:
.. index:: Inline
* Any one of the following applies: `pragma Inline` is applied to the
- subprogram and the *-gnatn* switch is specified; the
- subprogram is local to the unit and called once from within it; the
- subprogram is small and optimization level *-O2* is specified;
- optimization level *-O3* is specified.
+ subprogram; the subprogram is local to the unit and called once from
+ within it; the subprogram is small and optimization level *-O2* is
+ specified; optimization level *-O3* is specified.
Calls to subprograms in |withed| units are normally not inlined.
To achieve actual inlining (that is, replacement of the call by the code
@@ -1755,8 +1754,6 @@ in the body of the subprogram), the following conditions must all be true:
and not contain something that *gcc* cannot support in inlined
subprograms.
-* The call appears in a body (not in a package spec).
-
* There is a `pragma Inline` for the subprogram.
* The *-gnatn* switch is used on the command line.
@@ -1806,7 +1803,7 @@ additional dependencies.
.. index:: -fno-inline (gcc)
Note: The *-fno-inline* switch overrides all other conditions and ensures that
-no inlining occurs, unless requested with pragma Inline_Always for gcc
+no inlining occurs, unless requested with pragma Inline_Always for *gcc*
back-ends. The extra dependences resulting from *-gnatn* will still be active,
even if this switch is used to suppress the resulting inlining actions.
@@ -2605,6 +2602,14 @@ appropriate options.
subprograms and helps the compiler to create a smaller executable for your
program.
+ *gnatelim* is a project-aware tool.
+ (See :ref:`Using_Project_Files_with_GNAT_Tools` for a description of
+ the project-related switches but note that *gnatelim* does not support
+ the :samp:`-U`, :samp:`-U {main_unit}`, :samp:`--subdirs={dir}`, or
+ :samp:`--no_objects_dir` switches.)
+ The project file package that can specify
+ *gnatelim* switches is named ``Eliminate``.
+
.. _About_gnatelim:
About `gnatelim`
@@ -2790,8 +2795,6 @@ appropriate options.
indicate that the analysed set of sources is incomplete to make up a
partition and that some subprogram bodies are missing are not generated.
- Note: to invoke *gnatelim* with a project file, use the `gnat`
- driver (see :ref:`The_GNAT_Driver_and_Project_Files`).
.. _Processing_Precompiled_Libraries:
@@ -3088,7 +3091,7 @@ The three modes are:
Note that these modes apply only to the evaluation of predefined
arithmetic, membership, and comparison operators for signed integer
-aritmetic.
+arithmetic.
For fixed-point arithmetic, checks can be suppressed. But if checks
are enabled
diff --git a/gcc/ada/doc/gnat_ugn/gnat_project_manager.rst b/gcc/ada/doc/gnat_ugn/gnat_project_manager.rst
deleted file mode 100644
index 87269d8b31..0000000000
--- a/gcc/ada/doc/gnat_ugn/gnat_project_manager.rst
+++ /dev/null
@@ -1,4887 +0,0 @@
-.. |with| replace:: *with*
-.. |withs| replace:: *with*\ s
-.. |withed| replace:: *with*\ ed
-.. |withing| replace:: *with*\ ing
-
-.. -- Example: A |withing| unit has a |with| clause, it |withs| a |withed| unit
-
-
-.. _GNAT_Project_Manager:
-
-********************
-GNAT Project Manager
-********************
-
-
-.. _GNAT_Project_Manager_Introduction:
-
-Introduction
-============
-
-This chapter describes GNAT's *Project Manager*, a facility that allows
-you to manage complex builds involving a number of source files, directories,
-and options for different system configurations. In particular,
-project files allow you to specify:
-
-* The directory or set of directories containing the source files, and/or the
- names of the specific source files themselves
-* The directory in which the compiler's output
- (:file:`ALI` files, object files, tree files, etc.) is to be placed
-* The directory in which the executable programs are to be placed
-* Switch settings for any of the project-enabled tools;
- you can apply these settings either globally or to individual compilation units.
-* The source files containing the main subprogram(s) to be built
-* The source programming language(s)
-* Source file naming conventions; you can specify these either globally or for
- individual compilation units (see :ref:`Naming_Schemes`).
-* Change any of the above settings depending on external values, thus enabling
- the reuse of the projects in various **scenarios** (see :ref:`Scenarios_in_Projects`).
-* Automatically build libraries as part of the build process
- (see :ref:`Library_Projects`).
-
-
-Project files are written in a syntax close to that of Ada, using familiar
-notions such as packages, context clauses, declarations, default values,
-assignments, and inheritance (see :ref:`Project_File_Reference`).
-
-Project files can be built hierarchically from other project files, simplifying
-complex system integration and project reuse (see :ref:`Organizing_Projects_into_Subsystems`).
-
-* One project can import other projects containing needed source files.
- More generally, the Project Manager lets you structure large development
- efforts into hierarchical subsystems, where build decisions are delegated
- to the subsystem level, and thus different compilation environments
- (switch settings) used for different subsystems.
-* You can organize GNAT projects in a hierarchy: a child project
- can extend a parent project, inheriting the parent's source files and
- optionally overriding any of them with alternative versions
- (see :ref:`Project_Extension`).
-
-
-Several tools support project files, generally in addition to specifying
-the information on the command line itself). They share common switches
-to control the loading of the project (in particular
-:samp:`-P{projectfile}` and
-:samp:`-X{vbl}={value}`).
-
-The Project Manager supports a wide range of development strategies,
-for systems of all sizes. Here are some typical practices that are
-easily handled:
-
-* Using a common set of source files and generating object files in different
- directories via different switch settings. It can be used for instance, for
- generating separate sets of object files for debugging and for production.
-* Using a mostly-shared set of source files with different versions of
- some units or subunits. It can be used for instance, for grouping and hiding
- all OS dependencies in a small number of implementation units.
-
-Project files can be used to achieve some of the effects of a source
-versioning system (for example, defining separate projects for
-the different sets of sources that comprise different releases) but the
-Project Manager is independent of any source configuration management tool
-that might be used by the developers.
-
-The various sections below introduce the different concepts related to
-projects. Each section starts with examples and use cases, and then goes into
-the details of related project file capabilities.
-
-.. _Building_With_Projects:
-
-Building With Projects
-======================
-
-In its simplest form, a unique project is used to build a single executable.
-This section concentrates on such a simple setup. Later sections will extend
-this basic model to more complex setups.
-
-The following concepts are the foundation of project files, and will be further
-detailed later in this documentation. They are summarized here as a reference.
-
-**Project file**:
- A text file using an Ada-like syntax, generally using the :file:`.gpr`
- extension. It defines build-related characteristics of an application.
- The characteristics include the list of sources, the location of those
- sources, the location for the generated object files, the name of
- the main program, and the options for the various tools involved in the
- build process.
-
-
-**Project attribute**:
- A specific project characteristic is defined by an attribute clause. Its
- value is a string or a sequence of strings. All settings in a project
- are defined through a list of predefined attributes with precise
- semantics. See :ref:`Attributes`.
-
-
-**Package in a project**:
- Global attributes are defined at the top level of a project.
- Attributes affecting specific tools are grouped in a
- package whose name is related to tool's function. The most common
- packages are `Builder`, `Compiler`, `Binder`,
- and `Linker`. See :ref:`Packages`.
-
-
-**Project variables**:
- In addition to attributes, a project can use variables to store intermediate
- values and avoid duplication in complex expressions. It can be initialized
- with a value coming from the environment.
- A frequent use of variables is to define scenarios.
- See :ref:`External_Values`, :ref:`Scenarios_in_Projects`, and :ref:`Variables`.
-
-
-**Source files** and **source directories**:
- A source file is associated with a language through a naming convention. For
- instance, `foo.c` is typically the name of a C source file;
- `bar.ads` or `bar.1.ada` are two common naming conventions for a
- file containing an Ada spec. A compilation unit is often composed of a main
- source file and potentially several auxiliary ones, such as header files in C.
- The naming conventions can be user defined :ref:`Naming_Schemes`, and will
- drive the builder to call the appropriate compiler for the given source file.
- Source files are searched for in the source directories associated with the
- project through the **Source_Dirs** attribute. By default, all the files (in
- these source directories) following the naming conventions associated with the
- declared languages are considered to be part of the project. It is also
- possible to limit the list of source files using the **Source_Files** or
- **Source_List_File** attributes. Note that those last two attributes only
- accept basenames with no directory information.
-
-
-**Object files** and **object directory**:
- An object file is an intermediate file produced by the compiler from a
- compilation unit. It is used by post-compilation tools to produce
- final executables or libraries. Object files produced in the context of
- a given project are stored in a single directory that can be specified by the
- **Object_Dir** attribute. In order to store objects in
- two or more object directories, the system must be split into
- distinct subsystems with their own project file.
-
-
-The following subsections introduce gradually all the attributes of interest
-for simple build needs. Here is the simple setup that will be used in the
-following examples.
-
-The Ada source files :file:`pack.ads`, :file:`pack.adb`, and :file:`proc.adb` are in
-the :file:`common/` directory. The file :file:`proc.adb` contains an Ada main
-subprogram `Proc` that |withs| package `Pack`. We want to compile
-these source files with the switch
-*-O2*, and put the resulting files in
-the directory :file:`obj/`.
-
-::
-
- common/
- pack.ads
- pack.adb
- proc.adb
- common/obj/
- proc.ali, proc.o pack.ali, pack.o
-
-
-Our project is to be called *Build*. The name of the
-file is the name of the project (case-insensitive) with the
-:file:`.gpr` extension, therefore the project file name is :file:`build.gpr`. This
-is not mandatory, but a warning is issued when this convention is not followed.
-
-This is a very simple example, and as stated above, a single project
-file is enough for it. We will thus create a new file, that for now
-should contain the following code:
-
-.. code-block:: gpr
-
- project Build is
- end Build;
-
-
-.. _Source_Files_and_Directories:
-
-Source Files and Directories
-----------------------------
-
-When you create a new project, the first thing to describe is how to find the
-corresponding source files. These are the only settings that are needed by all
-the tools that will use this project (builder, compiler, binder and linker for
-the compilation, IDEs to edit the source files,...).
-
-.. index:: Source directories (GNAT Project Manager)
-
-The first step is to declare the source directories, which are the directories
-to be searched to find source files. In the case of the example,
-the :file:`common` directory is the only source directory.
-
-.. index:: Source_Dirs (GNAT Project Manager)
-
-There are several ways of defining source directories:
-
-* When the attribute **Source_Dirs** is not used, a project contains a
- single source directory which is the one where the project file itself
- resides. In our example, if :file:`build.gpr` is placed in the :file:`common`
- directory, the project has the needed implicit source directory.
-
-* The attribute **Source_Dirs** can be set to a list of path names, one
- for each of the source directories. Such paths can either be absolute
- names (for instance :file:`"/usr/local/common/"` on UNIX), or relative to the
- directory in which the project file resides (for instance "." if
- :file:`build.gpr` is inside :file:`common/`, or "common" if it is one level up).
- Each of the source directories must exist and be readable.
-
- .. index:: portability of path names (GNAT Project Manager)
-
- The syntax for directories is platform specific. For portability, however,
- the project manager will always properly translate UNIX-like path names to
- the native format of the specific platform. For instance, when the same
- project file is to be used both on Unix and Windows, "/" should be used as
- the directory separator rather than "\\".
-
-* The attribute **Source_Dirs** can automatically include subdirectories
- using a special syntax inspired by some UNIX shells. If any of the paths in
- the list ends with ":file:`**`", then that path and all its subdirectories
- (recursively) are included in the list of source directories. For instance,
- :file:`**` and :file:`./**` represent the complete directory tree rooted at
- the directory in which the project file resides.
-
- .. index:: Source directories (GNAT Project Manager)
-
- .. index:: Excluded_Source_Dirs (GNAT Project Manager)
-
- When using that construct, it can sometimes be convenient to also use the
- attribute **Excluded_Source_Dirs**, which is also a list of paths. Each entry
- specifies a directory whose immediate content, not including subdirs, is to
- be excluded. It is also possible to exclude a complete directory subtree
- using the "**" notation.
-
- .. index:: Ignore_Source_Sub_Dirs (GNAT Project Manager)
-
- It is often desirable to remove, from the source directories, directory
- subtrees rooted at some subdirectories. An example is the subdirectories
- created by a Version Control System such as Subversion that creates directory
- subtrees rooted at subdirectories ".svn". To do that, attribute
- **Ignore_Source_Sub_Dirs** can be used. It specifies the list of simple
- file names for the roots of these undesirable directory subtrees.
-
-
- .. code-block:: gpr
-
- for Source_Dirs use ("./**");
- for Ignore_Source_Sub_Dirs use (".svn");
-
-
-When applied to the simple example, and because we generally prefer to have
-the project file at the toplevel directory rather than mixed with the sources,
-we will create the following file
-
-
-.. code-block:: gpr
-
- build.gpr
- project Build is
- for Source_Dirs use ("common"); -- <<<<
- end Build;
-
-
-Once source directories have been specified, one may need to indicate
-source files of interest. By default, all source files present in the source
-directories are considered by the project manager. When this is not desired,
-it is possible to specify the list of sources to consider explicitly.
-In such a case, only source file base names are indicated and not
-their absolute or relative path names. The project manager is in charge of
-locating the specified source files in the specified source directories.
-
-* By default, the project manager searches for all source files of all
- specified languages in all the source directories.
-
- Since the project manager was initially developed for Ada environments, the
- default language is usually Ada and the above project file is complete: it
- defines without ambiguity the sources composing the project: that is to say,
- all the sources in subdirectory "common" for the default language (Ada) using
- the default naming convention.
-
- .. index:: Languages (GNAT Project Manager)
-
- However, when compiling a multi-language application, or a pure C
- application, the project manager must be told which languages are of
- interest, which is done by setting the **Languages** attribute to a list of
- strings, each of which is the name of a language.
-
- .. index:: Naming scheme (GNAT Project Manager)
-
- Even when using only Ada, the default naming might not be suitable. Indeed,
- how does the project manager recognizes an "Ada file" from any other
- file? Project files can describe the naming scheme used for source files,
- and override the default (see :ref:`Naming_Schemes`). The default is the
- standard GNAT extension (:file:`.adb` for bodies and :file:`.ads` for
- specs), which is what is used in our example, explaining why no naming scheme
- is explicitly specified.
- See :ref:`Naming_Schemes`.
-
- .. index:: Source_Files (GNAT Project Manager)
-
-* `Source_Files`.
- In some cases, source directories might contain files that should not be
- included in a project. One can specify the explicit list of file names to
- be considered through the **Source_Files** attribute.
- When this attribute is defined, instead of looking at every file in the
- source directories, the project manager takes only those names into
- consideration reports errors if they cannot be found in the source
- directories or does not correspond to the naming scheme.
-
-* For various reasons, it is sometimes useful to have a project with no
- sources (most of the time because the attributes defined in the project
- file will be reused in other projects, as explained in
- :ref:`Organizing_Projects_into_Subsystems`. To do this, the attribute
- *Source_Files* is set to the empty list, i.e. `()`. Alternatively,
- *Source_Dirs* can be set to the empty list, with the same
- result.
-
- .. index:: Source_List_File (GNAT Project Manager)
-
-* `Source_List_File`.
- If there is a great number of files, it might be more convenient to use
- the attribute **Source_List_File**, which specifies the full path of a file.
- This file must contain a list of source file names (one per line, no
- directory information) that are searched as if they had been defined
- through *Source_Files*. Such a file can easily be created through
- external tools.
-
- A warning is issued if both attributes `Source_Files` and
- `Source_List_File` are given explicit values. In this case, the
- attribute `Source_Files` prevails.
-
- .. index:: Excluded_Source_Files (GNAT Project Manager)
- .. index:: Locally_Removed_Files (GNAT Project Manager)
- .. index:: Excluded_Source_List_File (GNAT Project Manager)
-
-* `Excluded_Source_Files`.
- Specifying an explicit list of files is not always convenient.It might be
- more convenient to use the default search rules with specific exceptions.
- This can be done thanks to the attribute **Excluded_Source_Files**
- (or its synonym **Locally_Removed_Files**).
- Its value is the list of file names that should not be taken into account.
- This attribute is often used when extending a project,
- see :ref:`Project_Extension`. A similar attribute
- **Excluded_Source_List_File** plays the same
- role but takes the name of file containing file names similarly to
- `Source_List_File`.
-
-
-In most simple cases, such as the above example, the default source file search
-behavior provides the expected result, and we do not need to add anything after
-setting `Source_Dirs`. The project manager automatically finds
-:file:`pack.ads`, :file:`pack.adb`, and :file:`proc.adb` as source files of the
-project.
-
-Note that by default a warning is issued when a project has no sources attached
-to it and this is not explicitly indicated in the project file.
-
-.. _Duplicate_Sources_in_Projects:
-
-Duplicate Sources in Projects
------------------------------
-
-If the order of the source directories is known statically, that is if
-`"/**"` is not used in the string list `Source_Dirs`, then there may
-be several files with the same name sitting in different directories of the
-project. In this case, only the file in the first directory is considered as a
-source of the project and the others are hidden. If `"/**"` is used in the
-string list `Source_Dirs`, it is an error to have several files with the
-same name in the same directory `"/**"` subtree, since there would be an
-ambiguity as to which one should be used. However, two files with the same name
-may exist in two single directories or directory subtrees. In this case, the
-one in the first directory or directory subtree is a source of the project.
-
-If there are two sources in different directories of the same `"/**"`
-subtree, one way to resolve the problem is to exclude the directory of the
-file that should not be used as a source of the project.
-
-.. _Object_and_Exec_Directory:
-
-Object and Exec Directory
--------------------------
-
-The next step when writing a project is to indicate where the compiler should
-put the object files. In fact, the compiler and other tools might create
-several different kind of files (for GNAT, there is the object file and the ALI
-file for instance). One of the important concepts in projects is that most
-tools may consider source directories as read-only and do not attempt to create
-new or temporary files there. Instead, all files are created in the object
-directory. It is of course not true for project-aware IDEs, whose purpose it is
-to create the source files.
-
-.. index:: Object_Dir (GNAT Project Manager)
-
-The object directory is specified through the **Object_Dir** attribute.
-Its value is the path to the object directory, either absolute or
-relative to the directory containing the project file. This
-directory must already exist and be readable and writable, although
-some tools have a switch to create the directory if needed (See
-the switch `-p` for *gprbuild*).
-
-If the attribute `Object_Dir` is not specified, it defaults to
-the project directory, that is the directory containing the project file.
-
-For our example, we can specify the object dir in this way:
-
-.. code-block:: gpr
-
- project Build is
- for Source_Dirs use ("common");
- for Object_Dir use "obj"; -- <<<<
- end Build;
-
-As mentioned earlier, there is a single object directory per project. As a
-result, if you have an existing system where the object files are spread across
-several directories, you can either move all of them into the same directory if
-you want to build it with a single project file, or study the section on
-subsystems (see :ref:`Organizing_Projects_into_Subsystems`) to see how each
-separate object directory can be associated with one of the subsystems
-constituting the application.
-
-When the *linker* is called, it usually creates an executable. By
-default, this executable is placed in the object directory of the project. It
-might be convenient to store it in its own directory.
-
-.. index:: Exec_Dir (GNAT Project Manager)
-
-This can be done through the `Exec_Dir` attribute, which, like
-*Object_Dir* contains a single absolute or relative path and must point to
-an existing and writable directory, unless you ask the tool to create it on
-your behalf. When not specified, It defaults to the object directory and
-therefore to the project file's directory if neither *Object_Dir* nor
-*Exec_Dir* was specified.
-
-In the case of the example, let's place the executable in the root
-of the hierarchy, ie the same directory as :file:`build.gpr`. Hence
-the project file is now
-
-.. code-block:: gpr
-
- project Build is
- for Source_Dirs use ("common");
- for Object_Dir use "obj";
- for Exec_Dir use "."; -- <<<<
- end Build;
-
-
-.. _Main_Subprograms:
-
-Main Subprograms
-----------------
-
-In the previous section, executables were mentioned. The project manager needs
-to be taught what they are. In a project file, an executable is indicated by
-pointing to the source file of a main subprogram. In C this is the file that
-contains the `main` function, and in Ada the file that contains the main
-unit.
-
-There can be any number of such main files within a given project, and thus
-several executables can be built in the context of a single project file. Of
-course, one given executable might not (and in fact will not) need all the
-source files referenced by the project. As opposed to other build environments
-such as *makefile*, one does not need to specify the list of
-dependencies of each executable, the project-aware builder knows enough of the
-semantics of the languages to build and link only the necessary elements.
-
-.. index:: Main (GNAT Project Manager)
-
-The list of main files is specified via the **Main** attribute. It contains
-a list of file names (no directories). If a project defines this
-attribute, it is not necessary to identify main files on the
-command line when invoking a builder, and editors like
-*GPS* will be able to create extra menus to spawn or debug the
-corresponding executables.
-
-.. code-block:: gpr
-
- project Build is
- for Source_Dirs use ("common");
- for Object_Dir use "obj";
- for Exec_Dir use ".";
- for Main use ("proc.adb"); -- <<<<
- end Build;
-
-
-If this attribute is defined in the project, then spawning the builder
-with a command such as
-
-.. code-block:: sh
-
- gprbuild -Pbuild
-
-
-automatically builds all the executables corresponding to the files
-listed in the *Main* attribute. It is possible to specify one
-or more executables on the command line to build a subset of them.
-
-.. _Tools_Options_in_Project_Files:
-
-Tools Options in Project Files
-------------------------------
-
-We now have a project file that fully describes our environment, and can be
-used to build the application with a simple *gprbuild* command as seen
-in the previous section. In fact, the empty project we showed immediately at
-the beginning (with no attribute at all) could already fulfill that need if it
-was put in the :file:`common` directory.
-
-Of course, we might want more control. This section shows you how to specify
-the compilation switches that the various tools involved in the building of the
-executable should use.
-
-.. index:: command line length (GNAT Project Manager)
-
-Since source names and locations are described in the project file, it is not
-necessary to use switches on the command line for this purpose (switches such
-as -I for gcc). This removes a major source of command line length overflow.
-Clearly, the builders will have to communicate this information one way or
-another to the underlying compilers and tools they call but they usually use
-response files for this and thus are not subject to command line overflows.
-
-Several tools participate to the creation of an executable: the compiler
-produces object files from the source files; the binder (in the Ada case)
-creates a "source" file that takes care, among other things, of elaboration
-issues and global variable initialization; and the linker gathers everything
-into a single executable that users can execute. All these tools are known to
-the project manager and will be called with user defined switches from the
-project files. However, we need to introduce a new project file concept to
-express the switches to be used for any of the tools involved in the build.
-
-.. index:: project file packages (GNAT Project Manager)
-
-A project file is subdivided into zero or more **packages**, each of which
-contains the attributes specific to one tool (or one set of tools). Project
-files use an Ada-like syntax for packages. Package names permitted in project
-files are restricted to a predefined set (see :ref:`Packages`), and the contents
-of packages are limited to a small set of constructs and attributes
-(see :ref:`Attributes`).
-
-Our example project file can be extended with the following empty packages. At
-this stage, they could all be omitted since they are empty, but they show which
-packages would be involved in the build process.
-
-.. code-block:: gpr
-
- project Build is
- for Source_Dirs use ("common");
- for Object_Dir use "obj";
- for Exec_Dir use ".";
- for Main use ("proc.adb");
-
- package Builder is --<<< for gprbuild
- end Builder;
-
- package Compiler is --<<< for the compiler
- end Compiler;
-
- package Binder is --<<< for the binder
- end Binder;
-
- package Linker is --<<< for the linker
- end Linker;
- end Build;
-
-Let's first examine the compiler switches. As stated in the initial description
-of the example, we want to compile all files with *-O2*. This is a
-compiler switch, although it is usual, on the command line, to pass it to the
-builder which then passes it to the compiler. It is recommended to use directly
-the right package, which will make the setup easier to understand for other
-people.
-
-Several attributes can be used to specify the switches:
-
-.. index:: Default_Switches (GNAT Project Manager)
-
-**Default_Switches**:
-
- This is the first mention in this manual of an **indexed attribute**. When
- this attribute is defined, one must supply an *index* in the form of a
- literal string.
- In the case of *Default_Switches*, the index is the name of the
- language to which the switches apply (since a different compiler will
- likely be used for each language, and each compiler has its own set of
- switches). The value of the attribute is a list of switches.
-
- In this example, we want to compile all Ada source files with the switch
- *-O2*, and the resulting project file is as follows
- (only the `Compiler` package is shown):
-
- .. code-block:: gpr
-
- package Compiler is
- for Default_Switches ("Ada") use ("-O2");
- end Compiler;
-
-.. index:: Switches (GNAT Project Manager)
-
-**Switches**:
-
- In some cases, we might want to use specific switches
- for one or more files. For instance, compiling :file:`proc.adb` might not be
- possible at high level of optimization because of a compiler issue.
- In such a case, the *Switches*
- attribute (indexed on the file name) can be used and will override the
- switches defined by *Default_Switches*. Our project file would
- become:
-
- .. code-block:: gpr
-
-
- package Compiler is
- for Default_Switches ("Ada")
- use ("-O2");
- for Switches ("proc.adb")
- use ("-O0");
- end Compiler;
-
-
- `Switches` may take a pattern as an index, such as in:
-
- .. code-block:: gpr
-
- package Compiler is
- for Default_Switches ("Ada")
- use ("-O2");
- for Switches ("pkg*")
- use ("-O0");
- end Compiler;
-
- Sources :file:`pkg.adb` and :file:`pkg-child.adb` would be compiled with -O0,
- not -O2.
-
- `Switches` can also be given a language name as index instead of a file
- name in which case it has the same semantics as *Default_Switches*.
- However, indexes with wild cards are never valid for language name.
-
-
-.. index:: Local_Configuration_Pragmas (GNAT Project Manager)
-
-**Local_Configuration_Pragmas**:
-
- This attribute may specify the path
- of a file containing configuration pragmas for use by the Ada compiler,
- such as `pragma Restrictions (No_Tasking)`. These pragmas will be
- used for all the sources of the project.
-
-
-The switches for the other tools are defined in a similar manner through the
-**Default_Switches** and **Switches** attributes, respectively in the
-*Builder* package (for *gprbuild*),
-the *Binder* package (binding Ada executables) and the *Linker*
-package (for linking executables).
-
-
-.. _Compiling_with_Project_Files:
-
-Compiling with Project Files
-----------------------------
-
-Now that our project files are written, let's build our executable.
-Here is the command we would use from the command line:
-
-.. code-block:: sh
-
- gprbuild -Pbuild
-
-This will automatically build the executables specified through the
-*Main* attribute: for each, it will compile or recompile the
-sources for which the object file does not exist or is not up-to-date; it
-will then run the binder; and finally run the linker to create the
-executable itself.
-
-The *gprbuild* builder, can automatically manage C files the
-same way: create the file :file:`utils.c` in the :file:`common` directory,
-set the attribute *Languages* to `"(Ada, C)"`, and re-run
-
-.. code-block:: sh
-
- gprbuild -Pbuild
-
-Gprbuild knows how to recompile the C files and will
-recompile them only if one of their dependencies has changed. No direct
-indication on how to build the various elements is given in the
-project file, which describes the project properties rather than a
-set of actions to be executed. Here is the invocation of
-*gprbuild* when building a multi-language program:
-
-.. code-block:: sh
-
- $ gprbuild -Pbuild
- gcc -c proc.adb
- gcc -c pack.adb
- gcc -c utils.c
- gprbind proc
- ...
- gcc proc.o -o proc
-
-Notice the three steps described earlier:
-
-* The first three gcc commands correspond to the compilation phase.
-* The gprbind command corresponds to the post-compilation phase.
-* The last gcc command corresponds to the final link.
-
-
-.. index:: -v option (for GPRbuild)
-
-The default output of GPRbuild's execution is kept reasonably simple and easy
-to understand. In particular, some of the less frequently used commands are not
-shown, and some parameters are abbreviated. So it is not possible to rerun the
-effect of the *gprbuild* command by cut-and-pasting its output.
-GPRbuild's option `-v` provides a much more verbose output which includes,
-among other information, more complete compilation, post-compilation and link
-commands.
-
-
-.. _Executable_File_Names:
-
-Executable File Names
----------------------
-
-.. index:: Executable (GNAT Project Manager)
-
-By default, the executable name corresponding to a main file is
-computed from the main source file name. Through the attribute
-**Builder.Executable**, it is possible to change this default.
-
-For instance, instead of building *proc* (or *proc.exe*
-on Windows), we could configure our project file to build "proc1"
-(resp proc1.exe) with the following addition:
-
-.. code-block:: gpr
-
- project Build is
- ... -- same as before
- package Builder is
- for Executable ("proc.adb") use "proc1";
- end Builder
- end Build;
-
-.. index:: Executable_Suffix (GNAT Project Manager)
-
-Attribute **Executable_Suffix**, when specified, may change the suffix
-of the executable files, when no attribute `Executable` applies:
-its value replaces the platform-specific executable suffix.
-The default executable suffix is empty on UNIX and ".exe" on Windows.
-
-It is also possible to change the name of the produced executable by using the
-command line switch *-o*. When several mains are defined in the project,
-it is not possible to use the *-o* switch and the only way to change the
-names of the executable is provided by Attributes `Executable` and
-`Executable_Suffix`.
-
-
-.. _Avoid_Duplication_With_Variables:
-
-Avoid Duplication With Variables
---------------------------------
-
-To illustrate some other project capabilities, here is a slightly more complex
-project using similar sources and a main program in C:
-
-
-.. code-block:: gpr
-
- project C_Main is
- for Languages use ("Ada", "C");
- for Source_Dirs use ("common");
- for Object_Dir use "obj";
- for Main use ("main.c");
- package Compiler is
- C_Switches := ("-pedantic");
- for Default_Switches ("C") use C_Switches;
- for Default_Switches ("Ada") use ("-gnaty");
- for Switches ("main.c") use C_Switches & ("-g");
- end Compiler;
- end C_Main;
-
-This project has many similarities with the previous one.
-As expected, its `Main` attribute now refers to a C source.
-The attribute *Exec_Dir* is now omitted, thus the resulting
-executable will be put in the directory :file:`obj`.
-
-The most noticeable difference is the use of a variable in the
-*Compiler* package to store settings used in several attributes.
-This avoids text duplication, and eases maintenance (a single place to
-modify if we want to add new switches for C files). We will revisit
-the use of variables in the context of scenarios (see :ref:`Scenarios_in_Projects`).
-
-In this example, we see how the file :file:`main.c` can be compiled with
-the switches used for all the other C files, plus *-g*.
-In this specific situation the use of a variable could have been
-replaced by a reference to the `Default_Switches` attribute:
-
-.. code-block:: gpr
-
- for Switches ("c_main.c") use Compiler'Default_Switches ("C") & ("-g");
-
-Note the tick (*'*) used to refer to attributes defined in a package.
-
-Here is the output of the GPRbuild command using this project:
-
-.. code-block:: sh
-
- $ gprbuild -Pc_main
- gcc -c -pedantic -g main.c
- gcc -c -gnaty proc.adb
- gcc -c -gnaty pack.adb
- gcc -c -pedantic utils.c
- gprbind main.bexch
- ...
- gcc main.o -o main
-
-The default switches for Ada sources,
-the default switches for C sources (in the compilation of :file:`lib.c`),
-and the specific switches for :file:`main.c` have all been taken into
-account.
-
-
-.. _Naming_Schemes:
-
-Naming Schemes
---------------
-
-Sometimes an Ada software system is ported from one compilation environment to
-another (say GNAT), and the file are not named using the default GNAT
-conventions. Instead of changing all the file names, which for a variety of
-reasons might not be possible, you can define the relevant file naming scheme
-in the **Naming** package of your project file.
-
-The naming scheme has two distinct goals for the project manager: it
-allows finding of source files when searching in the source
-directories, and given a source file name it makes it possible to guess
-the associated language, and thus the compiler to use.
-
-Note that the use by the Ada compiler of pragmas Source_File_Name is not
-supported when using project files. You must use the features described in this
-paragraph. You can however specify other configuration pragmas.
-
-The following attributes can be defined in package `Naming`:
-
-.. index:: Casing (GNAT Project Manager)
-
-**Casing**:
-
- Its value must be one of `"lowercase"` (the default if
- unspecified), `"uppercase"` or `"mixedcase"`. It describes the
- casing of file names with regards to the Ada unit name. Given an Ada unit
- My_Unit, the file name will respectively be :file:`my_unit.adb` (lowercase),
- :file:`MY_UNIT.ADB` (uppercase) or :file:`My_Unit.adb` (mixedcase).
- On Windows, file names are case insensitive, so this attribute is
- irrelevant.
-
-
-.. index:: Dot_Replacement (GNAT Project Manager)
-
-**Dot_Replacement**:
-
- This attribute specifies the string that should replace the "." in unit
- names. Its default value is `"-"` so that a unit
- `Parent.Child` is expected to be found in the file
- :file:`parent-child.adb`. The replacement string must satisfy the following
- requirements to avoid ambiguities in the naming scheme:
-
- * It must not be empty
-
- * It cannot start or end with an alphanumeric character
-
- * It cannot be a single underscore
-
- * It cannot start with an underscore followed by an alphanumeric
-
- * It cannot contain a dot `'.'` except if the entire string is `"."`
-
-.. index:: Spec_Suffix (GNAT Project Manager)
-.. index:: Specification_Suffix (GNAT Project Manager)
-
-**Spec_Suffix** and **Specification_Suffix**:
-
- For Ada, these attributes give the suffix used in file names that contain
- specifications. For other languages, they give the extension for files
- that contain declaration (header files in C for instance). The attribute
- is indexed on the language.
- The two attributes are equivalent, but the latter is obsolescent.
-
- If the value of the attribute is the empty string, it indicates to the
- Project Manager that the only specifications/header files for the language
- are those specified with attributes `Spec` or
- `Specification_Exceptions`.
-
- If `Spec_Suffix ("Ada")` is not specified, then the default is
- `".ads"`.
-
- A non empty value must satisfy the following requirements:
-
- * It must include at least one dot
-
- * If `Dot_Replacement` is a single dot, then it cannot include
- more than one dot.
-
-.. index:: Body_Suffix (GNAT Project Manager)
-.. index:: Implementation_Suffix (GNAT Project Manager)
-
-**Body_Suffix** and **Implementation_Suffix**:
-
- These attributes give the extension used for file names that contain
- code (bodies in Ada). They are indexed on the language. The second
- version is obsolescent and fully replaced by the first attribute.
-
- For each language of a project, one of these two attributes need to be
- specified, either in the project itself or in the configuration project file.
-
- If the value of the attribute is the empty string, it indicates to the
- Project Manager that the only source files for the language
- are those specified with attributes `Body` or
- `Implementation_Exceptions`.
-
- These attributes must satisfy the same requirements as `Spec_Suffix`.
- In addition, they must be different from any of the values in
- `Spec_Suffix`.
- If `Body_Suffix ("Ada")` is not specified, then the default is
- `".adb"`.
-
- If `Body_Suffix ("Ada")` and `Spec_Suffix ("Ada")` end with the
- same string, then a file name that ends with the longest of these two
- suffixes will be a body if the longest suffix is `Body_Suffix ("Ada")`
- or a spec if the longest suffix is `Spec_Suffix ("Ada")`.
-
- If the suffix does not start with a '.', a file with a name exactly equal to
- the suffix will also be part of the project (for instance if you define the
- suffix as `Makefile.in`, a file called :file:`Makefile.in` will be part
- of the project. This capability is usually not interesting when building.
- However, it might become useful when a project is also used to
- find the list of source files in an editor, like the GNAT Programming System
- (GPS).
-
-.. index:: Separate_Suffix (GNAT Project Manager)
-
-**Separate_Suffix**:
-
- This attribute is specific to Ada. It denotes the suffix used in file names
- that contain separate bodies. If it is not specified, then it defaults to
- same value as `Body_Suffix ("Ada")`.
-
- The value of this attribute cannot be the empty string.
-
- Otherwise, the same rules apply as for the
- `Body_Suffix` attribute. The only accepted index is "Ada".
-
-
-**Spec** or **Specification**:
-
- .. index:: Spec (GNAT Project Manager)
-
- .. index:: Specification (GNAT Project Manager)
-
- This attribute `Spec` can be used to define the source file name for a
- given Ada compilation unit's spec. The index is the literal name of the Ada
- unit (case insensitive). The value is the literal base name of the file that
- contains this unit's spec (case sensitive or insensitive depending on the
- operating system). This attribute allows the definition of exceptions to the
- general naming scheme, in case some files do not follow the usual
- convention.
-
- When a source file contains several units, the relative position of the unit
- can be indicated. The first unit in the file is at position 1
-
-
- .. code-block:: gpr
-
- for Spec ("MyPack.MyChild") use "mypack.mychild.spec";
- for Spec ("top") use "foo.a" at 1;
- for Spec ("foo") use "foo.a" at 2;
-
-
-.. index:: Body (GNAT Project Manager)
-
-.. index:: Implementation (GNAT Project Manager)
-
-**Body** or **Implementation**:
-
- These attribute play the same role as *Spec* for Ada bodies.
-
-
-.. index:: Specification_Exceptions (GNAT Project Manager)
-
-.. index:: Implementation_Exceptions (GNAT Project Manager)
-
-**Specification_Exceptions** and **Implementation_Exceptions**:
-
- These attributes define exceptions to the naming scheme for languages
- other than Ada. They are indexed on the language name, and contain
- a list of file names respectively for headers and source code.
-
-
-For example, the following package models the Apex file naming rules:
-
-.. code-block:: gpr
-
- package Naming is
- for Casing use "lowercase";
- for Dot_Replacement use ".";
- for Spec_Suffix ("Ada") use ".1.ada";
- for Body_Suffix ("Ada") use ".2.ada";
- end Naming;
-
-
-.. _Installation:
-
-Installation
-------------
-
-After building an application or a library it is often required to
-install it into the development environment. For instance this step is
-required if the library is to be used by another application.
-The *gprinstall* tool provides an easy way to install
-libraries, executable or object code generated during the build. The
-**Install** package can be used to change the default locations.
-
-The following attributes can be defined in package `Install`:
-
-.. index:: Active (GNAT Project Manager)
-
-**Active**
- Whether the project is to be installed, values are `true`
- (default) or `false`.
-
-
-.. index:: Artifacts (GNAT Project Manager)
-
-**Artifacts**
-
- An array attribute to declare a set of files not part of the sources
- to be installed. The array discriminant is the directory where the
- file is to be installed. If a relative directory then Prefix (see
- below) is prepended. Note also that if the same file name occurs
- multiple time in the attribute list, the last one will be the one
- installed.
-
-
-.. index:: Prefix (GNAT Project Manager)
-
-**Prefix**:
-
- Root directory for the installation.
-
-
-**Exec_Subdir**
-
- Subdirectory of **Prefix** where executables are to be
- installed. Default is **bin**.
-
-
-**Lib_Subdir**
-
- Subdirectory of **Prefix** where directory with the library or object
- files is to be installed. Default is **lib**.
-
-
-**Sources_Subdir**
-
- Subdirectory of **Prefix** where directory with sources is to be
- installed. Default is **include**.
-
-
-**Project_Subdir**
-
- Subdirectory of **Prefix** where the generated project file is to be
- installed. Default is **share/gpr**.
-
-
-**Mode**
-
- The installation mode, it is either **dev** (default) or **usage**.
- See **gprbuild** user's guide for details.
-
-
-**Install_Name**
-
- Specify the name to use for recording the installation. The default is
- the project name without the extension.
-
-
-.. _Distributed_support:
-
-Distributed support
--------------------
-
-For large projects the compilation time can become a limitation in
-the development cycle. To cope with that, GPRbuild supports
-distributed compilation.
-
-The following attributes can be defined in package `Remote`:
-
-.. index:: Root_Dir (GNAT Project Manager)
-
-**Root_Dir**:
-
- Root directory of the project's sources. The default value is the
- project's directory.
-
-
-.. _Organizing_Projects_into_Subsystems:
-
-Organizing Projects into Subsystems
-===================================
-
-A **subsystem** is a coherent part of the complete system to be built. It is
-represented by a set of sources and one single object directory. A system can
-be composed of a single subsystem when it is simple as we have seen in the
-first section. Complex systems are usually composed of several interdependent
-subsystems. A subsystem is dependent on another subsystem if knowledge of the
-other one is required to build it, and in particular if visibility on some of
-the sources of this other subsystem is required. Each subsystem is usually
-represented by its own project file.
-
-In this section, the previous example is being extended. Let's assume some
-sources of our `Build` project depend on other sources.
-For instance, when building a graphical interface, it is usual to depend upon
-a graphical library toolkit such as GtkAda. Furthermore, we also need
-sources from a logging module we had previously written.
-
-.. _Project_Dependencies:
-
-Project Dependencies
---------------------
-
-GtkAda comes with its own project file (appropriately called
-:file:`gtkada.gpr`), and we will assume we have already built a project
-called :file:`logging.gpr` for the logging module. With the information provided
-so far in :file:`build.gpr`, building the application would fail with an error
-indicating that the gtkada and logging units that are relied upon by the sources
-of this project cannot be found.
-
-This is solved by adding the following **with** clauses at the beginning of our
-project:
-
-.. code-block:: gpr
-
- with "gtkada.gpr";
- with "a/b/logging.gpr";
- project Build is
- ... -- as before
- end Build;
-
-
-.. index:: Externally_Built (GNAT Project Manager)
-
-When such a project is compiled, *gprbuild* will automatically check
-the other projects and recompile their sources when needed. It will also
-recompile the sources from `Build` when needed, and finally create the
-executable. In some cases, the implementation units needed to recompile a
-project are not available, or come from some third party and you do not want to
-recompile it yourself. In this case, set the attribute **Externally_Built** to
-"true", indicating to the builder that this project can be assumed to be
-up-to-date, and should not be considered for recompilation. In Ada, if the
-sources of this externally built project were compiled with another version of
-the compiler or with incompatible options, the binder will issue an error.
-
-The project's |with| clause has several effects. It provides source
-visibility between projects during the compilation process. It also guarantees
-that the necessary object files from `Logging` and `GtkAda` are
-available when linking `Build`.
-
-As can be seen in this example, the syntax for importing projects is similar
-to the syntax for importing compilation units in Ada. However, project files
-use literal strings instead of names, and the |with| clause identifies
-project files rather than packages.
-
-Each literal string after |with| is the path
-(absolute or relative) to a project file. The `.gpr` extension is
-optional, although we recommend adding it. If no extension is specified,
-and no project file with the :file:`.gpr` extension is found, then
-the file is searched for exactly as written in the |with| clause,
-that is with no extension.
-
-As mentioned above, the path after a |with| has to be a literal
-string, and you cannot use concatenation, or lookup the value of external
-variables to change the directories from which a project is loaded.
-A solution if you need something like this is to use aggregate projects
-(see :ref:`Aggregate_Projects`).
-
-.. index:: project path (GNAT Project Manager)
-
-When a relative path or a base name is used, the
-project files are searched relative to each of the directories in the
-**project path**. This path includes all the directories found with the
-following algorithm, in this order; the first matching file is used:
-
-* First, the file is searched relative to the directory that contains the
- current project file.
-
- .. index:: GPR_PROJECT_PATH_FILE (GNAT Project Manager)
- .. index:: GPR_PROJECT_PATH (GNAT Project Manager)
- .. index:: ADA_PROJECT_PATH (GNAT Project Manager)
-
-* Then it is searched relative to all the directories specified in the
- environment variables **GPR_PROJECT_PATH_FILE**,
- **GPR_PROJECT_PATH** and **ADA_PROJECT_PATH** (in that order) if they exist.
- The value of **GPR_PROJECT_PATH_FILE**, when defined, is the path name of
- a text file that contains project directory path names, one per line.
- **GPR_PROJECT_PATH** and **ADA_PROJECT_PATH**, when defined, contain
- project directory path names separated by directory separators.
- **ADA_PROJECT_PATH** is used for compatibility, it is recommended to
- use **GPR_PROJECT_PATH_FILE** or **GPR_PROJECT_PATH**.
-
-* Finally, it is searched relative to the default project directories.
- Such directories depend on the tool used. The locations searched in the
- specified order are:
-
- * :file:`<prefix>/<target>/lib/gnat` if option *--target* is specified
- * :file:`<prefix>/<target>/share/gpr` if option *--target* is specified
- * :file:`<prefix>/share/gpr/`
- * :file:`<prefix>/lib/gnat/`
-
- In our example, :file:`gtkada.gpr` is found in the predefined directory if
- it was installed at the same root as GNAT.
-
-Some tools also support extending the project path from the command line,
-generally through the *-aP*. You can see the value of the project
-path by using the *gnatls -v* command.
-
-Any symbolic link will be fully resolved in the directory of the
-importing project file before the imported project file is examined.
-
-Any source file in the imported project can be used by the sources of the
-importing project, transitively.
-Thus if `A` imports `B`, which imports `C`, the sources of
-`A` may depend on the sources of `C`, even if `A` does not
-import `C` explicitly. However, this is not recommended, because if
-and when `B` ceases to import `C`, some sources in `A` will
-no longer compile. *gprbuild* has a switch *--no-indirect-imports*
-that will report such indirect dependencies.
-
-.. note::
-
- One very important aspect of a project hierarchy is that
- **a given source can only belong to one project** (otherwise the project manager
- would not know which settings apply to it and when to recompile it). It means
- that different project files do not usually share source directories or
- when they do, they need to specify precisely which project owns which sources
- using attribute `Source_Files` or equivalent. By contrast, 2 projects
- can each own a source with the same base file name as long as they live in
- different directories. The latter is not true for Ada Sources because of the
- correlation between source files and Ada units.
-
-.. _Cyclic_Project_Dependencies:
-
-Cyclic Project Dependencies
----------------------------
-
-Cyclic dependencies are mostly forbidden:
-if `A` imports `B` (directly or indirectly) then `B`
-is not allowed to import `A`. However, there are cases when cyclic
-dependencies would be beneficial. For these cases, another form of import
-between projects exists: the **limited with**. A project `A` that
-imports a project `B` with a straight |with| may also be imported,
-directly or indirectly, by `B` through a `limited with`.
-
-The difference between straight |with| and `limited with` is that
-the name of a project imported with a `limited with` cannot be used in the
-project importing it. In particular, its packages cannot be renamed and
-its variables cannot be referred to.
-
-.. code-block:: gpr
-
- with "b.gpr";
- with "c.gpr";
- project A is
- for Exec_Dir use B'Exec_Dir; -- ok
- end A;
-
- limited with "a.gpr"; -- Cyclic dependency: A -> B -> A
- project B is
- for Exec_Dir use A'Exec_Dir; -- not ok
- end B;
-
- with "d.gpr";
- project C is
- end C;
-
- limited with "a.gpr"; -- Cyclic dependency: A -> C -> D -> A
- project D is
- for Exec_Dir use A'Exec_Dir; -- not ok
- end D;
-
-
-.. _Sharing_Between_Projects:
-
-Sharing Between Projects
-------------------------
-
-When building an application, it is common to have similar needs in several of
-the projects corresponding to the subsystems under construction. For instance,
-they will all have the same compilation switches.
-
-As seen before (see :ref:`Tools_Options_in_Project_Files`), setting compilation
-switches for all sources of a subsystem is simple: it is just a matter of
-adding a `Compiler.Default_Switches` attribute to each project files with
-the same value. Of course, that means duplication of data, and both places need
-to be changed in order to recompile the whole application with different
-switches. It can become a real problem if there are many subsystems and thus
-many project files to edit.
-
-There are two main approaches to avoiding this duplication:
-
-* Since :file:`build.gpr` imports :file:`logging.gpr`, we could change it
- to reference the attribute in Logging, either through a package renaming,
- or by referencing the attribute. The following example shows both cases:
-
- .. code-block:: gpr
-
- project Logging is
- package Compiler is
- for Switches ("Ada")
- use ("-O2");
- end Compiler;
- package Binder is
- for Switches ("Ada")
- use ("-E");
- end Binder;
- end Logging;
-
- with "logging.gpr";
- project Build is
- package Compiler renames Logging.Compiler;
- package Binder is
- for Switches ("Ada") use Logging.Binder'Switches ("Ada");
- end Binder;
- end Build;
-
- The solution used for `Compiler` gets the same value for all
- attributes of the package, but you cannot modify anything from the
- package (adding extra switches or some exceptions). The second
- version is more flexible, but more verbose.
-
- If you need to refer to the value of a variable in an imported
- project, rather than an attribute, the syntax is similar but uses
- a "." rather than an apostrophe. For instance:
-
- .. code-block:: gpr
-
- with "imported";
- project Main is
- Var1 := Imported.Var;
- end Main;
-
-* The second approach is to define the switches in a third project.
- That project is set up without any sources (so that, as opposed to
- the first example, none of the project plays a special role), and
- will only be used to define the attributes. Such a project is
- typically called :file:`shared.gpr`.
-
- .. code-block:: gpr
-
- abstract project Shared is
- for Source_Files use (); -- no sources
- package Compiler is
- for Switches ("Ada")
- use ("-O2");
- end Compiler;
- end Shared;
-
- with "shared.gpr";
- project Logging is
- package Compiler renames Shared.Compiler;
- end Logging;
-
- with "shared.gpr";
- project Build is
- package Compiler renames Shared.Compiler;
- end Build;
-
- As for the first example, we could have chosen to set the attributes
- one by one rather than to rename a package. The reason we explicitly
- indicate that `Shared` has no sources is so that it can be created
- in any directory and we are sure it shares no sources with `Build`
- or `Logging`, which of course would be invalid.
-
- .. index:: project qualifier (GNAT Project Manager)
-
- Note the additional use of the **abstract** qualifier in :file:`shared.gpr`.
- This qualifier is optional, but helps convey the message that we do not
- intend this project to have sources (see :ref:`Qualified_Projects` for
- more qualifiers).
-
-
-.. _Global_Attributes:
-
-Global Attributes
------------------
-
-We have already seen many examples of attributes used to specify a special
-option of one of the tools involved in the build process. Most of those
-attributes are project specific. That it to say, they only affect the invocation
-of tools on the sources of the project where they are defined.
-
-There are a few additional attributes that apply to all projects in a
-hierarchy as long as they are defined on the "main" project.
-The main project is the project explicitly mentioned on the command-line.
-The project hierarchy is the "with"-closure of the main project.
-
-Here is a list of commonly used global attributes:
-
-.. index:: Global_Configuration_Pragmas (GNAT Project Manager)
-
-**Builder.Global_Configuration_Pragmas**:
-
- This attribute points to a file that contains configuration pragmas
- to use when building executables. These pragmas apply for all
- executables built from this project hierarchy. As we have seen before,
- additional pragmas can be specified on a per-project basis by setting the
- `Compiler.Local_Configuration_Pragmas` attribute.
-
-.. index:: Global_Compilation_Switches (GNAT Project Manager)
-
-**Builder.Global_Compilation_Switches**:
-
- This attribute is a list of compiler switches to use when compiling any
- source file in the project hierarchy. These switches are used in addition
- to the ones defined in the `Compiler` package, which only apply to
- the sources of the corresponding project. This attribute is indexed on
- the name of the language.
-
-Using such global capabilities is convenient. It can also lead to unexpected
-behavior. Especially when several subsystems are shared among different main
-projects and the different global attributes are not
-compatible. Note that using aggregate projects can be a safer and more powerful
-replacement to global attributes.
-
-.. _Scenarios_in_Projects:
-
-Scenarios in Projects
-=====================
-
-Various aspects of the projects can be modified based on **scenarios**. These
-are user-defined modes that change the behavior of a project. Typical
-examples are the setup of platform-specific compiler options, or the use of
-a debug and a release mode (the former would activate the generation of debug
-information, while the second will focus on improving code optimization).
-
-Let's enhance our example to support debug and release modes. The issue is to
-let the user choose what kind of system he is building: use *-g* as
-compiler switches in debug mode and *-O2* in release mode. We will also
-set up the projects so that we do not share the same object directory in both
-modes; otherwise switching from one to the other might trigger more
-recompilations than needed or mix objects from the two modes.
-
-One naive approach is to create two different project files, say
-:file:`build_debug.gpr` and :file:`build_release.gpr`, that set the appropriate
-attributes as explained in previous sections. This solution does not scale
-well, because in the presence of multiple projects depending on each other, you
-will also have to duplicate the complete hierarchy and adapt the project files
-to point to the right copies.
-
-.. index:: scenarios (GNAT Project Manager)
-
-Instead, project files support the notion of scenarios controlled
-by external values. Such values can come from several sources (in decreasing
-order of priority):
-
-.. index:: -X (usage with GNAT Project Manager)
-
-**Command line**:
- When launching *gprbuild*, the user can pass
- extra *-X* switches to define the external value. In
- our case, the command line might look like
-
- .. code-block:: sh
-
- gprbuild -Pbuild.gpr -Xmode=release
-
-
-**Environment variables**:
- When the external value does not come from the command line, it can come from
- the value of environment variables of the appropriate name.
- In our case, if an environment variable called "mode"
- exists, its value will be taken into account.
-
-
-
-.. index:: external (GNAT Project Manager)
-
-**External function second parameter**.
-
-We now need to get that value in the project. The general form is to use
-the predefined function **external** which returns the current value of
-the external. For instance, we could set up the object directory to point to
-either :file:`obj/debug` or :file:`obj/release` by changing our project to
-
-.. code-block:: gpr
-
- project Build is
- for Object_Dir use "obj/" & external ("mode", "debug");
- ... -- as before
- end Build;
-
-The second parameter to `external` is optional, and is the default
-value to use if "mode" is not set from the command line or the environment.
-
-In order to set the switches according to the different scenarios, other
-constructs have to be introduced such as typed variables and case constructions.
-
-.. index:: typed variable (GNAT Project Manager)
-.. index:: case construction (GNAT Project Manager)
-
-A **typed variable** is a variable that
-can take only a limited number of values, similar to an enumeration in Ada.
-Such a variable can then be used in a **case construction** and create conditional
-sections in the project. The following example shows how this can be done:
-
-.. code-block:: gpr
-
- project Build is
- type Mode_Type is ("debug", "release"); -- all possible values
- Mode : Mode_Type := external ("mode", "debug"); -- a typed variable
-
- package Compiler is
- case Mode is
- when "debug" =>
- for Switches ("Ada")
- use ("-g");
- when "release" =>
- for Switches ("Ada")
- use ("-O2");
- end case;
- end Compiler;
- end Build;
-
-The project has suddenly grown in size, but has become much more flexible.
-`Mode_Type` defines the only valid values for the `mode` variable. If
-any other value is read from the environment, an error is reported and the
-project is considered as invalid.
-
-The `Mode` variable is initialized with an external value
-defaulting to `"debug"`. This default could be omitted and that would
-force the user to define the value. Finally, we can use a case construction to set the
-switches depending on the scenario the user has chosen.
-
-Most aspects of the projects can depend on scenarios. The notable exception
-are project dependencies (|with| clauses), which cannot depend on a scenario.
-
-Scenarios work the same way with **project hierarchies**: you can either
-duplicate a variable similar to `Mode` in each of the project (as long
-as the first argument to `external` is always the same and the type is
-the same), or simply set the variable in the :file:`shared.gpr` project
-(see :ref:`Sharing_Between_Projects`).
-
-
-.. _Library_Projects:
-
-Library Projects
-================
-
-So far, we have seen examples of projects that create executables. However,
-it is also possible to create libraries instead. A **library** is a specific
-type of subsystem where, for convenience, objects are grouped together
-using system-specific means such as archives or windows DLLs.
-
-Library projects provide a system- and language-independent way of building
-both **static** and **dynamic** libraries. They also support the concept of
-**standalone libraries** (SAL) which offer two significant properties: the
-elaboration (e.g. initialization) of the library is either automatic or
-very simple; a change in the
-implementation part of the library implies minimal post-compilation actions on
-the complete system and potentially no action at all for the rest of the
-system in the case of dynamic SALs.
-
-There is a restriction on shared library projects: by default, they are only
-allowed to import other shared library projects. They are not allowed to
-import non library projects or static library projects.
-
-The GNAT Project Manager takes complete care of the library build, rebuild and
-installation tasks, including recompilation of the source files for which
-objects do not exist or are not up to date, assembly of the library archive, and
-installation of the library (i.e., copying associated source, object and
-:file:`ALI` files to the specified location).
-
-
-.. _Building_Libraries:
-
-Building Libraries
-------------------
-
-Let's enhance our example and transform the `logging` subsystem into a
-library. In order to do so, a few changes need to be made to
-:file:`logging.gpr`. Some attributes need to be defined: at least
-`Library_Name` and `Library_Dir`; in addition, some other attributes
-can be used to specify specific aspects of the library. For readability, it is
-also recommended (although not mandatory), to use the qualifier `library`
-in front of the `project` keyword.
-
-.. index:: Library_Name (GNAT Project Manager)
-
-**Library_Name**:
-
- This attribute is the name of the library to be built. There is no
- restriction on the name of a library imposed by the project manager, except
- for stand-alone libraries whose names must follow the syntax of Ada
- identifiers; however, there may be system-specific restrictions on the name.
- In general, it is recommended to stick to alphanumeric characters (and
- possibly single underscores) to help portability.
-
-.. index:: Library_Dir (GNAT Project Manager)
-
-**Library_Dir**:
-
- This attribute is the path (absolute or relative) of the directory where
- the library is to be installed. In the process of building a library,
- the sources are compiled, the object files end up in the explicit or
- implicit `Object_Dir` directory. When all sources of a library
- are compiled, some of the compilation artifacts, including the library itself,
- are copied to the library_dir directory. This directory must exist and be
- writable. It must also be different from the object directory so that cleanup
- activities in the Library_Dir do not affect recompilation needs.
-
-Here is the new version of :file:`logging.gpr` that makes it a library:
-
-.. code-block:: gpr
-
- library project Logging is -- "library" is optional
- for Library_Name use "logging"; -- will create "liblogging.a" on Unix
- for Object_Dir use "obj";
- for Library_Dir use "lib"; -- different from object_dir
- end Logging;
-
-Once the above two attributes are defined, the library project is valid and
-is enough for building a library with default characteristics.
-Other library-related attributes can be used to change the defaults:
-
-.. index:: Library_Kind (GNAT Project Manager)
-
-**Library_Kind**:
-
- The value of this attribute must be either `"static"`, `"dynamic"` or
- `"relocatable"` (the latter is a synonym for dynamic). It indicates
- which kind of library should be built (the default is to build a
- static library, that is an archive of object files that can potentially
- be linked into a static executable). When the library is set to be dynamic,
- a separate image is created that will be loaded independently, usually
- at the start of the main program execution. Support for dynamic libraries is
- very platform specific, for instance on Windows it takes the form of a DLL
- while on GNU/Linux, it is a dynamic elf image whose suffix is usually
- :file:`.so`. Library project files, on the other hand, can be written in
- a platform independent way so that the same project file can be used to build
- a library on different operating systems.
-
- If you need to build both a static and a dynamic library, it is recommended
- to use two different object directories, since in some cases some extra code
- needs to be generated for the latter. For such cases, one can either define
- two different project files, or a single one that uses scenarios to indicate
- the various kinds of library to be built and their corresponding object_dir.
-
-.. index:: Library_ALI_Dir (GNAT Project Manager)
-
-**Library_ALI_Dir**:
-
- This attribute may be specified to indicate the directory where the ALI
- files of the library are installed. By default, they are copied into the
- `Library_Dir` directory, but as for the executables where we have a
- separate `Exec_Dir` attribute, you might want to put them in a separate
- directory since there can be hundreds of them. The same restrictions as for
- the `Library_Dir` attribute apply.
-
-.. index:: Library_Version (GNAT Project Manager)
-
-**Library_Version**:
-
- This attribute is platform dependent, and has no effect on Windows.
- On Unix, it is used only for dynamic libraries as the internal
- name of the library (the `"soname"`). If the library file name (built
- from the `Library_Name`) is different from the `Library_Version`,
- then the library file will be a symbolic link to the actual file whose name
- will be `Library_Version`. This follows the usual installation schemes
- for dynamic libraries on many Unix systems.
-
- .. code-block:: gpr
-
- project Logging is
- Version := "1";
- for Library_Dir use "lib";
- for Library_Name use "logging";
- for Library_Kind use "dynamic";
- for Library_Version use "liblogging.so." & Version;
- end Logging;
-
-
- After the compilation, the directory :file:`lib` will contain both a
- :file:`libdummy.so.1` library and a symbolic link to it called
- :file:`libdummy.so`.
-
-.. index:: Library_GCC (GNAT Project Manager)
-
-**Library_GCC**:
-
- This attribute is the name of the tool to use instead of "gcc" to link shared
- libraries. A common use of this attribute is to define a wrapper script that
- accomplishes specific actions before calling gcc (which itself calls the
- linker to build the library image).
-
-.. index:: Library_Options (GNAT Project Manager)
-
-**Library_Options**:
-
- This attribute may be used to specify additional switches (last switches)
- when linking a shared library.
-
- It may also be used to add foreign object files to a static library.
- Each string in Library_Options is an absolute or relative path of an object
- file. When a relative path, it is relative to the object directory.
-
-.. index:: Leading_Library_Options (GNAT Project Manager)
-
-**Leading_Library_Options**:
-
- This attribute, that is taken into account only by *gprbuild*, may be
- used to specified leading options (first switches) when linking a shared
- library.
-
-.. index:: Linker_Options (GNAT Project Manager)
-
-**Linker.Linker_Options**:
-
- This attribute specifies additional switches to be given to the linker when
- linking an executable. It is ignored when defined in the main project and
- taken into account in all other projects that are imported directly or
- indirectly. These switches complement the `Linker.Switches`
- defined in the main project. This is useful when a particular subsystem
- depends on an external library: adding this dependency as a
- `Linker_Options` in the project of the subsystem is more convenient than
- adding it to all the `Linker.Switches` of the main projects that depend
- upon this subsystem.
-
-
-.. _Using_Library_Projects:
-
-Using Library Projects
-----------------------
-
-When the builder detects that a project file is a library project file, it
-recompiles all sources of the project that need recompilation and rebuild the
-library if any of the sources have been recompiled. It then groups all object
-files into a single file, which is a shared or a static library. This library
-can later on be linked with multiple executables. Note that the use
-of shard libraries reduces the size of the final executable and can also reduce
-the memory footprint at execution time when the library is shared among several
-executables.
-
-*gprbuild also allows to build **multi-language libraries** when specifying
-sources from multiple languages.
-
-A non-library project can import a library project. When the builder is invoked
-on the former, the library of the latter is only rebuilt when absolutely
-necessary. For instance, if a unit of the library is not up-to-date but none of
-the executables need this unit, then the unit is not recompiled and the library
-is not reassembled. For instance, let's assume in our example that logging has
-the following sources: :file:`log1.ads`, :file:`log1.adb`, :file:`log2.ads` and
-:file:`log2.adb`. If :file:`log1.adb` has been modified, then the library
-:file:`liblogging` will be rebuilt when compiling all the sources of
-`Build` only if :file:`proc.ads`, :file:`pack.ads` or :file:`pack.adb`
-include a `"with Log1"`.
-
-To ensure that all the sources in the `Logging` library are
-up to date, and that all the sources of `Build` are also up to date,
-the following two commands need to be used:
-
-.. code-block:: sh
-
- gprbuild -Plogging.gpr
- gprbuild -Pbuild.gpr
-
-All :file:`ALI` files will also be copied from the object directory to the
-library directory. To build executables, *gprbuild* will use the
-library rather than the individual object files.
-
-Library projects can also be useful to describe a library that needs to be used
-but, for some reason, cannot be rebuilt. For instance, it is the case when some
-of the library sources are not available. Such library projects need to use the
-`Externally_Built` attribute as in the example below:
-
-.. code-block:: gpr
-
- library project Extern_Lib is
- for Languages use ("Ada", "C");
- for Source_Dirs use ("lib_src");
- for Library_Dir use "lib2";
- for Library_Kind use "dynamic";
- for Library_Name use "l2";
- for Externally_Built use "true"; -- <<<<
- end Extern_Lib;
-
-In the case of externally built libraries, the `Object_Dir`
-attribute does not need to be specified because it will never be
-used.
-
-The main effect of using such an externally built library project is mostly to
-affect the linker command in order to reference the desired library. It can
-also be achieved by using `Linker.Linker_Options` or `Linker.Switches`
-in the project corresponding to the subsystem needing this external library.
-This latter method is more straightforward in simple cases but when several
-subsystems depend upon the same external library, finding the proper place
-for the `Linker.Linker_Options` might not be easy and if it is
-not placed properly, the final link command is likely to present ordering issues.
-In such a situation, it is better to use the externally built library project
-so that all other subsystems depending on it can declare this dependency thanks
-to a project |with| clause, which in turn will trigger the builder to find
-the proper order of libraries in the final link command.
-
-
-.. _Stand-alone_Library_Projects:
-
-Stand-alone Library Projects
-----------------------------
-
-.. index:: standalone libraries (usage with GNAT Project Manager)
-
-A **stand-alone library** is a library that contains the necessary code to
-elaborate the Ada units that are included in the library. A stand-alone
-library is a convenient way to add an Ada subsystem to a more global system
-whose main is not in Ada since it makes the elaboration of the Ada part mostly
-transparent. However, stand-alone libraries are also useful when the main is in
-Ada: they provide a means for minimizing relinking & redeployment of complex
-systems when localized changes are made.
-
-The name of a stand-alone library, specified with attribute
-`Library_Name`, must have the syntax of an Ada identifier.
-
-The most prominent characteristic of a stand-alone library is that it offers a
-distinction between interface units and implementation units. Only the former
-are visible to units outside the library. A stand-alone library project is thus
-characterised by a third attribute, usually **Library_Interface**, in addition
-to the two attributes that make a project a Library Project
-(`Library_Name` and `Library_Dir`). This third attribute may also be
-**Interfaces**. **Library_Interface** only works when the interface is in Ada
-and takes a list of units as parameter. **Interfaces** works for any supported
-language and takes a list of sources as parameter.
-
-.. index:: Library_Interface (GNAT Project Manager)
-
-**Library_Interface**:
-
- This attribute defines an explicit subset of the units of the project. Units
- from projects importing this library project may only "with" units whose
- sources are listed in the `Library_Interface`. Other sources are
- considered implementation units.
-
- .. code-block:: gpr
-
- for Library_Dir use "lib";
- for Library_Name use "logging";
- for Library_Interface use ("lib1", "lib2"); -- unit names
-
-**Interfaces**
-
- This attribute defines an explicit subset of the source files of a project.
- Sources from projects importing this project, can only depend on sources from
- this subset. This attribute can be used on non library projects. It can also
- be used as a replacement for attribute `Library_Interface`, in which
- case, units have to be replaced by source files. For multi-language library
- projects, it is the only way to make the project a Stand-Alone Library project
- whose interface is not purely Ada.
-
-
-.. index:: Library_Standalone (GNAT Project Manager)
-
-**Library_Standalone**:
-
- This attribute defines the kind of standalone library to
- build. Values are either `standard` (the default), `no` or
- `encapsulated`. When `standard` is used the code to elaborate and
- finalize the library is embedded, when `encapsulated` is used the
- library can furthermore depend only on static libraries (including
- the GNAT runtime). This attribute can be set to `no` to make it clear
- that the library should not be standalone in which case the
- `Library_Interface` should not defined. Note that this attribute
- only applies to shared libraries, so `Library_Kind` must be set
- to `dynamic`.
-
- .. code-block:: gpr
-
- for Library_Dir use "lib";
- for Library_Name use "logging";
- for Library_Kind use "dynamic";
- for Library_Interface use ("lib1", "lib2"); -- unit names
- for Library_Standalone use "encapsulated";
-
-In order to include the elaboration code in the stand-alone library, the binder
-is invoked on the closure of the library units creating a package whose name
-depends on the library name (b~logging.ads/b in the example).
-This binder-generated package includes **initialization** and **finalization**
-procedures whose names depend on the library name (`logginginit` and
-`loggingfinal` in the example). The object corresponding to this package is
-included in the library.
-
-.. index:: Library_Auto_Init (GNAT Project Manager)
-
-**Library_Auto_Init**:
-
- A dynamic stand-alone Library is automatically initialized
- if automatic initialization of Stand-alone Libraries is supported on the
- platform and if attribute **Library_Auto_Init** is not specified or
- is specified with the value "true". A static Stand-alone Library is never
- automatically initialized. Specifying "false" for this attribute
- prevents automatic initialization.
-
- When a non-automatically initialized stand-alone library is used in an
- executable, its initialization procedure must be called before any service of
- the library is used. When the main subprogram is in Ada, it may mean that the
- initialization procedure has to be called during elaboration of another
- package.
-
-
-.. index:: Library_Dir (GNAT Project Manager)
-
-**Library_Dir**:
-
- For a stand-alone library, only the :file:`ALI` files of the interface units
- (those that are listed in attribute `Library_Interface`) are copied to
- the library directory. As a consequence, only the interface units may be
- imported from Ada units outside of the library. If other units are imported,
- the binding phase will fail.
-
-
-**Binder.Default_Switches**:
-
- When a stand-alone library is bound, the switches that are specified in
- the attribute **Binder.Default_Switches ("Ada")** are
- used in the call to *gnatbind*.
-
-
-.. index:: Library_Src_Dir (GNAT Project Manager)
-
-**Library_Src_Dir**:
-
- This attribute defines the location (absolute or relative to the project
- directory) where the sources of the interface units are copied at
- installation time.
- These sources includes the specs of the interface units along with the
- closure of sources necessary to compile them successfully. That may include
- bodies and subunits, when pragmas `Inline` are used, or when there are
- generic units in specs. This directory cannot point to the object directory
- or one of the source directories, but it can point to the library directory,
- which is the default value for this attribute.
-
-
-.. index:: Library_Symbol_Policy (GNAT Project Manager)
-
-**Library_Symbol_Policy**:
-
- This attribute controls the export of symbols and, on some platforms (like
- VMS) that have the notions of major and minor IDs built in the library
- files, it controls the setting of these IDs. It is not supported on all
- platforms (where it will just have no effect). It may have one of the
- following values:
-
- * `"autonomous"` or `"default"`: exported symbols are not controlled
-
- * `"compliant"`: if attribute **Library_Reference_Symbol_File**
- is not defined, then it is equivalent to policy "autonomous". If there
- are exported symbols in the reference symbol file that are not in the
- object files of the interfaces, the major ID of the library is increased.
- If there are symbols in the object files of the interfaces that are not
- in the reference symbol file, these symbols are put at the end of the list
- in the newly created symbol file and the minor ID is increased.
-
- * `"controlled"`: the attribute **Library_Reference_Symbol_File** must be
- defined. The library will fail to build if the exported symbols in the
- object files of the interfaces do not match exactly the symbol in the
- symbol file.
-
- * `"restricted"`: The attribute **Library_Symbol_File** must be defined.
- The library will fail to build if there are symbols in the symbol file that
- are not in the exported symbols of the object files of the interfaces.
- Additional symbols in the object files are not added to the symbol file.
-
- * `"direct"`: The attribute **Library_Symbol_File** must be defined and
- must designate an existing file in the object directory. This symbol file
- is passed directly to the underlying linker without any symbol processing.
-
-
-.. index:: Library_Reference_Symbol_File (GNAT Project Manager)
-
-**Library_Reference_Symbol_File**
-
- This attribute may define the path name of a reference symbol file that is
- read when the symbol policy is either "compliant" or "controlled", on
- platforms that support symbol control, such as VMS, when building a
- stand-alone library. The path may be an absolute path or a path relative
- to the project directory.
-
-
-.. index:: Library_Symbol_File (GNAT Project Manager)
-
-**Library_Symbol_File**
-
- This attribute may define the name of the symbol file to be created when
- building a stand-alone library when the symbol policy is either "compliant",
- "controlled" or "restricted", on platforms that support symbol control,
- such as VMS. When symbol policy is "direct", then a file with this name
- must exist in the object directory.
-
-
-.. _Installing_a_library_with_project_files:
-
-Installing a library with project files
----------------------------------------
-
-When using project files, a usable version of the library is created in the
-directory specified by the `Library_Dir` attribute of the library
-project file. Thus no further action is needed in order to make use of
-the libraries that are built as part of the general application build.
-
-You may want to install a library in a context different from where the library
-is built. This situation arises with third party suppliers, who may want
-to distribute a library in binary form where the user is not expected to be
-able to recompile the library. The simplest option in this case is to provide
-a project file slightly different from the one used to build the library, by
-using the `externally_built` attribute. See :ref:`Using_Library_Projects`
-
-Another option is to use *gprinstall* to install the library in a
-different context than the build location. *gprinstall* automatically
-generates a project to use this library, and also copies the minimum set of
-sources needed to use the library to the install location.
-:ref:`Installation`
-
-
-.. _Project_Extension:
-
-Project Extension
-=================
-
-During development of a large system, it is sometimes necessary to use
-modified versions of some of the source files, without changing the original
-sources. This can be achieved through the **project extension** facility.
-
-Suppose for instance that our example `Build` project is built every night
-for the whole team, in some shared directory. A developer usually needs to work
-on a small part of the system, and might not want to have a copy of all the
-sources and all the object files (mostly because that would require too much
-disk space, time to recompile everything). He prefers to be able to override
-some of the source files in his directory, while taking advantage of all the
-object files generated at night.
-
-Another example can be taken from large software systems, where it is common to have
-multiple implementations of a common interface; in Ada terms, multiple
-versions of a package body for the same spec. For example, one implementation
-might be safe for use in tasking programs, while another might be used only
-in sequential applications. This can be modeled in GNAT using the concept
-of *project extension*. If one project (the 'child') *extends*
-another project (the 'parent') then by default all source files of the
-parent project are inherited by the child, but the child project can
-override any of the parent's source files with new versions, and can also
-add new files or remove unnecessary ones.
-This facility is the project analog of a type extension in
-object-oriented programming. Project hierarchies are permitted (an extending
-project may itself be extended), and a project that
-extends a project can also import other projects.
-
-A third example is that of using project extensions to provide different
-versions of the same system. For instance, assume that a `Common`
-project is used by two development branches. One of the branches has now
-been frozen, and no further change can be done to it or to `Common`.
-However, the other development branch still needs evolution of `Common`.
-Project extensions provide a flexible solution to create a new version
-of a subsystem while sharing and reusing as much as possible from the original
-one.
-
-A project extension implicitly inherits all the sources and objects from the
-project it extends. It is possible to create a new version of some of the
-sources in one of the additional source directories of the extending
-project. Those new versions hide the original versions. Adding new sources or
-removing existing ones is also possible. Here is an example on how to extend
-the project `Build` from previous examples:
-
-.. code-block:: gpr
-
- project Work extends "../bld/build.gpr" is
- end Work;
-
-The project after **extends** is the one being extended. As usual, it can be
-specified using an absolute path, or a path relative to any of the directories
-in the project path (see :ref:`Project_Dependencies`). This project does not
-specify source or object directories, so the default values for these
-attributes will be used that is to say the current directory (where project
-`Work` is placed). We can compile that project with
-
-.. code-block:: sh
-
- gprbuild -Pwork
-
-If no sources have been placed in the current directory, this command
-won't do anything, since this project does not change the
-sources it inherited from `Build`, therefore all the object files
-in `Build` and its dependencies are still valid and are reused
-automatically.
-
-Suppose we now want to supply an alternate version of :file:`pack.adb` but use
-the existing versions of :file:`pack.ads` and :file:`proc.adb`. We can create
-the new file in Work's current directory (likely by copying the one from the
-`Build` project and making changes to it. If new packages are needed at
-the same time, we simply create new files in the source directory of the
-extending project.
-
-When we recompile, *gprbuild* will now automatically recompile
-this file (thus creating :file:`pack.o` in the current directory) and
-any file that depends on it (thus creating :file:`proc.o`). Finally, the
-executable is also linked locally.
-
-Note that we could have obtained the desired behavior using project import
-rather than project inheritance. A `base` project would contain the
-sources for :file:`pack.ads` and :file:`proc.adb`, and `Work` would
-import `base` and add :file:`pack.adb`. In this scenario, `base`
-cannot contain the original version of :file:`pack.adb` otherwise there would be
-2 versions of the same unit in the closure of the project and this is not
-allowed. Generally speaking, it is not recommended to put the spec and the
-body of a unit in different projects since this affects their autonomy and
-reusability.
-
-In a project file that extends another project, it is possible to
-indicate that an inherited source is **not part** of the sources of the
-extending project. This is necessary sometimes when a package spec has
-been overridden and no longer requires a body: in this case, it is
-necessary to indicate that the inherited body is not part of the sources
-of the project, otherwise there will be a compilation error
-when compiling the spec.
-
-.. index:: Excluded_Source_Files (GNAT Project Manager)
-
-.. index:: Excluded_Source_List_File (GNAT Project Manager)
-
-For that purpose, the attribute **Excluded_Source_Files** is used.
-Its value is a list of file names.
-It is also possible to use attribute `Excluded_Source_List_File`.
-Its value is the path of a text file containing one file name per
-line.
-
-.. code-block:: gpr
-
- project Work extends "../bld/build.gpr" is
- for Source_Files use ("pack.ads");
- -- New spec of Pkg does not need a completion
- for Excluded_Source_Files use ("pack.adb");
- end Work;
-
-
-All packages that are not declared in the extending project are inherited from
-the project being extended, with their attributes, with the exception of
-`Linker'Linker_Options` which is never inherited. In particular, an
-extending project retains all the switches specified in the project being
-extended.
-
-At the project level, if they are not declared in the extending project, some
-attributes are inherited from the project being extended. They are:
-`Languages`, `Main` (for a root non library project) and
-`Library_Name` (for a project extending a library project).
-
-.. _Project_Hierarchy_Extension:
-
-Project Hierarchy Extension
----------------------------
-
-One of the fundamental restrictions in project extension is the following:
-**A project is not allowed to import directly or indirectly at the same time an extending project and one of its ancestors**.
-
-For example, consider the following hierarchy of projects.
-
-::
-
- a.gpr contains package A1
- b.gpr, imports a.gpr and contains B1, which depends on A1
- c.gpr, imports b.gpr and contains C1, which depends on B1
-
-If we want to locally extend the packages `A1` and `C1`, we need to
-create several extending projects:
-
-::
-
- a_ext.gpr which extends a.gpr, and overrides A1
- b_ext.gpr which extends b.gpr and imports a_ext.gpr
- c_ext.gpr which extends c.gpr, imports b_ext.gpr and overrides C1
-
-.. code-block:: gpr
-
- project A_Ext extends "a.gpr" is
- for Source_Files use ("a1.adb", "a1.ads");
- end A_Ext;
-
- with "a_ext.gpr";
- project B_Ext extends "b.gpr" is
- end B_Ext;
-
- with "b_ext.gpr";
- project C_Ext extends "c.gpr" is
- for Source_Files use ("c1.adb");
- end C_Ext;
-
-The extension :file:`b_ext.gpr` is required, even though we are not overriding
-any of the sources of :file:`b.gpr` because otherwise :file:`c_expr.gpr` would
-import :file:`b.gpr` which itself knows nothing about :file:`a_ext.gpr`.
-
-.. index:: extends all (GNAT Project Manager)
-
-When extending a large system spanning multiple projects, it is often
-inconvenient to extend every project in the hierarchy that is impacted by a
-small change introduced in a low layer. In such cases, it is possible to create
-an **implicit extension** of an entire hierarchy using **extends all**
-relationship.
-
-When the project is extended using `extends all` inheritance, all projects
-that are imported by it, both directly and indirectly, are considered virtually
-extended. That is, the project manager creates implicit projects
-that extend every project in the hierarchy; all these implicit projects do not
-control sources on their own and use the object directory of
-the "extending all" project.
-
-It is possible to explicitly extend one or more projects in the hierarchy
-in order to modify the sources. These extending projects must be imported by
-the "extending all" project, which will replace the corresponding virtual
-projects with the explicit ones.
-
-When building such a project hierarchy extension, the project manager will
-ensure that both modified sources and sources in implicit extending projects
-that depend on them are recompiled.
-
-Thus, in our example we could create the following projects instead:
-
-::
-
- a_ext.gpr, extends a.gpr and overrides A1
- c_ext.gpr, "extends all" c.gpr, imports a_ext.gpr and overrides C1
-
-.. code-block:: gpr
-
- project A_Ext extends "a.gpr" is
- for Source_Files use ("a1.adb", "a1.ads");
- end A_Ext;
-
- with "a_ext.gpr";
- project C_Ext extends all "c.gpr" is
- for Source_Files use ("c1.adb");
- end C_Ext;
-
-
-When building project :file:`c_ext.gpr`, the entire modified project space is
-considered for recompilation, including the sources of :file:`b.gpr` that are
-impacted by the changes in `A1` and `C1`.
-
-
-.. _Aggregate_Projects:
-
-Aggregate Projects
-==================
-
-Aggregate projects are an extension of the project paradigm, and are
-meant to solve a few specific use cases that cannot be solved directly
-using standard projects. This section will go over a few of these use
-cases to try to explain what you can use aggregate projects for.
-
-
-.. _Building_all_main_programs_from_a_single_project_tree:
-
-Building all main programs from a single project tree
------------------------------------------------------
-
-Most often, an application is organized into modules and submodules,
-which are very conveniently represented as a project tree or graph
-(the root project A |withs| the projects for each modules (say B and C),
-which in turn |with| projects for submodules.
-
-Very often, modules will build their own executables (for testing
-purposes for instance), or libraries (for easier reuse in various
-contexts).
-
-However, if you build your project through *gprbuild*, using a syntax similar to
-
-::
-
- gprbuild -PA.gpr
-
-this will only rebuild the main programs of project A, not those of the
-imported projects B and C. Therefore you have to spawn several
-*gprbuild* commands, one per project, to build all executables.
-This is a little inconvenient, but more importantly is inefficient
-because *gprbuild* needs to do duplicate work to ensure that sources are
-up-to-date, and cannot easily compile things in parallel when using
-the -j switch.
-
-Also libraries are always rebuilt when building a project.
-
-You could therefore define an aggregate project Agg that groups A, B
-and C. Then, when you build with
-
-::
-
- gprbuild -PAgg.gpr
-
-this will build all mains from A, B and C.
-
-.. code-block:: gpr
-
- aggregate project Agg is
- for Project_Files use ("a.gpr", "b.gpr", "c.gpr");
- end Agg;
-
-If B or C do not define any main program (through their Main
-attribute), all their sources are built. When you do not group them
-in the aggregate project, only those sources that are needed by A
-will be built.
-
-If you add a main to a project P not already explicitly referenced in the
-aggregate project, you will need to add "p.gpr" in the list of project
-files for the aggregate project, or the main will not be built when
-building the aggregate project.
-
-.. _Building_a_set_of_projects_with_a_single_command:
-
-Building a set of projects with a single command
-------------------------------------------------
-
-One other case is when you have multiple applications and libraries
-that are built independently from each other (but can be built in
-parallel). For instance, you have a project tree rooted at A, and
-another one (which might share some subprojects) rooted at B.
-
-Using only *gprbuild*, you could do
-
-.. code-block:: sh
-
- gprbuild -PA.gpr
- gprbuild -PB.gpr
-
-to build both. But again, *gprbuild* has to do some duplicate work for
-those files that are shared between the two, and cannot truly build
-things in parallel efficiently.
-
-If the two projects are really independent, share no sources other
-than through a common subproject, and have no source files with a
-common basename, you could create a project C that imports A and
-B. But these restrictions are often too strong, and one has to build
-them independently. An aggregate project does not have these
-limitations and can aggregate two project trees that have common
-sources.
-
-This scenario is particularly useful in environments like VxWorks 653
-where the applications running in the multiple partitions can be built
-in parallel through a single *gprbuild* command. This also works nicely
-with Annex E.
-
-
-.. _Define_a_build_environment:
-
-Define a build environment
---------------------------
-
-The environment variables at the time you launch *gprbuild*
-will influence the view these tools have of the project
-(PATH to find the compiler, ADA_PROJECT_PATH or GPR_PROJECT_PATH to find the
-projects, environment variables that are referenced in project files
-through the "external" built-in function, ...). Several command line switches
-can be used to override those (-X or -aP), but on some systems and
-with some projects, this might make the command line too long, and on
-all systems often make it hard to read.
-
-An aggregate project can be used to set the environment for all
-projects built through that aggregate. One of the nice aspects is that
-you can put the aggregate project under configuration management, and
-make sure all your user have a consistent environment when
-building. The syntax looks like
-
-.. code-block:: gpr
-
- aggregate project Agg is
- for Project_Files use ("A.gpr", "B.gpr");
- for Project_Path use ("../dir1", "../dir1/dir2");
- for External ("BUILD") use "PRODUCTION";
-
- package Builder is
- for Global_Compilation_Switches ("Ada") use ("-g");
- end Builder;
- end Agg;
-
-One of the often requested features in projects is to be able to
-reference external variables in |with| declarations, as in
-
-.. code-block:: gpr
-
- with external("SETUP") & "path/prj.gpr"; -- ILLEGAL
- project MyProject is
- ...
- end MyProject;
-
-For various reasons, this is not allowed. But using aggregate projects provide
-an elegant solution. For instance, you could use a project file like:
-
-.. code-block:: gpr
-
- aggregate project Agg is
- for Project_Path use (external("SETUP") & "path");
- for Project_Files use ("myproject.gpr");
- end Agg;
-
- with "prj.gpr"; -- searched on Agg'Project_Path
- project MyProject is
- ...
- end MyProject;
-
-
-.. _Performance_improvements_in_builder:
-
-Performance improvements in builder
------------------------------------
-
-The loading of aggregate projects is optimized in *gprbuild*,
-so that all files are searched for only once on the disk
-(thus reducing the number of system calls and contributing to faster
-compilation times, especially on systems with sources on remote
-servers). As part of the loading, *gprbuild*
-computes how and where a source file should be compiled, and even if it is
-found several times in the aggregated projects it will be compiled only
-once.
-
-Since there is no ambiguity as to which switches should be used, files
-can be compiled in parallel (through the usual -j switch) and this can
-be done while maximizing the use of CPUs (compared to launching
-multiple *gprbuild* commands in parallel).
-
-
-.. _Syntax_of_aggregate_projects:
-
-Syntax of aggregate projects
-----------------------------
-
-An aggregate project follows the general syntax of project files. The
-recommended extension is still :file:`.gpr`. However, a special
-`aggregate` qualifier must be put before the keyword
-`project`.
-
-An aggregate project cannot |with| any other project (standard or
-aggregate), except an abstract project which can be used to share attribute
-values. Also, aggregate projects cannot be extended or imported though a
-|with| clause by any other project. Building other aggregate projects from
-an aggregate project is done through the Project_Files attribute (see below).
-
-An aggregate project does not have any source files directly (only
-through other standard projects). Therefore a number of the standard
-attributes and packages are forbidden in an aggregate project. Here is the
-(non exhaustive) list:
-
-* Languages
-* Source_Files, Source_List_File and other attributes dealing with
- list of sources.
-* Source_Dirs, Exec_Dir and Object_Dir
-* Library_Dir, Library_Name and other library-related attributes
-* Main
-* Roots
-* Externally_Built
-* Inherit_Source_Path
-* Excluded_Source_Dirs
-* Locally_Removed_Files
-* Excluded_Source_Files
-* Excluded_Source_List_File
-* Interfaces
-
-The only package that is authorized (albeit optional) is
-Builder. Other packages (in particular Compiler, Binder and Linker)
-are forbidden.
-
-The following three attributes can be used only in an aggregate project:
-
-.. index:: Project_Files (GNAT Project Manager)
-
-**Project_Files**:
-
- This attribute is compulsory (or else we are not aggregating any project,
- and thus not doing anything). It specifies a list of :file:`.gpr` files
- that are grouped in the aggregate. The list may be empty. The project
- files can be either other aggregate projects, or standard projects. When
- grouping standard projects, you can have both the root of a project tree
- (and you do not need to specify all its imported projects), and any project
- within the tree.
-
- Basically, the idea is to specify all those projects that have
- main programs you want to build and link, or libraries you want to
- build. You can even specify projects that do not use the Main
- attribute nor the `Library_*` attributes, and the result will be to
- build all their source files (not just the ones needed by other
- projects).
-
- The file can include paths (absolute or relative). Paths are relative to
- the location of the aggregate project file itself (if you use a base name,
- we expect to find the .gpr file in the same directory as the aggregate
- project file). The environment variables `ADA_PROJECT_PATH`,
- `GPR_PROJECT_PATH` and `GPR_PROJECT_PATH_FILE` are not used to find
- the project files. The extension :file:`.gpr` is mandatory, since this attribute
- contains file names, not project names.
-
- Paths can also include the `"*"` and `"**"` globbing patterns. The
- latter indicates that any subdirectory (recursively) will be
- searched for matching files. The latter (`"**"`) can only occur at the
- last position in the directory part (ie `"a/**/*.gpr"` is supported, but
- not `"**/a/*.gpr"`). Starting the pattern with `"**"` is equivalent
- to starting with `"./**"`.
-
- For now, the pattern `"*"` is only allowed in the filename part, not
- in the directory part. This is mostly for efficiency reasons to limit the
- number of system calls that are needed.
-
- Here are a few valid examples:
-
- .. code-block:: gpr
-
- for Project_Files use ("a.gpr", "subdir/b.gpr");
- -- two specific projects relative to the directory of agg.gpr
-
- for Project_Files use ("/.gpr");
- -- all projects recursively
-
-
-.. index:: Project_Path (GNAT Project Manager)
-
-**Project_Path**:
-
- This attribute can be used to specify a list of directories in
- which to look for project files in |with| declarations.
-
- When you specify a project in Project_Files (say `x/y/a.gpr`), and
- `a.gpr` imports a project `b.gpr`, only `b.gpr` is searched in
- the project path. `a.gpr` must be exactly at
- `<dir of the aggregate>/x/y/a.gpr`.
-
- This attribute, however, does not affect the search for the aggregated
- project files specified with `Project_Files`.
-
- Each aggregate project has its own `Project_Path` (that is if
- `agg1.gpr` includes `agg2.gpr`, they can potentially both have a
- different `Project_Path`).
-
- This project path is defined as the concatenation, in that order, of:
-
- * the current directory;
-
- * followed by the command line -aP switches;
-
- * then the directories from the GPR_PROJECT_PATH and ADA_PROJECT_PATH environment
- variables;
-
- * then the directories from the Project_Path attribute;
-
- * and finally the predefined directories.
-
- In the example above, agg2.gpr's project path is not influenced by
- the attribute agg1'Project_Path, nor is agg1 influenced by
- agg2'Project_Path.
-
- This can potentially lead to errors. Consider the following example::
-
- --
- -- +---------------+ +----------------+
- -- | Agg1.gpr |-=--includes--=-->| Agg2.gpr |
- -- | 'project_path| | 'project_path |
- -- | | | |
- -- +---------------+ +----------------+
- -- : :
- -- includes includes
- -- : :
- -- v v
- -- +-------+ +---------+
- -- | P.gpr |<---------- withs --------| Q.gpr |
- -- +-------+---------\ +---------+
- -- | |
- -- withs |
- -- | |
- -- v v
- -- +-------+ +---------+
- -- | R.gpr | | R'.gpr |
- -- +-------+ +---------+
-
- When looking for p.gpr, both aggregates find the same physical file on
- the disk. However, it might happen that with their different project
- paths, both aggregate projects would in fact find a different r.gpr.
- Since we have a common project (p.gpr) "with"ing two different r.gpr,
- this will be reported as an error by the builder.
-
- Directories are relative to the location of the aggregate project file.
-
- Example:
-
- .. code-block:: gpr
-
- for Project_Path use ("/usr/local/gpr", "gpr/");
-
-.. index:: External (GNAT Project Manager)
-
-**External**:
-
- This attribute can be used to set the value of environment
- variables as retrieved through the `external` function
- in projects. It does not affect the environment variables
- themselves (so for instance you cannot use it to change the value
- of your PATH as seen from the spawned compiler).
-
- This attribute affects the external values as seen in the rest of
- the aggregate project, and in the aggregated projects.
-
- The exact value of external a variable comes from one of three
- sources (each level overrides the previous levels):
-
- * An External attribute in aggregate project, for instance
- `for External ("BUILD_MODE") use "DEBUG"`;
-
- * Environment variables.
- These override the value given by the attribute, so that
- users can override the value set in the (presumably shared
- with others team members) aggregate project.
-
- * The -X command line switch to *gprbuild*.
- This always takes precedence.
-
- This attribute is only taken into account in the main aggregate
- project (i.e. the one specified on the command line to *gprbuild*),
- and ignored in other aggregate projects. It is invalid
- in standard projects.
- The goal is to have a consistent value in all
- projects that are built through the aggregate, which would not
- be the case in the diamond case: A groups the aggregate
- projects B and C, which both (either directly or indirectly)
- build the project P. If B and C could set different values for
- the environment variables, we would have two different views of
- P, which in particular might impact the list of source files in P.
-
-
-.. _package_Builder_in_aggregate_projects:
-
-package Builder in aggregate projects
--------------------------------------
-
-As mentioned above, only the package Builder can be specified in
-an aggregate project. In this package, only the following attributes
-are valid:
-
-.. index:: Switches (GNAT Project Manager)
-
-**Switches**:
-
- This attribute gives the list of switches to use for *gprbuild*.
- Because no mains can be specified for aggregate projects, the only possible
- index for attribute `Switches` is `others`. All other indexes will
- be ignored.
-
- Example:
-
- .. code-block:: gpr
-
- for Switches (others) use ("-v", "-k", "-j8");
-
- These switches are only read from the main aggregate project (the
- one passed on the command line), and ignored in all other aggregate
- projects or projects.
-
- It can only contain builder switches, not compiler switches.
-
-.. index:: Global_Compilation_Switches (GNAT Project Manager)
-
-**Global_Compilation_Switches**
-
- This attribute gives the list of compiler switches for the various
- languages. For instance,
-
- .. code-block:: gpr
-
- for Global_Compilation_Switches ("Ada") use ("O1", "-g");
- for Global_Compilation_Switches ("C") use ("-O2");
-
- This attribute is only taken into account in the aggregate project
- specified on the command line, not in other aggregate projects.
-
- In the projects grouped by that aggregate, the attribute
- Builder.Global_Compilation_Switches is also ignored. However, the
- attribute Compiler.Default_Switches will be taken into account (but
- that of the aggregate have higher priority). The attribute
- Compiler.Switches is also taken into account and can be used to
- override the switches for a specific file. As a result, it always
- has priority.
-
- The rules are meant to avoid ambiguities when compiling. For
- instance, aggregate project Agg groups the projects A and B, that
- both depend on C. Here is an extra for all of these projects:
-
-
- .. code-block:: gpr
-
- aggregate project Agg is
- for Project_Files use ("a.gpr", "b.gpr");
- package Builder is
- for Global_Compilation_Switches ("Ada") use ("-O2");
- end Builder;
- end Agg;
-
- with "c.gpr";
- project A is
- package Builder is
- for Global_Compilation_Switches ("Ada") use ("-O1");
- -- ignored
- end Builder;
-
- package Compiler is
- for Default_Switches ("Ada")
- use ("-O1", "-g");
- for Switches ("a_file1.adb")
- use ("-O0");
- end Compiler;
- end A;
-
- with "c.gpr";
- project B is
- package Compiler is
- for Default_Switches ("Ada") use ("-O0");
- end Compiler;
- end B;
-
- project C is
- package Compiler is
- for Default_Switches ("Ada")
- use ("-O3",
- "-gnatn");
- for Switches ("c_file1.adb")
- use ("-O0", "-g");
- end Compiler;
- end C;
-
-
- then the following switches are used:
-
- * all files from project A except a_file1.adb are compiled
- with "-O2 -g", since the aggregate project has priority.
-
- * the file a_file1.adb is compiled with
- "-O0", since the Compiler.Switches has priority
-
- * all files from project B are compiled with
- "-O2", since the aggregate project has priority
-
- * all files from C are compiled with "-O2 -gnatn", except for
- c_file1.adb which is compiled with "-O0 -g"
-
- Even though C is seen through two paths (through A and through
- B), the switches used by the compiler are unambiguous.
-
-
-.. index:: Global_Configuration_Pragmas (GNAT Project Manager)
-
-**Global_Configuration_Pragmas**
-
- This attribute can be used to specify a file containing
- configuration pragmas, to be passed to the Ada compiler. Since we
- ignore the package Builder in other aggregate projects and projects,
- only those pragmas defined in the main aggregate project will be
- taken into account.
-
- Projects can locally add to those by using the
- `Compiler.Local_Configuration_Pragmas` attribute if they need.
-
-
-.. index:: Global_Config_File (GNAT Project Manager)
-
-**Global_Config_File**
-
- This attribute, indexed with a language name, can be used to specify a config
- when compiling sources of the language. For Ada, these files are configuration
- pragmas files.
-
-For projects that are built through the aggregate, the package Builder
-is ignored, except for the Executable attribute which specifies the
-name of the executables resulting from the link of the main programs, and
-for the Executable_Suffix.
-
-
-.. _Aggregate_Library_Projects:
-
-Aggregate Library Projects
-==========================
-
-Aggregate library projects make it possible to build a single library
-using object files built using other standard or library
-projects. This gives the flexibility to describe an application as
-having multiple modules (a GUI, database access, ...) using different
-project files (so possibly built with different compiler options) and
-yet create a single library (static or relocatable) out of the
-corresponding object files.
-
-.. _Building_aggregate_library_projects:
-
-Building aggregate library projects
------------------------------------
-
-For example, we can define an aggregate project Agg that groups A, B
-and C:
-
-.. code-block:: gpr
-
- aggregate library project Agg is
- for Project_Files use ("a.gpr", "b.gpr", "c.gpr");
- for Library_Name use ("agg");
- for Library_Dir use ("lagg");
- end Agg;
-
-Then, when you build with:
-
-.. code-block:: sh
-
- gprbuild agg.gpr
-
-This will build all units from projects A, B and C and will create a
-static library named :file:`libagg.a` in the :file:`lagg`
-directory. An aggregate library project has the same set of
-restriction as a standard library project.
-
-Note that a shared aggregate library project cannot aggregate a
-static library project. In platforms where a compiler option is
-required to create relocatable object files, a Builder package in the
-aggregate library project may be used:
-
-.. code-block:: gpr
-
- aggregate library project Agg is
- for Project_Files use ("a.gpr", "b.gpr", "c.gpr");
- for Library_Name use ("agg");
- for Library_Dir use ("lagg");
- for Library_Kind use "relocatable";
-
- package Builder is
- for Global_Compilation_Switches ("Ada") use ("-fPIC");
- end Builder;
- end Agg;
-
-With the above aggregate library Builder package, the `-fPIC`
-option will be passed to the compiler when building any source code
-from projects :file:`a.gpr`, :file:`b.gpr` and :file:`c.gpr`.
-
-
-.. _Syntax_of_aggregate_library_projects:
-
-Syntax of aggregate library projects
-------------------------------------
-
-An aggregate library project follows the general syntax of project
-files. The recommended extension is still :file:`.gpr`. However, a special
-`aggregate library` qualifier must be put before the keyword
-`project`.
-
-An aggregate library project cannot |with| any other project
-(standard or aggregate), except an abstract project which can be used
-to share attribute values.
-
-An aggregate library project does not have any source files directly (only
-through other standard projects). Therefore a number of the standard
-attributes and packages are forbidden in an aggregate library
-project. Here is the (non exhaustive) list:
-
-* Languages
-* Source_Files, Source_List_File and other attributes dealing with
- list of sources.
-* Source_Dirs, Exec_Dir and Object_Dir
-* Main
-* Roots
-* Externally_Built
-* Inherit_Source_Path
-* Excluded_Source_Dirs
-* Locally_Removed_Files
-* Excluded_Source_Files
-* Excluded_Source_List_File
-* Interfaces
-
-The only package that is authorized (albeit optional) is Builder.
-
-The Project_Files attribute (See :ref:`Aggregate_Projects`) is used to
-described the aggregated projects whose object files have to be
-included into the aggregate library. The environment variables
-`ADA_PROJECT_PATH`, `GPR_PROJECT_PATH` and
-`GPR_PROJECT_PATH_FILE` are not used to find the project files.
-
-
-.. _Project_File_Reference:
-
-Project File Reference
-======================
-
-This section describes the syntactic structure of project files, the various
-constructs that can be used. Finally, it ends with a summary of all available
-attributes.
-
-
-.. _Project_Declaration:
-
-Project Declaration
--------------------
-
-Project files have an Ada-like syntax. The minimal project file is:
-
-.. code-block:: gpr
-
- project Empty is
- end Empty;
-
-The identifier `Empty` is the name of the project.
-This project name must be present after the reserved
-word `end` at the end of the project file, followed by a semi-colon.
-
-**Identifiers** (i.e., the user-defined names such as project or variable names)
-have the same syntax as Ada identifiers: they must start with a letter,
-and be followed by zero or more letters, digits or underscore characters;
-it is also illegal to have two underscores next to each other. Identifiers
-are always case-insensitive ("Name" is the same as "name").
-
-::
-
- simple_name ::= identifier
- name ::= simple_name { . simple_name }
-
-**Strings** are used for values of attributes or as indexes for these
-attributes. They are in general case sensitive, except when noted
-otherwise (in particular, strings representing file names will be case
-insensitive on some systems, so that "file.adb" and "File.adb" both
-represent the same file).
-
-**Reserved words** are the same as for standard Ada 95, and cannot
-be used for identifiers. In particular, the following words are currently
-used in project files, but others could be added later on. In bold are the
-extra reserved words in project files:
-``all``, ``at``, ``case``, ``end``, ``for``, ``is``, ``limited``,
-``null``, ``others``, ``package``, ``renames``, ``type``, ``use``, ``when``,
-``with``, **extends**, **external**, **project**.
-
-**Comments** in project files have the same syntax as in Ada, two consecutive
-hyphens through the end of the line.
-
-A project may be an **independent project**, entirely defined by a single
-project file. Any source file in an independent project depends only
-on the predefined library and other source files in the same project.
-But a project may also depend on other projects, either by importing them
-through **with clauses**, or by **extending** at most one other project. Both
-types of dependency can be used in the same project.
-
-A path name denotes a project file. It can be absolute or relative.
-An absolute path name includes a sequence of directories, in the syntax of
-the host operating system, that identifies uniquely the project file in the
-file system. A relative path name identifies the project file, relative
-to the directory that contains the current project, or relative to a
-directory listed in the environment variables ADA_PROJECT_PATH and
-GPR_PROJECT_PATH. Path names are case sensitive if file names in the host
-operating system are case sensitive. As a special case, the directory
-separator can always be "/" even on Windows systems, so that project files
-can be made portable across architectures.
-The syntax of the environment variables ADA_PROJECT_PATH and
-GPR_PROJECT_PATH is a list of directory names separated by colons on UNIX and
-semicolons on Windows.
-
-A given project name can appear only once in a context clause.
-
-It is illegal for a project imported by a context clause to refer, directly
-or indirectly, to the project in which this context clause appears (the
-dependency graph cannot contain cycles), except when one of the with clauses
-in the cycle is a **limited with**.
-
-.. code-block:: gpr
-
- with "other_project.gpr";
- project My_Project extends "extended.gpr" is
- end My_Project;
-
-These dependencies form a **directed graph**, potentially cyclic when using
-**limited with**. The subgraph reflecting the **extends** relations is a tree.
-
-A project's **immediate sources** are the source files directly defined by
-that project, either implicitly by residing in the project source directories,
-or explicitly through any of the source-related attributes.
-More generally, a project's **sources** are the immediate sources of the
-project together with the immediate sources (unless overridden) of any project
-on which it depends directly or indirectly.
-
-A **project hierarchy** can be created, where projects are children of
-other projects. The name of such a child project must be `Parent.Child`,
-where `Parent` is the name of the parent project. In particular, this
-makes all |with| clauses of the parent project automatically visible
-in the child project.
-
-::
-
- project ::= context_clause project_declaration
-
- context_clause ::= {with_clause}
- with_clause ::= *with* path_name { , path_name } ;
- path_name ::= string_literal
-
- project_declaration ::= simple_project_declaration | project_extension
- simple_project_declaration ::=
- project <project_>name is
- {declarative_item}
- end <project_>simple_name;
-
-
-.. _Qualified_Projects:
-
-Qualified Projects
-------------------
-
-Before the reserved `project`, there may be one or two **qualifiers**, that
-is identifiers or reserved words, to qualify the project.
-The current list of qualifiers is:
-
-**abstract**:
- Qualifies a project with no sources.
- Such a project must either have no declaration of attributes `Source_Dirs`,
- `Source_Files`, `Languages` or `Source_List_File`, or one of
- `Source_Dirs`, `Source_Files`, or `Languages` must be declared
- as empty. If it extends another project, the project it extends must also be a
- qualified abstract project.
-
-**standard**:
- A standard project is a non library project with sources.
- This is the default (implicit) qualifier.
-
-**aggregate**:
- A project whose sources are aggregated from other project files.
-
-**aggregate library**:
- A library whose sources are aggregated from other project
- or library project files.
-
-**library**:
- A library project must declare both attributes
- Library_Name` and `Library_Dir`.
-
-**configuration**:
- A configuration project cannot be in a project tree.
- It describes compilers and other tools to *gprbuild*.
-
-
-.. _Declarations:
-
-Declarations
-------------
-
-Declarations introduce new entities that denote types, variables, attributes,
-and packages. Some declarations can only appear immediately within a project
-declaration. Others can appear within a project or within a package.
-
-::
-
- declarative_item ::= simple_declarative_item
- | typed_string_declaration
- | package_declaration
-
- simple_declarative_item ::= variable_declaration
- | typed_variable_declaration
- | attribute_declaration
- | case_construction
- | empty_declaration
-
- empty_declaration ::= *null* ;
-
-An empty declaration is allowed anywhere a declaration is allowed. It has
-no effect.
-
-
-.. _Packages:
-
-Packages
---------
-
-A project file may contain **packages**, that group attributes (typically
-all the attributes that are used by one of the GNAT tools).
-
-A package with a given name may only appear once in a project file.
-The following packages are currently supported in project files
-(See :ref:`Attributes` for the list of attributes that each can contain).
-
-*Binder*
- This package specifies characteristics useful when invoking the binder either
- directly via the *gnat* driver or when using *gprbuild*.
- See :ref:`Main_Subprograms`.
-
-*Builder*
- This package specifies the compilation options used when building an
- executable or a library for a project. Most of the options should be
- set in one of `Compiler`, `Binder` or `Linker` packages,
- but there are some general options that should be defined in this
- package. See :ref:`Main_Subprograms`, and :ref:`Executable_File_Names` in
- particular.
-
-.. only:: PRO or GPL
-
- *Check*
- This package specifies the options used when calling the checking tool
- *gnatcheck* via the *gnat* driver. Its attribute
- **Default_Switches** has the same semantics as for the package
- `Builder`. The first string should always be `-rules` to specify
- that all the other options belong to the `-rules` section of the
- parameters to *gnatcheck*.
-
-*Clean*
- This package specifies the options used when cleaning a project or a project
- tree using the tools *gnatclean* or *gprclean*.
-
-*Compiler*
- This package specifies the compilation options used by the compiler for
- each languages. See :ref:`Tools_Options_in_Project_Files`.
-
-*Cross_Reference*
- This package specifies the options used when calling the library tool
- *gnatxref* via the *gnat* driver. Its attributes
- **Default_Switches** and **Switches** have the same semantics as for the
- package `Builder`.
-
-.. only:: PRO or GPL
-
- *Eliminate*
- This package specifies the options used when calling the tool
- *gnatelim* via the *gnat* driver. Its attributes
- **Default_Switches** and **Switches** have the same semantics as for the
- package `Builder`.
-
-*Finder*
- This package specifies the options used when calling the search tool
- *gnatfind* via the *gnat* driver. Its attributes
- **Default_Switches** and **Switches** have the same semantics as for the
- package `Builder`.
-
-*Gnatls*
- This package specifies the options to use when invoking *gnatls*
- via the *gnat* driver.
-
-.. only:: PRO or GPL
-
- *Gnatstub*
- This package specifies the options used when calling the tool
- *gnatstub* via the *gnat* driver. Its attributes
- **Default_Switches** and **Switches** have the same semantics as for the
- package `Builder`.
-
-*IDE*
- This package specifies the options used when starting an integrated
- development environment, for instance *GPS* or *Gnatbench*.
-
-*Install*
- This package specifies the options used when installing a project
- with *gprinstall*. See :ref:`Installation`.
-
-*Linker*
- This package specifies the options used by the linker.
- See :ref:`Main_Subprograms`.
-
-.. only:: PRO or GPL
-
- *Metrics*
- This package specifies the options used when calling the tool
- *gnatmetric* via the *gnat* driver. Its attributes
- **Default_Switches** and **Switches** have the same semantics as for the
- package `Builder`.
-
-*Naming*
- This package specifies the naming conventions that apply
- to the source files in a project. In particular, these conventions are
- used to automatically find all source files in the source directories,
- or given a file name to find out its language for proper processing.
- See :ref:`Naming_Schemes`.
-
- .. only:: PRO or GPL
-
- *Pretty_Printer*
- This package specifies the options used when calling the formatting tool
- *gnatpp* via the *gnat* driver. Its attributes
- **Default_Switches** and **Switches** have the same semantics as for the
- package `Builder`.
-
-*Remote*
- This package is used by *gprbuild* to describe how distributed
- compilation should be done.
-
-*Stack*
- This package specifies the options used when calling the tool
- *gnatstack* via the *gnat* driver. Its attributes
- **Default_Switches** and **Switches** have the same semantics as for the
- package `Builder`.
-
-*Synchronize*
- This package specifies the options used when calling the tool
- *gnatsync* via the *gnat* driver.
-
-In its simplest form, a package may be empty:
-
-.. code-block:: gpr
-
- project Simple is
- package Builder is
- end Builder;
- end Simple;
-
-A package may contain **attribute declarations**,
-**variable declarations** and **case constructions**, as will be
-described below.
-
-When there is ambiguity between a project name and a package name,
-the name always designates the project. To avoid possible confusion, it is
-always a good idea to avoid naming a project with one of the
-names allowed for packages or any name that starts with `gnat`.
-
-A package can also be defined by a **renaming declaration**. The new package
-renames a package declared in a different project file, and has the same
-attributes as the package it renames. The name of the renamed package
-must be the same as the name of the renaming package. The project must
-contain a package declaration with this name, and the project
-must appear in the context clause of the current project, or be its parent
-project. It is not possible to add or override attributes to the renaming
-project. If you need to do so, you should use an **extending declaration**
-(see below).
-
-Packages that are renamed in other project files often come from project files
-that have no sources: they are just used as templates. Any modification in the
-template will be reflected automatically in all the project files that rename
-a package from the template. This is a very common way to share settings
-between projects.
-
-Finally, a package can also be defined by an **extending declaration**. This is
-similar to a **renaming declaration**, except that it is possible to add or
-override attributes.
-
-::
-
- package_declaration ::= package_spec | package_renaming | package_extension
- package_spec ::=
- package <package_>simple_name is
- {simple_declarative_item}
- end package_identifier ;
- package_renaming ::==
- package <package_>simple_name renames <project_>simple_name.package_identifier ;
- package_extension ::==
- package <package_>simple_name extends <project_>simple_name.package_identifier is
- {simple_declarative_item}
- end package_identifier ;
-
-
-.. _Expressions:
-
-Expressions
------------
-
-An expression is any value that can be assigned to an attribute or a
-variable. It is either a literal value, or a construct requiring runtime
-computation by the project manager. In a project file, the computed value of
-an expression is either a string or a list of strings.
-
-A string value is one of:
-
-* A literal string, for instance `"comm/my_proj.gpr"`
-* The name of a variable that evaluates to a string (see :ref:`Variables`)
-* The name of an attribute that evaluates to a string (see :ref:`Attributes`)
-* An external reference (see :ref:`External_Values`)
-* A concatenation of the above, as in `"prefix_" & Var`.
-
-A list of strings is one of the following:
-
-* A parenthesized comma-separated list of zero or more string expressions, for
- instance `(File_Name, "gnat.adc", File_Name & ".orig")` or `()`.
-* The name of a variable that evaluates to a list of strings
-* The name of an attribute that evaluates to a list of strings
-* A concatenation of a list of strings and a string (as defined above), for
- instance `("A", "B") & "C"`
-* A concatenation of two lists of strings
-
-The following is the grammar for expressions
-
-::
-
- string_literal ::= "{string_element}" -- Same as Ada
- string_expression ::= string_literal
- | *variable_*name
- | external_value
- | attribute_reference
- | ( string_expression { & string_expression } )
- string_list ::= ( string_expression { , string_expression } )
- | *string_variable*_name
- | *string_*attribute_reference
- term ::= string_expression | string_list
- expression ::= term { & term } -- Concatenation
-
-Concatenation involves strings and list of strings. As soon as a list of
-strings is involved, the result of the concatenation is a list of strings. The
-following Ada declarations show the existing operators:
-
-.. code-block:: ada
-
- function "&" (X : String; Y : String) return String;
- function "&" (X : String_List; Y : String) return String_List;
- function "&" (X : String_List; Y : String_List) return String_List;
-
-
-Here are some specific examples:
-
-.. code-block:: ada
-
- List := () & File_Name; -- One string in this list
- List2 := List & (File_Name & ".orig"); -- Two strings
- Big_List := List & Lists2; -- Three strings
- Illegal := "gnat.adc" & List2; -- Illegal, must start with list
-
-
-.. _External_Values:
-
-External Values
----------------
-
-An external value is an expression whose value is obtained from the command
-that invoked the processing of the current project file (typically a
-*gprbuild* command).
-
-There are two kinds of external values, one that returns a single string, and
-one that returns a string list.
-
-The syntax of a single string external value is::
-
- external_value ::= *external* ( string_literal [, string_literal] )
-
-
-The first string_literal is the string to be used on the command line or
-in the environment to specify the external value. The second string_literal,
-if present, is the default to use if there is no specification for this
-external value either on the command line or in the environment.
-
-Typically, the external value will either exist in the
-environment variables
-or be specified on the command line through the
-:samp:`-X{vbl}={value}` switch. If both
-are specified, then the command line value is used, so that a user can more
-easily override the value.
-
-The function `external` always returns a string. It is an error if the
-value was not found in the environment and no default was specified in the
-call to `external`.
-
-An external reference may be part of a string expression or of a string
-list expression, and can therefore appear in a variable declaration or
-an attribute declaration.
-
-Most of the time, this construct is used to initialize typed variables, which
-are then used in **case** constructions to control the value assigned to
-attributes in various scenarios. Thus such variables are often called
-**scenario variables**.
-
-The syntax for a string list external value is::
-
- external_value ::= *external_as_list* ( string_literal , string_literal )
-
-
-The first string_literal is the string to be used on the command line or
-in the environment to specify the external value. The second string_literal is
-the separator between each component of the string list.
-
-If the external value does not exist in the environment or on the command line,
-the result is an empty list. This is also the case, if the separator is an
-empty string or if the external value is only one separator.
-
-Any separator at the beginning or at the end of the external value is
-discarded. Then, if there is no separator in the external value, the result is
-a string list with only one string. Otherwise, any string between the beginning
-and the first separator, between two consecutive separators and between the
-last separator and the end are components of the string list.
-
-::
-
- *external_as_list* ("SWITCHES", ",")
-
-If the external value is "-O2,-g",
-the result is ("-O2", "-g").
-
-If the external value is ",-O2,-g,",
-the result is also ("-O2", "-g").
-
-if the external value is "-gnatv",
-the result is ("-gnatv").
-
-If the external value is ",,", the result is ("").
-
-If the external value is ",", the result is (), the empty string list.
-
-
-.. _Typed_String_Declaration:
-
-Typed String Declaration
-------------------------
-
-A **type declaration** introduces a discrete set of string literals.
-If a string variable is declared to have this type, its value
-is restricted to the given set of literals. These are the only named
-types in project files. A string type may only be declared at the project
-level, not inside a package.
-
-::
-
- typed_string_declaration ::=
- *type* *<typed_string_>*_simple_name *is* ( string_literal {, string_literal} );
-
-The string literals in the list are case sensitive and must all be different.
-They may include any graphic characters allowed in Ada, including spaces.
-Here is an example of a string type declaration:
-
-.. code-block:: ada
-
- type OS is ("NT", "nt", "Unix", "GNU/Linux", "other OS");
-
-Variables of a string type are called **typed variables**; all other
-variables are called **untyped variables**. Typed variables are
-particularly useful in `case` constructions, to support conditional
-attribute declarations. (See :ref:`Case_Constructions`).
-
-A string type may be referenced by its name if it has been declared in the same
-project file, or by an expanded name whose prefix is the name of the project
-in which it is declared.
-
-
-.. _Variables:
-
-Variables
----------
-
-**Variables** store values (strings or list of strings) and can appear
-as part of an expression. The declaration of a variable creates the
-variable and assigns the value of the expression to it. The name of the
-variable is available immediately after the assignment symbol, if you
-need to reuse its old value to compute the new value. Before the completion
-of its first declaration, the value of a variable defaults to the empty
-string ("").
-
-A **typed** variable can be used as part of a **case** expression to
-compute the value, but it can only be declared once in the project file,
-so that all case constructions see the same value for the variable. This
-provides more consistency and makes the project easier to understand.
-The syntax for its declaration is identical to the Ada syntax for an
-object declaration. In effect, a typed variable acts as a constant.
-
-An **untyped** variable can be declared and overridden multiple times
-within the same project. It is declared implicitly through an Ada
-assignment. The first declaration establishes the kind of the variable
-(string or list of strings) and successive declarations must respect
-the initial kind. Assignments are executed in the order in which they
-appear, so the new value replaces the old one and any subsequent reference
-to the variable uses the new value.
-
-A variable may be declared at the project file level, or within a package.
-
-::
-
- typed_variable_declaration ::=
- *<typed_variable_>*simple_name : *<typed_string_>*name := string_expression;
-
- variable_declaration ::= *<variable_>*simple_name := expression;
-
-Here are some examples of variable declarations:
-
-.. code-block:: gpr
-
- This_OS : OS := external ("OS"); -- a typed variable declaration
- That_OS := "GNU/Linux"; -- an untyped variable declaration
-
- Name := "readme.txt";
- Save_Name := Name & ".saved";
-
- Empty_List := ();
- List_With_One_Element := ("-gnaty");
- List_With_Two_Elements := List_With_One_Element & "-gnatg";
- Long_List := ("main.ada", "pack1_.ada", "pack1.ada", "pack2_.ada");
-
-A **variable reference** may take several forms:
-
-* The simple variable name, for a variable in the current package (if any)
- or in the current project
-* An expanded name, whose prefix is a context name.
-
-A **context** may be one of the following:
-
-* The name of an existing package in the current project
-* The name of an imported project of the current project
-* The name of an ancestor project (i.e., a project extended by the current
- project, either directly or indirectly)
-* An expanded name whose prefix is an imported/parent project name, and
- whose selector is a package name in that project.
-
-
-.. _Case_Constructions:
-
-Case Constructions
-------------------
-
-A **case** construction is used in a project file to effect conditional
-behavior. Through this construction, you can set the value of attributes
-and variables depending on the value previously assigned to a typed
-variable.
-
-All choices in a choice list must be distinct. Unlike Ada, the choice
-lists of all alternatives do not need to include all values of the type.
-An `others` choice must appear last in the list of alternatives.
-
-The syntax of a `case` construction is based on the Ada case construction
-(although the `null` declaration for empty alternatives is optional).
-
-The case expression must be a string variable, either typed or not, whose value
-is often given by an external reference (see :ref:`External_Values`).
-
-Each alternative starts with the reserved word `when`, either a list of
-literal strings separated by the `"|"` character or the reserved word
-`others`, and the `"=>"` token.
-When the case expression is a typed string variable, each literal string must
-belong to the string type that is the type of the case variable.
-After each `=>`, there are zero or more declarations. The only
-declarations allowed in a case construction are other case constructions,
-attribute declarations and variable declarations. String type declarations and
-package declarations are not allowed. Variable declarations are restricted to
-variables that have already been declared before the case construction.
-
-::
-
- case_construction ::=
- *case* *<variable_>*name *is* {case_item} *end case* ;
-
- case_item ::=
- *when* discrete_choice_list =>
- {case_declaration
- | attribute_declaration
- | variable_declaration
- | empty_declaration}
-
- discrete_choice_list ::= string_literal {| string_literal} | *others*
-
-Here is a typical example, with a typed string variable:
-
-.. code-block:: gpr
-
- project MyProj is
- type OS_Type is ("GNU/Linux", "Unix", "NT", "VMS");
- OS : OS_Type := external ("OS", "GNU/Linux");
-
- package Compiler is
- case OS is
- when "GNU/Linux" | "Unix" =>
- for Switches ("Ada")
- use ("-gnath");
- when "NT" =>
- for Switches ("Ada")
- use ("-gnatP");
- when others =>
- null;
- end case;
- end Compiler;
- end MyProj;
-
-
-.. _Attributes:
-
-Attributes
-----------
-
-A project (and its packages) may have **attributes** that define
-the project's properties. Some attributes have values that are strings;
-others have values that are string lists.
-
-::
-
- attribute_declaration ::=
- simple_attribute_declaration | indexed_attribute_declaration
-
- simple_attribute_declaration ::= *for* attribute_designator *use* expression ;
-
- indexed_attribute_declaration ::=
- *for* *<indexed_attribute_>*simple_name ( string_literal) *use* expression ;
-
- attribute_designator ::=
- *<simple_attribute_>*simple_name
- | *<indexed_attribute_>*simple_name ( string_literal )
-
-There are two categories of attributes: **simple attributes**
-and **indexed attributes**.
-Each simple attribute has a default value: the empty string (for string
-attributes) and the empty list (for string list attributes).
-An attribute declaration defines a new value for an attribute, and overrides
-the previous value. The syntax of a simple attribute declaration is similar to
-that of an attribute definition clause in Ada.
-
-Some attributes are indexed. These attributes are mappings whose
-domain is a set of strings. They are declared one association
-at a time, by specifying a point in the domain and the corresponding image
-of the attribute.
-Like untyped variables and simple attributes, indexed attributes
-may be declared several times. Each declaration supplies a new value for the
-attribute, and replaces the previous setting.
-
-Here are some examples of attribute declarations:
-
-.. code-block:: gpr
-
- -- simple attributes
- for Object_Dir use "objects";
- for Source_Dirs use ("units", "test/drivers");
-
- -- indexed attributes
- for Body ("main") use "Main.ada";
- for Switches ("main.ada")
- use ("-v", "-gnatv");
- for Switches ("main.ada") use Builder'Switches ("main.ada") & "-g";
-
- -- indexed attributes copy (from package Builder in project Default)
- -- The package name must always be specified, even if it is the current
- -- package.
- for Default_Switches use Default.Builder'Default_Switches;
-
-Attributes references may appear anywhere in expressions, and are used
-to retrieve the value previously assigned to the attribute. If an attribute
-has not been set in a given package or project, its value defaults to the
-empty string or the empty list, with some exceptions.
-
-::
-
- attribute_reference ::=
- attribute_prefix ' *<simple_attribute>_*simple_name [ (string_literal) ]
- attribute_prefix ::= *project*
- | *<project_>*simple_name
- | package_identifier
- | *<project_>*simple_name . package_identifier
-
-Examples are::
-
- <project>'Object_Dir
- Naming'Dot_Replacement
- Imported_Project'Source_Dirs
- Imported_Project.Naming'Casing
- Builder'Default_Switches ("Ada")
-
-The exceptions to the empty defaults are:
-
-* Object_Dir: default is "."
-* Exec_Dir: default is 'Object_Dir, that is the value of attribute
- Object_Dir in the same project, declared or defaulted.
-* Source_Dirs: default is (".")
-
-The prefix of an attribute may be:
-
-* `project` for an attribute of the current project
-* The name of an existing package of the current project
-* The name of an imported project
-* The name of a parent project that is extended by the current project
-* An expanded name whose prefix is imported/parent project name,
- and whose selector is a package name
-
-In the following sections, all predefined attributes are succinctly described,
-first the project level attributes, that is those attributes that are not in a
-package, then the attributes in the different packages.
-
-It is possible for different tools to dynamically create new packages with
-attributes, or new attributes in predefined packages. These attributes are
-not documented here.
-
-The attributes under Configuration headings are usually found only in
-configuration project files.
-
-The characteristics of each attribute are indicated as follows:
-
-* **Type of value**
-
- The value of an attribute may be a single string, indicated by the word
- "single", or a string list, indicated by the word "list".
-
-* **Read-only**
-
- When the attribute is read-only, that is when it is not allowed to declare
- the attribute, this is indicated by the words "read-only".
-
-* **Optional index**
-
- If it is allowed in the value of the attribute (both single and list) to have
- an optional index, this is indicated by the words "optional index".
-
-* **Indexed attribute**
-
- When it is an indexed attribute, this is indicated by the word "indexed".
-
-* **Case-sensitivity of the index**
-
- For an indexed attribute, if the index is case-insensitive, this is indicated
- by the words "case-insensitive index".
-
-* **File name index**
-
- For an indexed attribute, when the index is a file name, this is indicated by
- the words "file name index". The index may or may not be case-sensitive,
- depending on the platform.
-
-* **others allowed in index**
-
- For an indexed attribute, if it is allowed to use **others** as the index,
- this is indicated by the words "others allowed".
-
- When **others** is used as the index of an indexed attribute, the value of
- the attribute indexed by **others** is used when no other index would apply.
-
-
-.. _Project_Level_Attributes:
-
-Project Level Attributes
-^^^^^^^^^^^^^^^^^^^^^^^^
-
-
-* **General**
-
- * **Name**: single, read-only
-
- The name of the project.
-
- * **Project_Dir**: single, read-only
-
- The path name of the project directory.
-
- * **Main**: list, optional index
-
- The list of main sources for the executables.
-
- * **Languages**: list
-
- The list of languages of the sources of the project.
-
- * **Roots**: list, indexed, file name index
-
- The index is the file name of an executable source. Indicates the list of units
- from the main project that need to be bound and linked with their closures
- with the executable. The index is either a file name, a language name or "*".
- The roots for an executable source are those in **Roots** with an index that
- is the executable source file name, if declared. Otherwise, they are those in
- **Roots** with an index that is the language name of the executable source,
- if present. Otherwise, they are those in **Roots ("*")**, if declared. If none
- of these three possibilities are declared, then there are no roots for the
- executable source.
-
- * **Externally_Built**: single
-
- Indicates if the project is externally built.
- Only case-insensitive values allowed are "true" and "false", the default.
-
-* **Directories**
-
- * **Object_Dir**: single
-
- Indicates the object directory for the project.
-
- * **Exec_Dir**: single
-
- Indicates the exec directory for the project, that is the directory where the
- executables are.
-
- * **Source_Dirs**: list
-
- The list of source directories of the project.
-
- * **Inherit_Source_Path**: list, indexed, case-insensitive index
-
- Index is a language name. Value is a list of language names. Indicates that
- in the source search path of the index language the source directories of
- the languages in the list should be included.
-
- Example:
-
- .. code-block:: gpr
-
- for Inherit_Source_Path ("C++") use ("C");
-
- * **Exclude_Source_Dirs**: list
-
- The list of directories that are included in Source_Dirs but are not source
- directories of the project.
-
- * **Ignore_Source_Sub_Dirs**: list
-
- Value is a list of simple names for subdirectories that are removed from the
- list of source directories, including theur subdirectories.
-
-* **Source Files**
-
- * **Source_Files**: list
-
- Value is a list of source file simple names.
-
- * **Locally_Removed_Files**: list
-
- Obsolescent. Equivalent to Excluded_Source_Files.
-
- * **Excluded_Source_Files**: list
-
- Value is a list of simple file names that are not sources of the project.
- Allows to remove sources that are inherited or found in the source directories
- and that match the naming scheme.
-
- * **Source_List_File**: single
-
- Value is a text file name that contains a list of source file simple names,
- one on each line.
-
- * **Excluded_Source_List_File**: single
-
- Value is a text file name that contains a list of file simple names that
- are not sources of the project.
-
- * **Interfaces**: list
-
- Value is a list of file names that constitutes the interfaces of the project.
-
-* **Aggregate Projects**
-
- * **Project_Files**: list
-
- Value is the list of aggregated projects.
-
- * **Project_Path**: list
-
- Value is a list of directories that are added to the project search path when
- looking for the aggregated projects.
-
- * **External**: single, indexed
-
- Index is the name of an external reference. Value is the value of the
- external reference to be used when parsing the aggregated projects.
-
-* **Libraries**
-
- * **Library_Dir**: single
-
- Value is the name of the library directory. This attribute needs to be
- declared for each library project.
-
- * **Library_Name**: single
-
- Value is the name of the library. This attribute needs to be declared or
- inherited for each library project.
-
- * **Library_Kind**: single
-
- Specifies the kind of library: static library (archive) or shared library.
- Case-insensitive values must be one of "static" for archives (the default) or
- "dynamic" or "relocatable" for shared libraries.
-
- * **Library_Version**: single
-
- Value is the name of the library file.
-
- * **Library_Interface**: list
-
- Value is the list of unit names that constitutes the interfaces
- of a Stand-Alone Library project.
-
- * **Library_Standalone**: single
-
- Specifies if a Stand-Alone Library (SAL) is encapsulated or not.
- Only authorized case-insensitive values are "standard" for non encapsulated
- SALs, "encapsulated" for encapsulated SALs or "no" for non SAL library project.
-
- * **Library_Encapsulated_Options**: list
-
- Value is a list of options that need to be used when linking an encapsulated
- Stand-Alone Library.
-
- * **Library_Encapsulated_Supported**: single
-
- Indicates if encapsulated Stand-Alone Libraries are supported. Only
- authorized case-insensitive values are "true" and "false" (the default).
-
- * **Library_Auto_Init**: single
-
- Indicates if a Stand-Alone Library is auto-initialized. Only authorized
- case-insentive values are "true" and "false".
-
- * **Leading_Library_Options**: list
-
- Value is a list of options that are to be used at the beginning of
- the command line when linking a shared library.
-
- * **Library_Options**: list
-
- Value is a list of options that are to be used when linking a shared library.
-
- * **Library_Rpath_Options**: list, indexed, case-insensitive index
-
- Index is a language name. Value is a list of options for an invocation of the
- compiler of the language. This invocation is done for a shared library project
- with sources of the language. The output of the invocation is the path name
- of a shared library file. The directory name is to be put in the run path
- option switch when linking the shared library for the project.
-
- * **Library_Src_Dir**: single
-
- Value is the name of the directory where copies of the sources of the
- interfaces of a Stand-Alone Library are to be copied.
-
- * **Library_ALI_Dir**: single
-
- Value is the name of the directory where the ALI files of the interfaces
- of a Stand-Alone Library are to be copied. When this attribute is not declared,
- the directory is the library directory.
-
- * **Library_gcc**: single
-
- Obsolescent attribute. Specify the linker driver used to link a shared library.
- Use instead attribute Linker'Driver.
-
- * **Library_Symbol_File**: single
-
- Value is the name of the library symbol file.
-
- * **Library_Symbol_Policy**: single
-
- Indicates the symbol policy kind. Only authorized case-insensitive values are
- "autonomous", "default", "compliant", "controlled" or "direct".
-
- * **Library_Reference_Symbol_File**: single
-
- Value is the name of the reference symbol file.
-
-* **Configuration - General**
-
- * **Default_Language**: single
-
- Value is the case-insensitive name of the language of a project when attribute
- Languages is not specified.
-
- * **Run_Path_Option**: list
-
- Value is the list of switches to be used when specifying the run path option
- in an executable.
-
- * **Run_Path_Origin**: single
-
- Value is the the string that may replace the path name of the executable
- directory in the run path options.
-
- * **Separate_Run_Path_Options**: single
-
- Indicates if there may be several run path options specified when linking an
- executable. Only authorized case-insensitive values are "true" or "false" (the
- default).
-
- * **Toolchain_Version**: single, indexed, case-insensitive index
-
- Index is a language name. Specify the version of a toolchain for a language.
-
- * **Toolchain_Description**: single, indexed, case-insensitive index
-
- Obsolescent. No longer used.
-
- * **Object_Generated**: single, indexed, case-insensitive index
-
- Index is a language name. Indicates if invoking the compiler for a language
- produces an object file. Only authorized case-insensitive values are "false"
- and "true" (the default).
-
- * **Objects_Linked**: single, indexed, case-insensitive index
-
- Index is a language name. Indicates if the object files created by the compiler
- for a language need to be linked in the executable. Only authorized
- case-insensitive values are "false" and "true" (the default).
-
- * **Target**: single
-
- Value is the name of the target platform. Taken into account only in the main
- project.
-
- Note that when the target is specified on the command line (usually with
- a switch --target=), the value of attribute reference 'Target is the one
- specified on the command line.
-
- * **Runtime**: single, indexed, case-insensitive index
-
- Index is a language name. Indicates the runtime directory that is to be used
- when using the compiler of the language. Taken into account only in the main
- project.
-
- Note that when the runtime is specified for a language on the command line
- (usually with a switch --RTS), the value of attribute reference 'Runtime
- for this language is the one specified on the command line.
-
-* **Configuration - Libraries**
-
- * **Library_Builder**: single
-
- Value is the path name of the application that is to be used to build
- libraries. Usually the path name of "gprlib".
-
- * **Library_Support**: single
-
- Indicates the level of support of libraries. Only authorized case-insensitive
- values are "static_only", "full" or "none" (the default).
-
-* **Configuration - Archives**
-
- * **Archive_Builder**: list
-
- Value is the name of the application to be used to create a static library
- (archive), followed by the options to be used.
-
- * **Archive_Builder_Append_Option**: list
-
- Value is the list of options to be used when invoking the archive builder
- to add project files into an archive.
-
- * **Archive_Indexer**: list
-
- Value is the name of the archive indexer, followed by the required options.
-
- * **Archive_Suffix**: single
-
- Value is the extension of archives. When not declared, the extension is ".a".
-
- * **Library_Partial_Linker**: list
-
- Value is the name of the partial linker executable, followed by the required
- options.
-
-* **Configuration - Shared Libraries**
-
- * **Shared_Library_Prefix**: single
-
- Value is the prefix in the name of shared library files. When not declared,
- the prefix is "lib".
-
- * **Shared_Library_Suffix**: single
-
- Value is the the extension of the name of shared library files. When not
- declared, the extension is ".so".
-
- * **Symbolic_Link_Supported**: single
-
- Indicates if symbolic links are supported on the platform. Only authorized
- case-insensitive values are "true" and "false" (the default).
-
- * **Library_Major_Minor_Id_Supported**: single
-
- Indicates if major and minor ids for shared library names are supported on
- the platform. Only authorized case-insensitive values are "true" and "false"
- (the default).
-
- * **Library_Auto_Init_Supported**: single
-
- Indicates if auto-initialization of Stand-Alone Libraries is supported. Only
- authorized case-insensitive values are "true" and "false" (the default).
-
- * **Shared_Library_Minimum_Switches**: list
-
- Value is the list of required switches when linking a shared library.
-
- * **Library_Version_Switches**: list
-
- Value is the list of switches to specify a internal name for a shared library.
-
- * **Library_Install_Name_Option**: single
-
- Value is the name of the option that needs to be used, concatenated with the
- path name of the library file, when linking a shared library.
-
- * **Runtime_Library_Dir**: single, indexed, case-insensitive index
-
- Index is a language name. Value is the path name of the directory where the
- runtime libraries are located.
-
- * **Runtime_Source_Dir**: single, indexed, case-insensitive index
-
- Index is a language name. Value is the path name of the directory where the
- sources of runtime libraries are located.
-
-
-.. _Package_Binder_Attributes:
-
-Package Binder Attributes
-^^^^^^^^^^^^^^^^^^^^^^^^^
-
-* **General**
-
- * **Default_Switches**: list, indexed, case-insensitive index
-
- Index is a language name. Value is the list of switches to be used when binding
- code of the language, if there is no applicable attribute Switches.
-
- * **Switches**: list, optional index, indexed,
- case-insensitive index, others allowed
-
- Index is either a language name or a source file name. Value is the list of
- switches to be used when binding code. Index is either the source file name
- of the executable to be bound or the language name of the code to be bound.
-
-* **Configuration - Binding**
-
- * **Driver**: single, indexed, case-insensitive index
-
- Index is a language name. Value is the name of the application to be used when
- binding code of the language.
-
- * **Required_Switches**: list, indexed, case-insensitive index
-
- Index is a language name. Value is the list of the required switches to be
- used when binding code of the language.
-
- * **Prefix**: single, indexed, case-insensitive index
-
- Index is a language name. Value is a prefix to be used for the binder exchange
- file name for the language. Used to have different binder exchange file names
- when binding different languages.
-
- * **Objects_Path**: single,indexed, case-insensitive index
-
- Index is a language name. Value is the name of the environment variable that
- contains the path for the object directories.
-
- * **Object_Path_File**: single,indexed, case-insensitive index
-
- Index is a language name. Value is the name of the environment variable. The
- value of the environment variable is the path name of a text file that
- contains the list of object directories.
-
-
-.. _Package_Builder_Attributes:
-
-Package Builder Attributes
-^^^^^^^^^^^^^^^^^^^^^^^^^^
-
-* **Default_Switches**: list, indexed, case-insensitive index
-
- Index is a language name. Value is the list of builder switches to be used when
- building an executable of the language, if there is no applicable attribute
- Switches.
-
-* **Switches**: list, optional index, indexed, case-insensitive index,
- others allowed
-
- Index is either a language name or a source file name. Value is the list of
- builder switches to be used when building an executable. Index is either the
- source file name of the executable to be built or its language name.
-
-* **Global_Compilation_Switches**: list, optional index, indexed,
- case-insensitive index
-
- Index is either a language name or a source file name. Value is the list of
- compilation switches to be used when building an executable. Index is either
- the source file name of the executable to be built or its language name.
-
-* **Executable**: single, indexed, case-insensitive index
-
- Index is an executable source file name. Value is the simple file name of the
- executable to be built.
-
-* **Executable_Suffix**: single
-
- Value is the extension of the file names of executable. When not specified,
- the extension is the default extension of executables on the platform.
-
-* **Global_Configuration_Pragmas**: single
-
- Value is the file name of a configuration pragmas file that is specified to
- the Ada compiler when compiling any Ada source in the project tree.
-
-* **Global_Config_File**: single, indexed, case-insensitive index
-
- Index is a language name. Value is the file name of a configuration file that
- is specified to the compiler when compiling any source of the language in the
- project tree.
-
-
-.. only:: PRO and GPL
-
- .. _Package_Check_Attributes:
-
- Package Check Attributes
- ^^^^^^^^^^^^^^^^^^^^^^^^
-
- * **Default_Switches**: list, indexed, case-insensitive index
-
- Index is a language name. Value is a list of switches to be used when invoking
- `gnatcheck` for a source of the language, if there is no applicable
- attribute Switches.
-
- * **Switches**: list, optional index, indexed, case-insensitive index,
- others allowed
-
- Index is a source file name. Value is the list of switches to be used when
- invoking `gnatcheck` for the source.
-
-.. _Package_Clean_Attributes:
-
-Package Clean Attributes
-^^^^^^^^^^^^^^^^^^^^^^^^
-
-* **Switches**: list
-
- Value is a list of switches to be used by the cleaning application.
-
-* **Source_Artifact_Extensions**: list, indexed, case-insensitive index
-
- Index is a language names. Value is the list of extensions for file names
- derived from object file names that need to be cleaned in the object
- directory of the project.
-
-* **Object_Artifact_Extensions**: list, indexed, case-insensitive index
-
- Index is a language names. Value is the list of extensions for file names
- derived from source file names that need to be cleaned in the object
- directory of the project.
-
-* **Artifacts_In_Object_Dir**: single
-
- Value is a list of file names expressed as regular expressions that are to be
- deleted by gprclean in the object directory of the project.
-
-* **Artifacts_In_Exec_Dir**: single
-
- Value is list of file names expressed as regular expressions that are to be
- deleted by gprclean in the exec directory of the main project.
-
-.. _Package_Compiler_Attributes:
-
-Package Compiler Attributes
-^^^^^^^^^^^^^^^^^^^^^^^^^^^
-
-* **General**
-
- * **Default_Switches**: list, indexed, case-insensitive index
-
- Index is a language name. Value is a list of switches to be used when invoking
- the compiler for the language for a source of the project, if there is no
- applicable attribute Switches.
-
- * **Switches**: list, optional index, indexed, case-insensitive index,
- others allowed
-
- Index is a source file name or a language name. Value is the list of switches
- to be used when invoking the compiler for the source or for its language.
-
- * **Local_Configuration_Pragmas**: single
-
- Value is the file name of a configuration pragmas file that is specified to
- the Ada compiler when compiling any Ada source in the project.
-
- * **Local_Config_File**: single, indexed, case-insensitive index
-
- Index is a language name. Value is the file name of a configuration file that
- is specified to the compiler when compiling any source of the language in the
- project.
-
-* **Configuration - Compiling**
-
- * **Driver**: single, indexed, case-insensitive index
-
- Index is a language name. Value is the name of the executable for the compiler
- of the language.
-
- * **Language_Kind**: single, indexed, case-insensitive index
-
- Index is a language name. Indicates the kind of the language, either file based
- or unit based. Only authorized case-insensitive values are "unit_based" and
- "file_based" (the default).
-
- * **Dependency_Kind**: single, indexed, case-insensitive index
-
- Index is a language name. Indicates how the dependencies are handled for the
- language. Only authorized case-insensitive values are "makefile", "ali_file",
- "ali_closure" or "none" (the default).
-
- * **Required_Switches**: list, indexed, case-insensitive index
-
- Equivalent to attribute Leading_Required_Switches.
-
- * **Leading_Required_Switches**: list, indexed, case-insensitive index
-
- Index is a language name. Value is the list of the minimum switches to be used
- at the beginning of the command line when invoking the compiler for the
- language.
-
- * **Trailing_Required_Switches**: list, indexed, case-insensitive index
-
- Index is a language name. Value is the list of the minimum switches to be used
- at the end of the command line when invoking the compiler for the language.
-
- * **PIC_Option**: list, indexed, case-insensitive index
-
- Index is a language name. Value is the list of switches to be used when
- compiling a source of the language when the project is a shared library
- project.
-
- * **Path_Syntax**: single, indexed, case-insensitive index
-
- Index is a language name. Value is the kind of path syntax to be used when
- invoking the compiler for the language. Only authorized case-insensitive
- values are "canonical" and "host" (the default).
-
- * **Source_File_Switches**: single, indexed, case-insensitive index
-
- Index is a language name. Value is a list of switches to be used just before
- the path name of the source to compile when invoking the compiler for a source
- of the language.
-
- * **Object_File_Suffix**: single, indexed, case-insensitive index
-
- Index is a language name. Value is the extension of the object files created
- by the compiler of the language. When not specified, the extension is the
- default one for the platform.
-
- * **Object_File_Switches**: list, indexed, case-insensitive index
-
- Index is a language name. Value is the list of switches to be used by the
- compiler of the language to specify the path name of the object file. When not
- specified, the switch used is "-o".
-
- * **Multi_Unit_Switches**: list, indexed, case-insensitive index
-
- Index is a language name. Value is the list of switches to be used to compile
- a unit in a multi unit source of the language. The index of the unit in the
- source is concatenated with the last switches in the list.
-
- * **Multi_Unit_Object_Separator**: single, indexed, case-insensitive index
-
- Index is a language name. Value is the string to be used in the object file
- name before the index of the unit, when compiling a unit in a multi unit source
- of the language.
-
-* **Configuration - Mapping Files**
-
- * **Mapping_File_Switches**: list, indexed, case-insensitive index
-
- Index is a language name. Value is the list of switches to be used to specify
- a mapping file when invoking the compiler for a source of the language.
-
- * **Mapping_Spec_Suffix**: single, indexed, case-insensitive index
-
- Index is a language name. Value is the suffix to be used in a mapping file
- to indicate that the source is a spec.
-
- * **Mapping_Body_Suffix**: single, indexed, case-insensitive index
-
- Index is a language name. Value is the suffix to be used in a mapping file
- to indicate that the source is a body.
-
-* **Configuration - Config Files**
-
- * **Config_File_Switches**: list: single, indexed, case-insensitive index
-
- Index is a language name. Value is the list of switches to specify to the
- compiler of the language a configuration file.
-
- * **Config_Body_File_Name**: single, indexed, case-insensitive index
-
- Index is a language name. Value is the template to be used to indicate a
- configuration specific to a body of the language in a configuration
- file.
-
- * **Config_Body_File_Name_Index**: single, indexed, case-insensitive index
-
- Index is a language name. Value is the template to be used to indicate a
- configuration specific to the body a unit in a multi unit source of the
- language in a configuration file.
-
- * **Config_Body_File_Name_Pattern**: single, indexed,
- case-insensitive index
-
- Index is a language name. Value is the template to be used to indicate a
- configuration for all bodies of the languages in a configuration file.
-
- * **Config_Spec_File_Name**: single, indexed, case-insensitive index
-
- Index is a language name. Value is the template to be used to indicate a
- configuration specific to a spec of the language in a configuration
- file.
-
- * **Config_Spec_File_Name_Index**: single, indexed, case-insensitive index
-
- Index is a language name. Value is the template to be used to indicate a
- configuration specific to the spec a unit in a multi unit source of the
- language in a configuration file.
-
- * **Config_Spec_File_Name_Pattern**: single, indexed,
- case-insensitive index
-
- Index is a language name. Value is the template to be used to indicate a
- configuration for all specs of the languages in a configuration file.
-
- * **Config_File_Unique**: single, indexed, case-insensitive index
-
- Index is a language name. Indicates if there should be only one configuration
- file specified to the compiler of the language. Only authorized
- case-insensitive values are "true" and "false" (the default).
-
-* **Configuration - Dependencies**
-
- * **Dependency_Switches**: list, indexed, case-insensitive index
-
- Index is a language name. Value is the list of switches to be used to specify
- to the compiler the dependency file when the dependency kind of the language is
- file based, and when Dependency_Driver is not specified for the language.
-
- * **Dependency_Driver**: list, indexed, case-insensitive index
-
- Index is a language name. Value is the name of the executable to be used to
- create the dependency file for a source of the language, followed by the
- required switches.
-
-* **Configuration - Search Paths**
-
- * **Include_Switches**: list, indexed, case-insensitive index
-
- Index is a language name. Value is the list of switches to specify to the
- compiler of the language to indicate a directory to look for sources.
-
- * **Include_Path**: single, indexed, case-insensitive index
-
- Index is a language name. Value is the name of an environment variable that
- contains the path of all the directories that the compiler of the language
- may search for sources.
-
- * **Include_Path_File**: single, indexed, case-insensitive index
-
- Index is a language name. Value is the name of an environment variable the
- value of which is the path name of a text file that contains the directories
- that the compiler of the language may search for sources.
-
- * **Object_Path_Switches**: list, indexed, case-insensitive index
-
- Index is a language name. Value is the list of switches to specify to the
- compiler of the language the name of a text file that contains the list of
- object directories. When this attribute is not declared, the text file is
- not created.
-
-
-.. _Package_Cross_Reference_Attributes:
-
-Package Cross_Reference Attributes
-^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-
-* **Default_Switches**: list, indexed, case-insensitive index
-
- Index is a language name. Value is a list of switches to be used when invoking
- `gnatxref` for a source of the language, if there is no applicable
- attribute Switches.
-
-* **Switches**: list, optional index, indexed, case-insensitive index,
- others allowed
-
- Index is a source file name. Value is the list of switches to be used when
- invoking `gnatxref` for the source.
-
-
-.. only:: PRO or GPL
-
- .. _Package_Eliminate_Attributes:
-
- Package Eliminate Attributes
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-
- * **Default_Switches**: list, indexed, case-insensitive index
-
- Index is a language name. Value is a list of switches to be used when invoking
- `gnatelim` for a source of the language, if there is no applicable
- attribute Switches.
-
- * **Switches**: list, optional index, indexed, case-insensitive index,
- others allowed
-
- Index is a source file name. Value is the list of switches to be used when
- invoking `gnatelim` for the source.
-
-.. _Package_Finder_Attributes:
-
-Package Finder Attributes
-^^^^^^^^^^^^^^^^^^^^^^^^^
-
-* **Default_Switches**: list, indexed, case-insensitive index
-
- Index is a language name. Value is a list of switches to be used when invoking
- `gnatfind` for a source of the language, if there is no applicable
- attribute Switches.
-
-* **Switches**: list, optional index, indexed, case-insensitive index,
- others allowed
-
- Index is a source file name. Value is the list of switches to be used when
- invoking `gnatfind` for the source.
-
-
-.. _Package_gnatls_Attributes:
-
-Package gnatls Attributes
-^^^^^^^^^^^^^^^^^^^^^^^^^
-
-* **Switches**: list
-
- Value is a list of switches to be used when invoking `gnatls`.
-
-
-.. only:: PRO or GPL
-
- Package gnatstub Attributes
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^
-
- * **Default_Switches**: list, indexed, case-insensitive index
-
- Index is a language name. Value is a list of switches to be used when invoking
- `gnatstub` for a source of the language, if there is no applicable
- attribute Switches.
-
- * **Switches**: list, optional index, indexed, case-insensitive index,
- others allowed
-
- Index is a source file name. Value is the list of switches to be used when
- invoking `gnatstub` for the source.
-
-
-.. _Package_IDE_Attributes:
-
-Package IDE Attributes
-^^^^^^^^^^^^^^^^^^^^^^
-
-* **Default_Switches**: list, indexed
-
- Index is the name of an external tool that the GNAT Programming System (GPS)
- is supporting. Value is a list of switches to use when invoking that tool.
-
-* **Remote_Host**: single
-
- Value is a string that designates the remote host in a cross-compilation
- environment, to be used for remote compilation and debugging. This attribute
- should not be specified when running on the local machine.
-
-* **Program_Host**: single
-
- Value is a string that specifies the name of IP address of the embedded target
- in a cross-compilation environment, on which the program should execute.
-
-* **Communication_Protocol**: single
-
- Value is the name of the protocol to use to communicate with the target
- in a cross-compilation environment, for example `"wtx"` or
- `"vxworks"`.
-
-* **Compiler_Command**: single, indexed, case-insensitive index
-
- Index is a language Name. Value is a string that denotes the command to be
- used to invoke the compiler. For historical reasons, the value of
- `Compiler_Command ("Ada")` is expected to be a reference to *gnatmake* or
- *cross-gnatmake*.
-
-* **Debugger_Command**: single
-
- Value is a string that specifies the name of the debugger to be used, such as
- gdb, powerpc-wrs-vxworks-gdb or gdb-4.
-
-* **gnatlist**: single
-
- Value is a string that specifies the name of the *gnatls* utility
- to be used to retrieve information about the predefined path; for example,
- `"gnatls"`, `"powerpc-wrs-vxworks-gnatls"`.
-
-* **VCS_Kind**: single
-
- Value is a string used to specify the Version Control System (VCS) to be used
- for this project, for example "Subversion", "ClearCase". If the
- value is set to "Auto", the IDE will try to detect the actual VCS used
- on the list of supported ones.
-
-* **VCS_File_Check**: single
-
- Value is a string that specifies the command used by the VCS to check
- the validity of a file, either when the user explicitly asks for a check,
- or as a sanity check before doing the check-in.
-
-* **VCS_Log_Check**: single
-
- Value is a string that specifies the command used by the VCS to check
- the validity of a log file.
-
-* **Documentation_Dir**: single
-
- Value is the directory used to generate the documentation of source code.
-
-
-.. _Package_Install_Attributes:
-
-Package Install Attributes
-^^^^^^^^^^^^^^^^^^^^^^^^^^
-
-* **Artifacts**: list, indexed
-
- An array attribute to declare a set of files not part of the sources
- to be installed. The array discriminant is the directory where the
- file is to be installed. If a relative directory then Prefix (see
- below) is prepended. Note also that if the same file name occurs
- multiple time in the attribute list, the last one will be the one
- installed.
-
-* **Prefix**: single
-
- Value is the install destination directory.
-
-* **Sources_Subdir**: single
-
- Value is the sources directory or subdirectory of Prefix.
-
-* **Exec_Subdir**: single
-
- Value is the executables directory or subdirectory of Prefix.
-
-* **Lib_Subdir**: single
-
- Value is library directory or subdirectory of Prefix.
-
-* **Project_Subdir**: single
-
- Value is the project directory or subdirectory of Prefix.
-
-* **Active**: single
-
- Indicates that the project is to be installed or not. Case-insensitive value
- "false" means that the project is not to be installed, all other values mean
- that the project is to be installed.
-
-* **Mode**: single
-
- Value is the installation mode, it is either **dev** (default) or **usage**.
-
-* **Install_Name**: single
-
- Specify the name to use for recording the installation. The default is
- the project name without the extension.
-
-
-.. _Package_Linker_Attributes:
-
-Package Linker Attributes
-^^^^^^^^^^^^^^^^^^^^^^^^^
-
-* **General**
-
- * **Required_Switches**: list
-
- Value is a list of switches that are required when invoking the linker to link
- an executable.
-
- * **Default_Switches**: list, indexed, case-insensitive index
-
- Index is a language name. Value is a list of switches for the linker when
- linking an executable for a main source of the language, when there is no
- applicable Switches.
-
- * **Leading_Switches**: list, optional index, indexed,
- case-insensitive index, others allowed
-
- Index is a source file name or a language name. Value is the list of switches
- to be used at the beginning of the command line when invoking the linker to
- build an executable for the source or for its language.
-
- * **Switches**: list, optional index, indexed, case-insensitive index,
- others allowed
-
- Index is a source file name or a language name. Value is the list of switches
- to be used when invoking the linker to build an executable for the source or
- for its language.
-
- * **Trailing_Switches**: list, optional index, indexed,
- case-insensitive index, others allowed
-
- Index is a source file name or a language name. Value is the list of switches
- to be used at the end of the command line when invoking the linker to
- build an executable for the source or for its language. These switches may
- override the Required_Switches.
-
- * **Linker_Options**: list
-
- Value is a list of switches/options that are to be added when linking an
- executable from a project importing the current project directly or indirectly.
- Linker_Options are not used when linking an executable from the current
- project.
-
- * **Map_File_Option**: single
-
- Value is the switch to specify the map file name that the linker needs to
- create.
-
-* **Configuration - Linking**
-
- * **Driver**: single
-
- Value is the name of the linker executable.
-
-* **Configuration - Response Files**
-
- * **Max_Command_Line_Length**: single
-
- Value is the maximum number of character in the command line when invoking
- the linker to link an executable.
-
- * **Response_File_Format**: single
-
- Indicates the kind of response file to create when the length of the linking
- command line is too large. Only authorized case-insensitive values are "none",
- "gnu", "object_list", "gcc_gnu", "gcc_option_list" and "gcc_object_list".
-
- * **Response_File_Switches**: list
-
- Value is the list of switches to specify a response file to the linker.
-
-
-
-.. only PRO or GPL
-
- .. _Package_Metrics_Attribute:
-
- Package Metrics Attribute
- ^^^^^^^^^^^^^^^^^^^^^^^^^
-
- * **Default_Switches**: list, indexed, case-insensitive index
-
- Index is a language name. Value is a list of switches to be used when invoking
- `gnatmetric` for a source of the language, if there is no applicable
- attribute Switches.
-
- * **Switches**: list, optional index, indexed, case-insensitive index,
- others allowed
-
- Index is a source file name. Value is the list of switches to be used when
- invoking `gnatmetric` for the source.
-
-
-.. _Package_Naming_Attributes:
-
-Package Naming Attributes
-^^^^^^^^^^^^^^^^^^^^^^^^^
-
-* **Specification_Suffix**: single, indexed, case-insensitive index
-
- Equivalent to attribute Spec_Suffix.
-
-* **Spec_Suffix**: single, indexed, case-insensitive index
-
- Index is a language name. Value is the extension of file names for specs of
- the language.
-
-* **Implementation_Suffix**: single, indexed, case-insensitive index
-
- Equivalent to attribute Body_Suffix.
-
-* **Body_Suffix**: single, indexed, case-insensitive index
-
- Index is a language name. Value is the extension of file names for bodies of
- the language.
-
-* **Separate_Suffix**: single
-
- Value is the extension of file names for subunits of Ada.
-
-* **Casing**: single
-
- Indicates the casing of sources of the Ada language. Only authorized
- case-insensitive values are "lowercase", "uppercase" and "mixedcase".
-
-* **Dot_Replacement**: single
-
- Value is the string that replace the dot of unit names in the source file names
- of the Ada language.
-
-* **Specification**: single, optional index, indexed,
- case-insensitive index
-
- Equivalent to attribute Spec.
-
-* **Spec**: single, optional index, indexed, case-insensitive index
-
- Index is a unit name. Value is the file name of the spec of the unit.
-
-* **Implementation**: single, optional index, indexed,
- case-insensitive index
-
- Equivalent to attribute Body.
-
-* **Body**: single, optional index, indexed, case-insensitive index
-
- Index is a unit name. Value is the file name of the body of the unit.
-
-* **Specification_Exceptions**: list, indexed, case-insensitive index
-
- Index is a language name. Value is a list of specs for the language that do not
- necessarily follow the naming scheme for the language and that may or may not
- be found in the source directories of the project.
-
-* **Implementation_Exceptions**: list, indexed, case-insensitive index
-
- Index is a language name. Value is a list of bodies for the language that do not
- necessarily follow the naming scheme for the language and that may or may not
- be found in the source directories of the project.
-
-
-.. only:: PRO or GPL
-
- .. _Package_Pretty_Printer_Attributes:
-
- Package Pretty_Printer Attributes
- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-
- * **Default_Switches**: list, indexed, case-insensitive index
-
- Index is a language name. Value is a list of switches to be used when invoking
- `gnatpp` for a source of the language, if there is no applicable
- attribute Switches.
-
- * **Switches**: list, optional index, indexed, case-insensitive index,
- others allowed
-
- Index is a source file name. Value is the list of switches to be used when
- invoking `gnatpp` for the source.
-
-
-.. _Package_Remote_Attributes:
-
-Package Remote Attributes
-^^^^^^^^^^^^^^^^^^^^^^^^^
-
-* **Included_Patterns**: list
-
- If this attribute is defined it sets the patterns to
- synchronized from the master to the slaves. It is exclusive
- with Excluded_Patterns, that is it is an error to define
- both.
-
-* **Included_Artifact_Patterns**: list
-
- If this attribute is defined it sets the patterns of compilation
- artifacts to synchronized from the slaves to the build master.
- This attribute replace the default hard-coded patterns.
-
-* **Excluded_Patterns**: list
-
- Set of patterns to ignore when synchronizing sources from the build
- master to the slaves. A set of predefined patterns are supported
- (e.g. \*.o, \*.ali, \*.exe, etc.), this attributes make it possible to
- add some more patterns.
-
-* **Root_Dir**: single
-
- Value is the root directory used by the slave machines.
-
-
-.. _Package_Stack_Attributes:
-
-Package Stack Attributes
-^^^^^^^^^^^^^^^^^^^^^^^^
-
-* **Switches**: list
-
- Value is the list of switches to be used when invoking `gnatstack`.
-
-
-Package Synchronize Attributes
-^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-
-* **Default_Switches**: list, indexed, case-insensitive index
-
- Index is a language name. Value is a list of switches to be used when invoking
- `gnatsync` for a source of the language, if there is no applicable
- attribute Switches.
-
-* **Switches**: list, optional index, indexed, case-insensitive index,
- others allowed
-
- Index is a source file name. Value is the list of switches to be used when
- invoking `gnatsync` for the source.
diff --git a/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst b/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst
index 2ee90d3dc9..062d6b90cd 100644
--- a/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst
+++ b/gcc/ada/doc/gnat_ugn/gnat_utility_programs.rst
@@ -19,6 +19,9 @@ This chapter describes a number of utility programs:
* :ref:`The_Body_Stub_Generator_gnatstub`
* :ref:`The_Unit_Test_Generator_gnattest`
+ It also describes how several of these tools can be used in conjunction
+ with project files: :ref:`Using_Project_Files_with_GNAT_Tools`
+
.. only:: FSF
* :ref:`The_File_Cleanup_Utility_gnatclean`
@@ -629,10 +632,7 @@ The following switches are available for *gnatxref*:
.. index:: -pFILE (gnatxref)
:samp:`p{FILE}`
- Specify a project file to use :ref:`GNAT_Project_Manager`.
- If you need to use the :file:`.gpr`
- project files, you should use gnatxref through the GNAT driver
- (*gnat xref -Pproject*).
+ Specify a project file to use.
By default, `gnatxref` and `gnatfind` will try to locate a
project file in the current directory.
@@ -832,7 +832,7 @@ The following switches are available:
.. index:: -pFILE (gnatfind)
:samp:`p{FILE}`
- Specify a project file (:ref:`GNAT_Project_Manager`) to use.
+ Specify a project file.
By default, `gnatxref` and `gnatfind` will try to locate a
project file in the current directory.
@@ -1379,6 +1379,11 @@ Alternatively, you may run the script using the following command line:
The *gnat2xml* tool is an ASIS-based utility that converts
Ada source code into XML.
+ *gnat2xml* is a project-aware tool
+ (see :ref:`Using_Project_Files_with_GNAT_Tools` for a description of
+ the project-related switches). The project file package that can specify
+ *gnat2xml* switches is named ``gnat2xml``.
+
.. _Switches_for_*gnat2xml*:
Switches for *gnat2xml*
@@ -1823,15 +1828,12 @@ Alternatively, you may run the script using the following command line:
The *gnatcheck* tool is an ASIS-based utility that checks properties
of Ada source files according to a given set of semantic rules.
- In order to check compliance with a given rule, *gnatcheck* has to
- semantically analyze the Ada sources.
- Therefore, checks can only be performed on
- legal Ada units. Moreover, when a unit depends semantically upon units located
- outside the current directory, the source search path has to be provided when
- calling *gnatcheck*, either through a specified project file or
- through *gnatcheck* switches.
+ *gnatcheck* is a project-aware tool
+ (see :ref:`Using_Project_Files_with_GNAT_Tools` for a description of
+ the project-related switches). The project file package that can specify
+ *gnatcheck* switches is named ``Check``.
- For full details, refer to :title:`GNATcheck Reference Manual`.
+ For full details, plese refer to :title:`GNATcheck Reference Manual`.
@@ -1851,6 +1853,11 @@ Alternatively, you may run the script using the following command line:
metrics data as output. Various switches control which
metrics are computed and output.
+ *gnatmetric* is a project-aware tool
+ (see :ref:`Using_Project_Files_with_GNAT_Tools` for a description of
+ the project-related switches). The project file package that can specify
+ *gnatmetric* switches is named ``Metrics``.
+
To compute program metrics, *gnatmetric* invokes the Ada
compiler and generates and uses the ASIS tree for the input source;
thus the input must be legal Ada code, and the tool should have all the
@@ -2095,71 +2102,71 @@ Alternatively, you may run the script using the following command line:
.. index:: --no-lines (gnatmetric)
- :samp:`-lines-all`
+ :samp:`--lines-all`
Report all the line metrics
- :samp:`-no-lines-all`
+ :samp:`--no-lines-all`
Do not report any of line metrics
- :samp:`-lines`
+ :samp:`--lines`
Report the number of all lines
- :samp:`-no-lines`
+ :samp:`--no-lines`
Do not report the number of all lines
- :samp:`-lines-code`
+ :samp:`--lines-code`
Report the number of code lines
- :samp:`-no-lines-code`
+ :samp:`--no-lines-code`
Do not report the number of code lines
- :samp:`-lines-comment`
+ :samp:`--lines-comment`
Report the number of comment lines
- :samp:`-no-lines-comment`
+ :samp:`--no-lines-comment`
Do not report the number of comment lines
- :samp:`-lines-eol-comment`
+ :samp:`--lines-eol-comment`
Report the number of code lines containing
end-of-line comments
- :samp:`-no-lines-eol-comment`
+ :samp:`--no-lines-eol-comment`
Do not report the number of code lines containing
end-of-line comments
- :samp:`-lines-ratio`
+ :samp:`--lines-ratio`
Report the comment percentage in the program text
- :samp:`-no-lines-ratio`
+ :samp:`--no-lines-ratio`
Do not report the comment percentage in the program text
- :samp:`-lines-blank`
+ :samp:`--lines-blank`
Report the number of blank lines
- :samp:`-no-lines-blank`
+ :samp:`--no-lines-blank`
Do not report the number of blank lines
- :samp:`-lines-average`
+ :samp:`--lines-average`
Report the average number of code lines in subprogram bodies, task bodies,
entry bodies and statement sequences in package bodies. The metric is computed
and reported for the whole set of processed Ada sources only.
- :samp:`-no-lines-average`
+ :samp:`--no-lines-average`
Do not report the average number of code lines in subprogram bodies,
task bodies, entry bodies and statement sequences in package bodies.
@@ -2204,6 +2211,15 @@ Alternatively, you may run the script using the following command line:
maximum nesting level in the GNAT built-in style checks
(see :ref:`Style_Checking`)
+ * *Number of formal parameters*
+ Number of formal parameters of a subprogram; if a subprogram does have
+ parameters, then numbers of "in", "out" and "in out" parameters are also
+ reported. This metric is reported for subprogram specifications and for
+ subprogram instantiations. For subprogram bodies, expression functions
+ and null procedures this metric is reported if the construct acts as a
+ subprogram declaration but is not a completion of previous declaration.
+ This metric is not reported for generic and formal subprograms.
+
For the outermost unit in the file, *gnatmetric* additionally computes
the following metrics:
@@ -2263,77 +2279,84 @@ Alternatively, you may run the script using the following command line:
.. index:: --no-syntax (gnatmetric)
- :samp:`-syntax-all`
+ :samp:`--syntax-all`
Report all the syntax metrics
- :samp:`-no-syntax-all`
+ :samp:`--no-syntax-all`
Do not report any of syntax metrics
- :samp:`-declarations`
+ :samp:`--declarations`
Report the total number of declarations
- :samp:`-no-declarations`
+ :samp:`--no-declarations`
Do not report the total number of declarations
- :samp:`-statements`
+ :samp:`--statements`
Report the total number of statements
- :samp:`-no-statements`
+ :samp:`--no-statements`
Do not report the total number of statements
- :samp:`-public-subprograms`
+ :samp:`--public-subprograms`
Report the number of public subprograms in a compilation unit
- :samp:`-no-public-subprograms`
+ :samp:`--no-public-subprograms`
Do not report the number of public subprograms in a compilation unit
- :samp:`-all-subprograms`
+ :samp:`--all-subprograms`
Report the number of all the subprograms in a compilation unit
- :samp:`-no-all-subprograms`
+ :samp:`--no-all-subprograms`
Do not report the number of all the subprograms in a compilation unit
- :samp:`-public-types`
+ :samp:`--public-types`
Report the number of public types in a compilation unit
- :samp:`-no-public-types`
+ :samp:`--no-public-types`
Do not report the number of public types in a compilation unit
- :samp:`-all-types`
+ :samp:`--all-types`
Report the number of all the types in a compilation unit
- :samp:`-no-all-types`
+ :samp:`--no-all-types`
Do not report the number of all the types in a compilation unit
- :samp:`-unit-nesting`
+ :samp:`--unit-nesting`
Report the maximal program unit nesting level
- :samp:`-no-unit-nesting`
+ :samp:`--no-unit-nesting`
Do not report the maximal program unit nesting level
- :samp:`-construct-nesting`
+ :samp:`--construct-nesting`
Report the maximal construct nesting level
- :samp:`-no-construct-nesting`
+ :samp:`--no-construct-nesting`
Do not report the maximal construct nesting level
+ :samp:`--param-number`
+ Report the number of subprogram parameters
+
+
+ :samp:`--no-param-number`
+ Do not report the number of subprogram parameters
+
.. _Complexity_Metrics_Control:
@@ -2420,31 +2443,31 @@ Alternatively, you may run the script using the following command line:
.. index:: --no-complexity (gnatmetric)
- :samp:`-complexity-all`
+ :samp:`--complexity-all`
Report all the complexity metrics
- :samp:`-no-complexity-all`
+ :samp:`--no-complexity-all`
Do not report any of complexity metrics
- :samp:`-complexity-cyclomatic`
+ :samp:`--complexity-cyclomatic`
Report the McCabe Cyclomatic Complexity
- :samp:`-no-complexity-cyclomatic`
+ :samp:`--no-complexity-cyclomatic`
Do not report the McCabe Cyclomatic Complexity
- :samp:`-complexity-essential`
+ :samp:`--complexity-essential`
Report the Essential Complexity
- :samp:`-no-complexity-essential`
+ :samp:`--no-complexity-essential`
Do not report the Essential Complexity
- :samp:`-loop-nesting`
+ :samp:`--loop-nesting`
Report maximal loop nesting level
@@ -2452,14 +2475,14 @@ Alternatively, you may run the script using the following command line:
Do not report maximal loop nesting level
- :samp:`-complexity-average`
+ :samp:`--complexity-average`
Report the average McCabe Cyclomatic Complexity for all the subprogram bodies,
task bodies, entry bodies and statement sequences in package bodies.
The metric is computed and reported for whole set of processed Ada sources
only.
- :samp:`-no-complexity-average`
+ :samp:`--no-complexity-average`
Do not report the average McCabe Cyclomatic Complexity for all the subprogram
bodies, task bodies, entry bodies and statement sequences in package bodies
@@ -2473,11 +2496,11 @@ Alternatively, you may run the script using the following command line:
.. index:: --no-static-loop (gnatmetric)
- :samp:`-no-static-loop`
+ :samp:`--no-static-loop`
Do not consider static loops when computing cyclomatic complexity
- :samp:`-extra-exit-points`
+ :samp:`--extra-exit-points`
Report the extra exit points for subprogram bodies. As an exit point, this
metric counts `return` statements and raise statements in case when the
raised exception is not handled in the same body. In case of a function this
@@ -2485,7 +2508,7 @@ Alternatively, you may run the script using the following command line:
must contain at least one `return` statement.
- :samp:`-no-extra-exit-points`
+ :samp:`--no-extra-exit-points`
Do not report the extra exit points for subprogram bodies
@@ -2678,39 +2701,39 @@ Alternatively, you may run the script using the following command line:
.. index:: --unit-coupling (gnatmetric)
.. index:: --control-coupling (gnatmetric)
- :samp:`-coupling-all`
+ :samp:`--coupling-all`
Report all the coupling metrics
- :samp:`-tagged-coupling-out`
+ :samp:`--tagged-coupling-out`
Report tagged (class) fan-out coupling
- :samp:`-tagged-coupling-in`
+ :samp:`--tagged-coupling-in`
Report tagged (class) fan-in coupling
- :samp:`-hierarchy-coupling-out`
+ :samp:`--hierarchy-coupling-out`
Report hierarchy (category) fan-out coupling
- :samp:`-hierarchy-coupling-in`
+ :samp:`--hierarchy-coupling-in`
Report hierarchy (category) fan-in coupling
- :samp:`-unit-coupling-out`
+ :samp:`--unit-coupling-out`
Report unit fan-out coupling
- :samp:`-unit-coupling-in`
+ :samp:`--unit-coupling-in`
Report unit fan-in coupling
- :samp:`-control-coupling-out`
+ :samp:`--control-coupling-out`
Report control fan-out coupling
- :samp:`-control-coupling-in`
+ :samp:`--control-coupling-in`
Report control fan-in coupling
@@ -2724,13 +2747,13 @@ Alternatively, you may run the script using the following command line:
.. index:: --version (gnatmetric)
- :samp:`-version`
+ :samp:`--version`
Display Copyright and version, then exit disregarding all other options.
.. index:: --help (gnatmetric)
- :samp:`-help`
+ :samp:`--help`
Display usage, then exit disregarding all other options.
@@ -2768,14 +2791,14 @@ Alternatively, you may run the script using the following command line:
.. index:: --RTS (gnatmetric)
- :samp:`-RTS={rts-path}`
+ :samp:`--RTS={rts-path}`
Specifies the default location of the runtime library. Same meaning as the
equivalent *gnatmake* flag (see :ref:`Switches_for_gnatmake`).
.. index:: --subdirs=dir (gnatmetric)
- :samp:`-subdirs={dir}`
+ :samp:`--subdirs={dir}`
Use the specified subdirectory of the project objects file (or of the
project file directory if the project does not specify an object directory)
for tool output files. Has no effect if no project is specified as
@@ -2784,7 +2807,7 @@ Alternatively, you may run the script using the following command line:
.. index:: --no_objects_dir (gnatmetric)
- :samp:`-no_objects_dir`
+ :samp:`--no_objects_dir`
Place all the result files into the current directory instead of
project objects directory. This corresponds to the *gnatcheck*
behavior when it is called with the project file from the
@@ -2852,6 +2875,11 @@ Alternatively, you may run the script using the following command line:
You can specify various style directives via switches; e.g.,
identifier case conventions, rules of indentation, and comment layout.
+ *gnatpp* is a project-aware tool
+ (see :ref:`Using_Project_Files_with_GNAT_Tools` for a description of
+ the project-related switches). The project file package that can specify
+ *gnatpp* switches is named ``Pretty_Printer``.
+
To produce a reformatted file, *gnatpp* invokes the Ada
compiler and generates and uses the ASIS tree for the input source;
thus the input must be legal Ada code, and the tool should have all the
@@ -3027,7 +3055,7 @@ Alternatively, you may run the script using the following command line:
.. index:: -nt (gnatpp)
- :samp:`-neD`
+ :samp:`-ntD`
Names introduced by type and subtype declarations are always
cased as they appear in the declaration in the source file.
Overrides -n casing setting.
@@ -3143,6 +3171,13 @@ Alternatively, you may run the script using the following command line:
:samp:`--comments-only`
Format just the comments.
+ .. index:: --no-end-id (gnatpp)
+
+
+ :samp:`--no-end-id`
+ Do not insert the name of a unit after `end`; leave whatever comes
+ after `end`, if anything, alone.
+
.. index:: --no-separate-is (gnatpp)
@@ -3849,6 +3884,15 @@ Alternatively, you may run the script using the following command line:
for library unit declarations, and empty but compilable
subunit for body stubs.
+ *gnatstub* is a project-aware tool.
+ (See :ref:`Using_Project_Files_with_GNAT_Tools` for a description of
+ the project-related switches but note that *gnatstub* does not support
+ the :samp:`-U`, :samp:`-U {main_unit}`, :samp:`--subdirs={dir}`, or
+ :samp:`--no_objects_dir` switches.)
+ The project file package that can specify
+ *gnatstub* switches is named ``gnatstub``.
+
+
To create a body or a subunit, *gnatstub* invokes the Ada
compiler and generates and uses the ASIS tree for the input source;
thus the input must be legal Ada code, and the tool should have all the
@@ -4157,6 +4201,14 @@ Alternatively, you may run the script using the following command line:
a skeleton for each visible subprogram in the packages under consideration when
they do not exist already.
+ *gnattest* is a project-aware tool.
+ (See :ref:`Using_Project_Files_with_GNAT_Tools` for a description of
+ the project-related switches but note that *gnattest* does not support
+ the :samp:`-U`, :samp:`-eL`, :samp:`--subdirs={dir}`, or
+ :samp:`--no_objects_dir` switches.)
+ The project file package that can specify
+ *gnattest* switches is named ``gnattest``.
+
The user can choose to generate a single test driver
that will run all individual tests, or separate test drivers for each test. The
second option allows much greater flexibility in test execution environment,
@@ -4305,12 +4357,6 @@ Alternatively, you may run the script using the following command line:
Recursively considers all sources from all projects.
- .. index:: -X (gnattest)
-
- :samp:`-X{name}={value}`
- Indicate that external variable `name` has the value `value`.
-
-
.. index:: --RTS (gnattest)
:samp:`--RTS={rts-path}`
@@ -4336,9 +4382,10 @@ Alternatively, you may run the script using the following command line:
.. index:: --separate-drivers (gnattest)
- :samp:`--separate-drivers`
- Generates a separate test driver for each test, rather than a single
- executable incorporating all tests.
+ :samp:`--separate-drivers[={val}]`
+ Generates a separate test driver for each test or unit under test, rather
+ than a single executable incorporating all tests. `val` can be "unit" or
+ "test", or may be omitted, which defaults to "unit".
.. index:: --stub (gnattest)
@@ -4401,6 +4448,16 @@ Alternatively, you may run the script using the following command line:
placed accordingly.
+ .. index:: --exclude-from-stubbing (gnattest)
+
+ :samp:`--exclude-from-stubbing={filename}`
+ Disables stubbing of units listed in `filename`. The file should contain
+ corresponding spec files, one per line.
+
+ :samp:`--exclude-from-stubbing:{unit}={filename}`
+ Same as above, but corresponding units will not be stubbed only when testing
+ specified `unit`.
+
.. index:: --validate-type-extensions (gnattest)
:samp:`--validate-type-extensions`
@@ -4531,6 +4588,15 @@ Alternatively, you may run the script using the following command line:
specified by ``--skeleton-default`` option. The value of this attribute
should be either ``pass`` or ``fail``.
+ * ``Default_Stub_Exclusion_List``
+ is used to specify the file with list of units whose bodies should not
+ be stubbed, otherwise specified by ``--exclude-from-stubbing=filename``.
+
+ * ``Stub_Exclusion_List ("unit")``
+ is used to specify the file with list of units whose bodies should not
+ be stubbed when testing "unit", otherwise specified by
+ ``--exclude-from-stubbing:unit=filename``.
+
Each of those attributes can be overridden from the command line if needed.
Other *gnattest* switches can also be passed via the project
file as an attribute list called *Gnattest_Switches*.
@@ -4877,12 +4943,12 @@ Alternatively, you may run the script using the following command line:
By default, *gnattest* generates a monolithic test driver that
aggregates the individual tests into a single executable. It is also possible
- to generate separate executables for each test, by passing the switch
- ``--separate-drivers``. This approach scales better for large testing
- campaigns, especially involving target architectures with limited resources
- typical for embedded development. It can also provide a major performance
- benefit on multi-core systems by allowing simultaneous execution of multiple
- tests.
+ to generate separate executables for each test or each unit under test, by
+ passing the switch ``--separate-drivers`` with corresponding parameter. This
+ approach scales better for large testing campaigns, especially involving target
+ architectures with limited resources typical for embedded development. It can
+ also provide a major performance benefit on multi-core systems by allowing
+ simultaneous execution of multiple tests.
*gnattest* can take charge of executing the individual tests; for this,
instead of passing a project file, a text file containing the list of
@@ -4923,7 +4989,8 @@ Alternatively, you may run the script using the following command line:
Due to the nature of stubbing process, this mode implies the switch
``--separate-drivers``, i.e. an individual test driver (with the
- corresponding hierarchy of extending projects) is generated for each test.
+ corresponding hierarchy of extending projects) is generated for each unit under
+ test.
.. note::
@@ -4962,7 +5029,93 @@ Alternatively, you may run the script using the following command line:
not supported;
* tests for protected subprograms and entries are not supported;
* pragma *No_Run_Time* is not supported;
+ * pragma *No_Secondary_Stack* is not supported;
* if pragmas for interfacing with foreign languages are used, manual
adjustments might be necessary to make the test harness compilable;
- * use of elaboration control pragmas may result in elaboration circularities
- in the generated harness.
+ * use of some constructs, such as elaboration-control pragmas, Type_Invariant
+ aspects, and complex variable initializations that use Subprogram'Access,
+ may result in elaboration circularities in the generated harness.
+
+.. only:: PRO or GPL
+
+ .. _Using_Project_Files_with_GNAT_Tools:
+
+ Using Project Files with GNAT Tools
+ ===================================
+
+ This section describes how project files can be used in conjunction
+ with a number of GNAT tools.
+ For a comprehensive description of project files and the overall
+ GNAT Project Manager facility, please refer to the
+ *GNAT Project Manager* chapter in the
+ *GPRbuild and GPR Companion Tools User's Guide*.
+
+ .. index:: Project-aware tool
+
+ If a tool can take a project file as an option and extract the needed
+ information, such a tool is called a *project-aware* tool.
+
+ .. _Switches_Related_to_Project_Files:
+
+ Switches Related to Project Files
+ ---------------------------------
+
+ The following switches are used by the project-aware GNAT tools:
+
+ :samp:`-P{project_file}`
+ Indicates the name of the project file whose source files are to
+ be processed. The exact set of sources depends on other options
+ specified, see below.
+
+ :samp:`-U`
+ If a project file is supplied, say for project ``proj``,
+ but no sources are specified for ``proj`` (either by a
+ project attribute or through a tool option that provides a list
+ of the files to be used), process all the source files
+ from projects imported either directly or indirectly by ``proj``.
+ Otherwise this option has no effect.
+
+ :samp:`-U {main_unit}`
+ Similar to :samp:`-U`, but if no sources are specified then
+ process only those source files for units in the closure of
+ `main_unit`.
+
+ :samp:`-X{name}={val}`
+ Indicates that the external variable ``name`` in the project has the
+ value ``val``. Has no effect if no project has been specified.
+
+ :samp:`--subdirs={dir}`
+ Use the `dir` subdirectory of the project's object directory (or the `dir`
+ subdirectory of the project file directory if the project does not specify
+ an object directory) for tool output files. Has no effect if no project
+ has been specified or if :samp:`--no_objects_dir` is specified.
+
+ :samp:`--no_objects_dir`
+ Place all the result files into the current directory (i.e., the directory
+ from which the tool invocation command is issued) instead of the project's
+ object directory. Has no effect if no project has been specified.
+
+ :samp:`-eL`
+ Follow all symbolic links when processing project files.
+
+ If a project file is specified and there is neither a :samp:`-U` option,
+ nor a :samp:`-U {main_unit}` option, nor some other explicit option to
+ specify the source files, then the sources to be processed are the
+ immediate sources of the specified project (i.e., the source files directly
+ defined by that project, either implicitly by residing in the project
+ source directories, or explicitly through any of the source-related
+ attributes).
+
+ .. _Tool-specific_packages_in_project files:
+
+ Tool-specific packages in project files
+ ---------------------------------------
+
+ Each project-aware tool may have a corresponding package in a project file;
+ the package names are given elsewhere in this manual, in the sections that describe
+ the respective tools.
+
+ A tool-specific package in a project file may define the ``Default_Switches``
+ attribute indexed by "ada" (as language name). The value of this attribute
+ is a list of switches that will be supplied at tool invocation.
+ Project-specific switches cannot be specified through this attribute.
diff --git a/gcc/ada/doc/gnat_ugn/inline_assembler.rst b/gcc/ada/doc/gnat_ugn/inline_assembler.rst
index d79b70b081..f2c0e72138 100644
--- a/gcc/ada/doc/gnat_ugn/inline_assembler.rst
+++ b/gcc/ada/doc/gnat_ugn/inline_assembler.rst
@@ -119,7 +119,7 @@ from which it generates a sequence of assembly language instructions.
The examples in this chapter will illustrate several of the forms
for invoking `Asm`; a complete specification of the syntax
-is found in the `Machine_Code_Insertions` section of the
+is found in the `Machine_Code_Insertions` section of the
:title:`GNAT Reference Manual`.
Under the standard GNAT conventions, the `Nothing` procedure
@@ -129,7 +129,7 @@ You can build the executable in the usual way:
::
$ gnatmake nothing
-
+
However, the interesting aspect of this example is not its run-time behavior
but rather the generated assembly code.
To see this output, invoke the compiler as follows:
@@ -137,7 +137,7 @@ To see this output, invoke the compiler as follows:
::
$ gcc -c -S -fomit-frame-pointer -gnatp nothing.adb
-
+
where the options are:
* :samp:`-c`
@@ -191,7 +191,7 @@ Assembling the file using the command
::
- $ as nothing.s
+ $ as nothing.s
will give you error messages whose lines correspond to the assembler
input file, so you can easily find and correct any mistakes you made.
@@ -224,7 +224,7 @@ statements.
Outputs => Unsigned_32'Asm_Output ("=g", Flags));
Put_Line ("Flags register:" & Flags'Img);
end Get_Flags;
-
+
In order to have a nicely aligned assembly listing, we have separated
multiple assembler statements in the Asm template string with linefeed
(ASCII.LF) and horizontal tab (ASCII.HT) characters.
@@ -243,7 +243,7 @@ It would have been legal to write the Asm invocation as:
.. code-block:: ada
Asm ("pushfl popl %%eax movl %%eax, %0")
-
+
but in the generated assembler file, this would come out as:
::
@@ -251,7 +251,7 @@ but in the generated assembler file, this would come out as:
#APP
pushfl popl %eax movl %eax, -40(%ebp)
#NO_APP
-
+
which is not so convenient for the human reader.
We use Ada comments
@@ -273,7 +273,7 @@ the third statement in the Asm template string:
::
movl %%eax, %0
-
+
The intent is to store the contents of the eax register in a variable that can
be accessed in Ada. Simply writing `movl %%eax, Flags` would not
necessarily work, since the compiler might optimize by using a register
@@ -288,21 +288,21 @@ parameter to `Asm`:
.. code-block:: ada
Outputs => Unsigned_32'Asm_Output ("=g", Flags));
-
+
The output is defined by the `Asm_Output` attribute of the target type;
the general format is
.. code-block:: ada
Type'Asm_Output (constraint_string, variable_name)
-
+
The constraint string directs the compiler how
to store/access the associated variable. In the example
.. code-block:: ada
Unsigned_32'Asm_Output ("=m", Flags);
-
+
the `"m"` (memory) constraint tells the compiler that the variable
`Flags` should be stored in a memory variable, thus preventing
the optimizer from keeping it in a register. In contrast,
@@ -310,7 +310,7 @@ the optimizer from keeping it in a register. In contrast,
.. code-block:: ada
Unsigned_32'Asm_Output ("=r", Flags);
-
+
uses the `"r"` (register) constraint, telling the compiler to
store the variable in a register.
@@ -352,7 +352,7 @@ integer. Thus in
"popl %%eax" & LF & HT & -- load eax with flags
"movl %%eax, %0", -- store flags in variable
Outputs => Unsigned_32'Asm_Output ("=g", Flags));
-
+
`%0` will be replaced in the expanded code by the appropriate operand,
whatever
@@ -375,7 +375,7 @@ For example:
Outputs => (Unsigned_32'Asm_Output ("=g", Var_A), -- %0 = Var_A
Unsigned_32'Asm_Output ("=g", Var_B), -- %1 = Var_B
Unsigned_32'Asm_Output ("=g", Var_C))); -- %2 = Var_C
-
+
where `Var_A`, `Var_B`, and `Var_C` are variables
in the Ada program.
@@ -398,7 +398,7 @@ variable, instead of including the store instruction explicitly in the
Outputs => Unsigned_32'Asm_Output ("=a", Flags));
Put_Line ("Flags register:" & Flags'Img);
end Get_Flags_2;
-
+
The `"a"` constraint tells the compiler that the `Flags`
variable will come from the eax register. Here is the resulting code:
@@ -409,7 +409,7 @@ variable will come from the eax register. Here is the resulting code:
popl %eax
#NO_APP
movl %eax,-40(%ebp)
-
+
The compiler generated the store of eax into Flags after
expanding the assembler code.
@@ -430,7 +430,7 @@ more simply, we could just pop the flags directly into the program variable:
Outputs => Unsigned_32'Asm_Output ("=g", Flags));
Put_Line ("Flags register:" & Flags'Img);
end Get_Flags_3;
-
+
.. _Input_Variables_in_Inline_Assembler:
@@ -465,7 +465,7 @@ The program simply increments its input value by 1:
Value := Incr (Value);
Put_Line ("Value after is" & Value'Img);
end Increment;
-
+
The `Outputs` parameter to `Asm` specifies
that the result will be in the eax register and that it is to be stored
in the `Result` variable.
@@ -505,7 +505,7 @@ The resulting assembler file (with *-O2* optimization) contains:
movl %ecx,(%esp)
addl $4,%esp
ret
-
+
.. _Inlining_Inline_Assembler_Code:
@@ -545,7 +545,7 @@ Here is the resulting program:
Value := Increment (Value);
Put_Line ("Value after is" & Value'Img);
end Increment_2;
-
+
Compile the program with both optimization (*-O2*) and inlining
(*-gnatn*) enabled.
@@ -557,7 +557,7 @@ point in `Increment` where our function used to be called:
pushl %edi
call _increment__incr.1
-
+
the code for the function body directly appears:
@@ -607,7 +607,7 @@ assembly code; for example:
"movl %%ebx, %1",
Outputs => Unsigned_32'Asm_Output ("=g", Var_Out),
Inputs => Unsigned_32'Asm_Input ("g", Var_In));
-
+
where the compiler (since it does not analyze the `Asm` template string)
does not know you are using the ebx register.
@@ -622,7 +622,7 @@ to identify the registers that will be used by your assembly code:
Outputs => Unsigned_32'Asm_Output ("=g", Var_Out),
Inputs => Unsigned_32'Asm_Input ("g", Var_In),
Clobber => "ebx");
-
+
The Clobber parameter is a static string expression specifying the
register(s) you are using. Note that register names are *not* prefixed
by a percent sign. Also, if more than one register is used then their names
@@ -657,7 +657,7 @@ the `Volatile` parameter to `True`; for example:
Inputs => Unsigned_32'Asm_Input ("g", Var_In),
Clobber => "ebx",
Volatile => True);
-
+
By default, `Volatile` is set to `False` unless there is no
`Outputs` parameter.
diff --git a/gcc/ada/doc/gnat_ugn/platform_specific_information.rst b/gcc/ada/doc/gnat_ugn/platform_specific_information.rst
index 694e37baee..8c94f90759 100644
--- a/gcc/ada/doc/gnat_ugn/platform_specific_information.rst
+++ b/gcc/ada/doc/gnat_ugn/platform_specific_information.rst
@@ -156,6 +156,31 @@ For example on x86-linux::
-- |
-- +--- adalib
+.. only:: html or latex
+
+ .. image:: rtlibrary-structure.png
+
+.. only:: not (html or latex)
+
+ ::
+
+ $(target-dir)
+ __/ / \ \___
+ _______/ / \ \_________________
+ / / \ \
+ / / \ \
+ ADAINCLUDE ADALIB rts-native rts-sjlj
+ : : / \ / \
+ : : / \ / \
+ : : / \ / \
+ : : / \ / \
+ +-------------> adainclude adalib adainclude adalib
+ : ^
+ : :
+ +---------------------+
+
+ Run-Time Library Directory Structure
+ (Upper-case names and dotted/dashed arrows represent soft links)
If the *rts-sjlj* library is to be selected on a permanent basis,
these soft links can be modified with the following commands:
@@ -486,6 +511,57 @@ file will be created. This is particularly useful in networked
environments where you may not have write access to some
directories.
+Disabling Command Line Argument Expansion
+-----------------------------------------
+
+.. index:: Command Line Argument Expansion
+
+By default, an executable compiled for the **Windows** platform will do
+the following postprocessing on the arguments passed on the command
+line:
+
+* If the argument contains the characters ``*`` and/or ``?``, then
+ file expansion will be attempted. For example, if the current directory
+ contains :file:`a.txt` and :file:`b.txt`, then when calling::
+
+ $ my_ada_program *.txt
+
+ The following arguments will effectively be passed to the main program
+ (for example when using ``Ada.Command_Line.Argument``)::
+
+ Ada.Command_Line.Argument (1) -> "a.txt"
+ Ada.Command_Line.Argument (2) -> "b.txt"
+
+* Filename expansion can be disabled for a given argument by using single
+ quotes. Thus, calling::
+
+ $ my_ada_program '*.txt'
+
+ will result in::
+
+ Ada.Command_Line.Argument (1) -> "*.txt"
+
+Note that if the program is launched from a shell such as **Cygwin** **Bash**
+then quote removal might be performed by the shell.
+
+In some contexts it might be useful to disable this feature (for example if
+the program performs its own argument expansion). In order to do this, a C
+symbol needs to be defined and set to ``0``. You can do this by
+adding the following code fragment in one of your **Ada** units:
+
+.. code-block:: ada
+
+ Do_Argv_Expansion : Integer := 0;
+ pragma Export (C, Do_Argv_Expansion, "__gnat_do_argv_expansion");
+
+The results of previous examples will be respectively::
+
+ Ada.Command_Line.Argument (1) -> "*.txt"
+
+and::
+
+ Ada.Command_Line.Argument (1) -> "'*.txt'"
+
.. _Mixed-Language_Programming_on_Windows:
@@ -1033,7 +1109,8 @@ Building DLLs with GNAT Project files
.. index:: DLLs, building
There is nothing specific to Windows in the build process.
-:ref:`Library_Projects`.
+See the *Library Projects* section in the *GNAT Project Manager*
+chapter of the *GPRbuild User's Guide*.
Due to a system limitation, it is not possible under Windows to create threads
when inside the `DllMain` routine which is used for auto-initialization
@@ -1149,7 +1226,9 @@ Note that a relocatable DLL stripped using the `strip`
binutils tool will not be relocatable anymore. To build a DLL without
debug information pass `-largs -s` to `gnatdll`. This
restriction does not apply to a DLL built using a Library Project.
-See :ref:`Library_Projects`.
+See the *Library Projects* section in the *GNAT Project Manager*
+chapter of the *GPRbuild User's Guide*.
+
.. Limitations_When_Using_Ada_DLLs_from Ada:
@@ -1865,7 +1944,7 @@ cookbook-style sequence of steps to follow:
$ gprbuild -p mylib.gpr
2. Produce a .def file for the symbols you need to interface with, either by
- hand or automatically with possibly some manual adjustments
+ hand or automatically with possibly some manual adjustments
(see :ref:`Creating Definition File Automatically <Create_Def_File_Automatically>`):
::
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 22e4950502..faedd8ae72 100644
--- a/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst
+++ b/gcc/ada/doc/gnat_ugn/the_gnat_compilation_model.rst
@@ -27,7 +27,7 @@ the following material:
* :ref:`Source_Representation`
* :ref:`Foreign_Language_Representation`
* :ref:`File_Naming_Topics_and_Utilities`
-
+
* :ref:`Configuration_Pragmas`
* :ref:`Generating_Object_Files`
* :ref:`Source_Dependencies`
@@ -217,7 +217,7 @@ possible encoding schemes:
character sequence::
ESC a b c d
-
+
where `a`, `b`, `c`, `d` are the four hexadecimal
characters (using uppercase letters) of the wide character code. For
example, ESC A345 is used to represent the wide character with code
@@ -281,7 +281,7 @@ possible encoding schemes:
character sequence::
[ " a b c d " ]
-
+
where `a`, `b`, `c`, `d` are the four hexadecimal
characters (using uppercase letters) of the wide character code. For
example, ['A345'] is used to represent the wide character with code
@@ -293,7 +293,7 @@ possible encoding schemes:
and is also the method used for wide character encoding in some standard
ACATS (Ada Conformity Assessment Test Suite) test suite distributions.
-.. note::
+.. note::
Some of these coding schemes do not permit the full use of the
Ada character set. For example, neither Shift JIS nor EUC allow the
@@ -321,7 +321,7 @@ possible encoding schemes:
10xxxxxx 10xxxxxx
16#0400_0000#-16#7FFF_FFFF#: 1111110x 10xxxxxx 10xxxxxx
10xxxxxx 10xxxxxx 10xxxxxx
-
+
where the `xxx` bits correspond to the left-padded bits of the
32-bit character value.
@@ -332,7 +332,7 @@ possible encoding schemes:
[ " a b c d e f " ]
[ " a b c d e f g h " ]
-
+
where `a-h` are the six or eight hexadecimal
characters (using uppercase letters) of the wide wide character code. For
example, ["1F4567"] is used to represent the wide wide character with code
@@ -441,7 +441,7 @@ The form of this pragma is as shown in the following examples:
Spec_File_Name => "myutilst_a.ada");
pragma Source_File_name (My_Utilities.Stacks,
Body_File_Name => "myutilst.ada");
-
+
As shown in this example, the first argument for the pragma is the unit
name (in this example a child unit). The second argument has the form
of a named association. The identifier
@@ -467,7 +467,7 @@ of the language, here `ada`, as in:
.. code-block:: sh
$ gcc -c -x ada peculiar_file_name.sim
-
+
`gnatmake` handles non-standard file names in the usual manner (the
non-standard file name for the main program is simply used as the
argument to gnatmake). Note that if the extension is also non-standard,
@@ -573,7 +573,7 @@ two pragmas appear:
(Spec_File_Name => ".1.ada");
pragma Source_File_Name
(Body_File_Name => ".2.ada");
-
+
The default GNAT scheme is actually implemented by providing the following
default pragmas internally:
@@ -583,7 +583,7 @@ default pragmas internally:
(Spec_File_Name => ".ads", Dot_Replacement => "-");
pragma Source_File_Name
(Body_File_Name => ".adb", Dot_Replacement => "-");
-
+
Our final example implements a scheme typically used with one of the
Ada 83 compilers, where the separator character for subunits was '__'
(two underscores), specs were identified by adding :file:`_.ADA`, bodies
@@ -609,7 +609,7 @@ the same double underscore separator for child units.
Casing = Uppercase);
-.. index:: ! gnatname
+.. index:: ! gnatname
.. _Handling_Arbitrary_File_Naming_Conventions_with_gnatname:
@@ -654,7 +654,7 @@ The usual form of the `gnatname` command is:
$ gnatname [`switches`] `naming_pattern` [`naming_patterns`]
[--and [`switches`] `naming_pattern` [`naming_patterns`]]
-
+
All of the arguments are optional. If invoked without any argument,
`gnatname` will display its usage.
@@ -683,7 +683,7 @@ Examples of Naming Patterns are::
"*.[12].ada"
"*.ad[sb]*"
"body_*" "spec_*"
-
+
For a more complete description of the syntax of Naming Patterns,
see the second kind of regular expressions described in :file:`g-regexp.ads`
(the 'Glob' regular expressions).
@@ -784,7 +784,7 @@ You may specify any of the following switches to `gnatname`:
.. code-block:: sh
gnatname -Pprj -f"*.c" "*.ada"
-
+
will look for Ada units in all files with the :file:`.ada` extension,
and will add to the list of file for project :file:`prj.gpr` the C files
with extension :file:`.c`.
@@ -833,7 +833,7 @@ You may specify any of the following switches to `gnatname`:
.. code-block:: sh
gnatname -x "*_nt.ada" "*.ada"
-
+
will look for Ada units in all files with the :file:`.ada` extension,
except those whose names end with :file:`_nt.ada`.
@@ -846,7 +846,7 @@ Examples of `gnatname` Usage
.. code-block:: sh
$ gnatname -c /home/me/names.adc -d sources "[a-z]*.ada*"
-
+
In this example, the directory :file:`/home/me` must already exist
and be writable. In addition, the directory
:file:`/home/me/sources` (specified by
@@ -858,7 +858,7 @@ Note the optional spaces after *-c* and *-d*.
$ gnatname -P/home/me/proj -x "*_nt_body.ada"
-dsources -dsources/plus -Dcommon_dirs.txt "body_*" "spec_*"
-
+
Note that several switches *-d* may be used,
even in conjunction with one or several switches
*-D*. Several Naming Patterns and one excluded pattern
@@ -872,7 +872,7 @@ File Name Krunching with `gnatkr`
.. index:: ! gnatkr
-This chapter discusses the method used by the compiler to shorten
+This section discusses the method used by the compiler to shorten
the default file names chosen for Ada units so that they do not
exceed the maximum length permitted. It also describes the
`gnatkr` utility that can be used to determine the result of
@@ -920,7 +920,7 @@ The `gnatkr` command has the form:
.. code-block:: sh
$ gnatkr `name` [`length`]
-
+
`name` is the uncrunched file name, derived from the name of the unit
in the standard manner described in the previous section (i.e., in particular
all dots are replaced by hyphens). The file name may or may not have an
@@ -989,7 +989,7 @@ the specified length by following these rules:
ou st wi fix 9
ou st wi fi 8
Final file name: oustwifi.adb
-
+
* The file names for all predefined units are always krunched to eight
characters. The krunching of these predefined units uses the following
special prefix replacements:
@@ -1023,7 +1023,7 @@ the specified length by following these rules:
a- st wi fix 9
a- st wi fi 8
Final file name: a-stwifi.adb
-
+
Of course no file shortening algorithm can guarantee uniqueness over all
possible unit names, and if file name krunching is used then it is your
responsibility to ensure that no name clashes occur. The utility
@@ -1043,7 +1043,7 @@ Examples of `gnatkr` Usage
$ gnatkr grandparent-parent-child --> grparchi
$ gnatkr very_long_unit_name.ads/count=6 --> vlunna.ads
$ gnatkr very_long_unit_name.ads/count=0 --> very_long_unit_name.ads
-
+
.. _Renaming_Files_with_gnatchop:
@@ -1052,7 +1052,7 @@ Renaming Files with `gnatchop`
.. index:: ! gnatchop
-This chapter discusses how to handle files with multiple units by using
+This section discusses how to handle files with multiple units by using
the `gnatchop` utility. This utility is also useful in renaming
files to meet the standard GNAT default file naming conventions.
@@ -1160,7 +1160,7 @@ The `gnatchop` command has the form:
$ gnatchop switches file_name [file_name ...]
[directory]
-
+
The only required argument is the file name of the file to be chopped.
There are no restrictions on the form of this file name. The file itself
contains one or more Ada units, in normal GNAT format, concatenated
@@ -1179,19 +1179,19 @@ file called :file:`hellofiles` containing
.. code-block:: ada
procedure Hello;
-
+
with Ada.Text_IO; use Ada.Text_IO;
procedure Hello is
begin
Put_Line ("Hello");
end Hello;
-
+
the command
.. code-block:: sh
$ gnatchop hellofiles
-
+
generates two files in the current directory, one called
:file:`hello.ads` containing the single line that is the procedure spec,
and the other called :file:`hello.adb` containing the remaining text. The
@@ -1214,13 +1214,13 @@ the command
.. code-block:: sh
$ gnatchop toto.txt
-
+
will not produce any new file and will result in the following warnings::
toto.txt:1:01: warning: empty file, contains no compilation units
no compilation units found
no source files written
-
+
.. _Switches_for_gnatchop:
@@ -1355,7 +1355,7 @@ directory are modified).
.. code-block:: sh
$ gnatchop archive
-
+
Chops the source file :file:`archive`
into the current directory. One
useful application of `gnatchop` is in sending sets of sources
@@ -1368,7 +1368,7 @@ file names.
.. code-block:: sh
$ gnatchop file1 file2 file3 direc
-
+
Chops all units in files :file:`file1`, :file:`file2`, :file:`file3`, placing
the resulting files in the directory :file:`direc`. Note that if any units
occur more than once anywhere within this set of files, an error message
@@ -1390,7 +1390,7 @@ Configuration Pragmas
Configuration pragmas include those pragmas described as
such in the Ada Reference Manual, as well as
implementation-dependent pragmas that are configuration pragmas.
-See the `Implementation_Defined_Pragmas` chapter in the
+See the `Implementation_Defined_Pragmas` chapter in the
:title:`GNAT_Reference_Manual` for details on these
additional GNAT-specific configuration pragmas.
Most notably, the pragma `Source_File_Name`, which allows
@@ -1446,6 +1446,7 @@ recognized by GNAT::
Propagate_Exceptions
Queuing_Policy
Ravenscar
+ Rename_Pragma
Restricted_Run_Time
Restrictions
Restrictions_Warnings
@@ -1464,7 +1465,7 @@ recognized by GNAT::
Validity_Checks
Warnings
Wide_Character_Encoding
-
+
.. _Handling_of_Configuration_Pragmas:
@@ -1550,8 +1551,10 @@ depend on a file that no longer exists. Such tools include
*gprbuild*, *gnatmake*, and *gnatcheck*.
If you are using project file, a separate mechanism is provided using
-project attributes, see :ref:`Specifying_Configuration_Pragmas` for more
-details.
+project attributes.
+
+.. --Comment:
+ See :ref:`Specifying_Configuration_Pragmas` for more details.
.. _Generating_Object_Files:
@@ -1788,10 +1791,10 @@ GNAT and Libraries
.. index:: Library building and using
-This chapter describes how to build and use libraries with GNAT, and also shows
+This section describes how to build and use libraries with GNAT, and also shows
how to recompile the GNAT run-time library. You should be familiar with the
-Project Manager facility (:ref:`GNAT_Project_Manager`) before reading this
-chapter.
+Project Manager facility (see the *GNAT_Project_Manager* chapter of the
+*GPRbuild User's Guide*) before reading this chapter.
.. _Introduction_to_Libraries_in_GNAT:
@@ -1849,7 +1852,8 @@ Building a library
The easiest way to build a library is to use the Project Manager,
which supports a special type of project called a *Library Project*
-(see :ref:`Library_Projects`).
+(see the *Library Projects* section in the *GNAT Project Manager*
+chapter of the *GPRbuild User's Guide*).
A project is considered a library project, when two project-level attributes
are defined in it: `Library_Name` and `Library_Dir`. In order to
@@ -1889,13 +1893,13 @@ Here is a simple library project file:
for Library_Dir use "lib";
for Library_Kind use "dynamic";
end My_lib;
-
+
and the compilation command to build and install the library:
.. code-block:: sh
$ gnatmake -Pmy_lib
-
+
It is not entirely trivial to perform manually all the steps required to
produce a library. We recommend that you use the GNAT Project Manager
for this task. In special cases where this is not desired, the necessary
@@ -1922,7 +1926,7 @@ Here is an example of such a dummy program:
begin
null;
end;
-
+
Here are the generic commands that will build an archive or a shared library.
.. code-block:: sh
@@ -1947,7 +1951,7 @@ Here are the generic commands that will build an archive or a shared library.
# Make the ALI files read-only so that gnatmake will not try to
# regenerate the objects that are in the library
$ chmod -w *.ali
-
+
Please note that the library must have a name of the form :file:`lib{xxx}.a`
or :file:`lib{xxx}.so` (or :file:`lib{xxx}.dll` on Windows) in order to
be accessed by the directive :samp:`-l{xxx}` at link time.
@@ -1961,7 +1965,8 @@ Installing a library
.. index:: GPR_PROJECT_PATH
If you use project files, library installation is part of the library build
-process (:ref:`Installing_a_library_with_project_files`).
+process (see the *Installing a Library with Project Files* section of the
+*GNAT Project Manager* chapter of the *GPRbuild User's Guide*).
When project files are not an option, it is also possible, but not recommended,
to install the library so that the sources needed to use the library are on the
@@ -1976,7 +1981,7 @@ file. The location of the gcc spec file can be determined as follows:
.. code-block:: sh
$ gcc -v
-
+
The configuration files mentioned above have a simple format: each line
must contain one unique directory name.
@@ -2025,7 +2030,7 @@ write:
project My_Proj is
...
end My_Proj;
-
+
Even if you have a third-party, non-Ada library, you can still use GNAT's
Project Manager facility to provide a wrapper for it. For example, the
following project, when |withed| by your main project, will link with the
@@ -2040,7 +2045,7 @@ third-party library :file:`liba.a`:
for Library_Name use "a";
for Library_Kind use "static";
end Liba;
-
+
This is an alternative to the use of `pragma Linker_Options`. It is
especially interesting in the context of systems with several interdependent
static libraries where finding a proper linker order is not easy and best be
@@ -2060,7 +2065,7 @@ For example, you can use the library :file:`mylib` installed in
$ gnatmake -aI/dir/my_lib_src -aO/dir/my_lib_obj my_appl \\
-largs -lmy_lib
-
+
This can be expressed more simply:
.. code-block:: sh
@@ -2083,7 +2088,7 @@ when the following conditions are met:
.. code-block:: ada
pragma Linker_Options ("-lmy_lib");
-
+
Note that you may also load a library dynamically at
run time given its filename, as illustrated in the GNAT :file:`plugins` example
in the directory :file:`share/examples/gnat/plugins` within the GNAT
@@ -2137,18 +2142,20 @@ Building a Stand-alone Library
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
GNAT's Project facility provides a simple way of building and installing
-stand-alone libraries; see :ref:`Stand-alone_Library_Projects`.
+stand-alone libraries; see the *Stand-alone Library Projects* section
+in the *GNAT Project Manager* chapter of the *GPRbuild User's Guide*.
To be a Stand-alone Library Project, in addition to the two attributes
that make a project a Library Project (`Library_Name` and
-`Library_Dir`; see :ref:`Library_Projects`), the attribute
-`Library_Interface` must be defined. For example:
+`Library_Dir`; see the *Library Projects* section in the
+*GNAT Project Manager* chapter of the *GPRbuild User's Guide*),
+the attribute `Library_Interface` must be defined. For example:
.. code-block:: gpr
-
+
for Library_Dir use "lib_dir";
for Library_Name use "dummy";
for Library_Interface use ("int1", "int1.child");
-
+
Attribute `Library_Interface` has a non-empty string list value,
each string in the list designating a unit contained in an immediate source
of the project file.
@@ -2189,7 +2196,7 @@ build an encapsulated library the attribute
for Library_Kind use "dynamic";
for Library_Interface use ("int1", "int1.child");
for Library_Standalone use "encapsulated";
-
+
The default value for this attribute is `standard` in which case
a stand-alone library is built.
@@ -2220,13 +2227,13 @@ occasions when it is necessary here are the steps that you need to perform:
.. code-block:: sh
$ gnatbind -n int1.ali int2.ali -Lsal1
-
+
* Compile the binder generated file:
.. code-block:: sh
$ gcc -c b~int2.adb
-
+
* Link the dynamic library with all the necessary object files,
indicating to the linker the names of the `init` (and possibly
`final`) procedures for automatic initialization (and finalization).
@@ -2267,7 +2274,7 @@ Here is an example of simple library interface for use with C main program:
pragma Export (C, Do_Something_Else, "do_something_else");
end My_Package;
-
+
On the foreign language side, you must provide a 'foreign' view of the
library interface; remember that it should contain elaboration routines in
addition to interface subprograms.
@@ -2286,7 +2293,7 @@ that there is no rule for the naming of this file, any name can be used)
/* the interface exported by the library */
extern void do_something (void);
extern void do_something_else (void);
-
+
Libraries built as explained above can be used from any program, provided
that the elaboration procedures (named `mylibinit` in the previous
example) are called before the library services are used. Any number of
@@ -2304,7 +2311,7 @@ Below is an example of a C program that uses the `mylib` library.
{
/* First, elaborate the library before using it */
mylibinit ();
-
+
/* Main program, using the library exported entities */
do_something ();
do_something_else ();
@@ -2381,7 +2388,7 @@ be determined by means of the command:
.. code-block:: sh
$ gnatls -v
-
+
The last entry in the object search path usually contains the
gnat library. This Makefile contains its own documentation and in
particular the set of instructions needed to rebuild a new library and
@@ -2447,7 +2454,7 @@ constants to control which code is executed.
if FP_Initialize_Required then
...
end if;
-
+
Not only will the code inside the `if` statement not be executed if
the constant Boolean is `False`, but it will also be completely
deleted from the program.
@@ -2469,7 +2476,7 @@ something like:
Reset_Available : constant Boolean := False;
...
end Config;
-
+
The `Config` package exists in multiple forms for the various targets,
with an appropriate script selecting the version of `Config` needed.
Then any other unit requiring conditional compilation can do a |with|
@@ -2514,13 +2521,13 @@ example, the last test could be written:
.. code-block:: ada
pragma Assert (Temperature <= 999.0, "Temperature Crazy");
-
+
or simply
.. code-block:: ada
pragma Assert (Temperature <= 999.0);
-
+
In both cases, if assertions are active and the temperature is excessive,
the exception `Assert_Failure` will be raised, with the given string in
the first case or a string indicating the location of the pragma in the second
@@ -2546,7 +2553,7 @@ For the example above with the `Put_Line`, the GNAT-specific pragma
.. code-block:: ada
pragma Debug (Put_Line ("got to the first stage!"));
-
+
If debug pragmas are enabled, the argument, which must be of the form of
a procedure call, is executed (in this case, `Put_Line` will be called).
Only one call can be present, but of course a special debugging procedure
@@ -2587,7 +2594,7 @@ to add a `null` statement.
pragma Assert (Num_Cases < 10);
null;
end if;
-
+
.. _Conditionalizing_Declarations:
Conditionalizing Declarations
@@ -2685,7 +2692,7 @@ to compile with an Ada 95 compiler. Conceptually you want to say:
else
... not quite as neat Ada 95 code
end if;
-
+
where `Ada_2005` is a Boolean constant.
But this won't work when `Ada_2005` is set to `False`,
@@ -2715,7 +2722,7 @@ This can also be done with project files' naming schemes. For example:
.. code-block:: gpr
for body ("File_Queries.Insert") use "file_queries-insert-2005.ada";
-
+
Note also that with project files it is desirable to use a different extension
than :file:`ads` / :file:`adb` for alternative versions. Otherwise a naming
conflict may arise through another commonly used feature: to declare as part
@@ -2865,6 +2872,17 @@ where
Switches for `gnatprep`
^^^^^^^^^^^^^^^^^^^^^^^
+.. index:: --version (gnatprep)
+
+:samp:`--version`
+ Display Copyright and version, then exit disregarding all other options.
+
+.. index:: --help (gnatprep)
+
+:samp:`--help`
+ If *--version* was not used, display usage, then exit disregarding
+ all other options.
+
.. index:: -b (gnatprep)
:samp:`-b`
@@ -2922,6 +2940,12 @@ Switches for `gnatprep`
Causes a sorted list of symbol names and values to be
listed on the standard output file.
+.. index:: -T (gnatprep)
+
+:samp:`-T`
+ Use LF as line terminators when writing files. By default the line terminator
+ of the host (LF under unix, CR/LF under Windows) is used.
+
.. index:: -u (gnatprep)
:samp:`-u`
@@ -2929,6 +2953,11 @@ Switches for `gnatprep`
of a preprocessor test. In the absence of this option, an undefined symbol in
a `#if` or `#elsif` test will be treated as an error.
+.. index:: -v (gnatprep)
+
+:samp:`-v`
+ Verbose mode: generates more output about work done.
+
Note: if neither *-b* nor *-c* is present,
then preprocessor lines and
@@ -2996,7 +3025,7 @@ In this example, <expression> is defined by the following grammar::
<expression> ::= <expression> and then <expression>
<expression> ::= <expression> or else <expression>
<expression> ::= ( <expression> )
-
+
Note the following restriction: it is not allowed to have "and" or "or"
following "not" in the same expression without parentheses. For example, this
is not allowed:
@@ -3004,14 +3033,14 @@ is not allowed:
.. code-block:: ada
not X or Y
-
+
This can be expressed instead as one of the following forms:
.. code-block:: ada
(not X) or Y
not (X or Y)
-
+
For the first test (<expression> ::= <symbol>) the symbol must have
either the value true or false, that is to say the right-hand of the
symbol definition must be one of the (case-insensitive) literals
@@ -3061,7 +3090,7 @@ Symbol substitution outside of preprocessor lines is obtained by using
the sequence::
$symbol
-
+
anywhere within a source line, except in a comment or within a
string literal. The identifier
following the `$` must match one of the symbols defined in the symbol
@@ -3126,10 +3155,18 @@ preprocessing is triggered and parameterized.
:samp:`-gnatep={file}`
This switch indicates to the compiler the file name (without directory
information) of the preprocessor data file to use. The preprocessor data file
- should be found in the source directories. Note that when the compiler is
- called by a builder such as (*gnatmake* with a project
- file, if the object directory is not also a source directory, the builder needs
- to be called with *-x*.
+ should be found in the source directories. Alternatively when using project
+ files, you can reference to the project file's directory via the
+ ``project name'Project_Dir`` project attribute, e.g:
+
+ .. code-block:: gpr
+
+ project Prj is
+ package Compiler is
+ for Switches ("Ada") use
+ ("-gnatep=" & Prj'Project_Dir & "prep.def");
+ end Compiler;
+ end Prj;
A preprocessing data file is a text file with significant lines indicating
how should be preprocessed either a specific source or all sources not
@@ -3267,7 +3304,7 @@ the main subprogram in Ada:
/* file1.c */
#include <stdio.h>
-
+
void print_num (int num)
{
printf ("num is %d.\\n", num);
@@ -3277,15 +3314,15 @@ the main subprogram in Ada:
.. code-block:: c
/* file2.c */
-
+
/* num_from_Ada is declared in my_main.adb */
extern int num_from_Ada;
-
+
int get_num (void)
{
return num_from_Ada;
}
-
+
.. code-block:: ada
-- my_main.adb
@@ -3308,7 +3345,7 @@ the main subprogram in Ada:
begin
Print_Num (Get_Num);
end My_Main;
-
+
To build this example:
* First compile the foreign language files to
@@ -3318,7 +3355,7 @@ To build this example:
$ gcc -c file1.c
$ gcc -c file2.c
-
+
* Then, compile the Ada units to produce a set of object files and ALI
files:
@@ -3338,13 +3375,13 @@ To build this example:
.. code-block:: sh
$ gnatlink my_main.ali file1.o file2.o
-
+
The last three steps can be grouped in a single command:
.. code-block:: sh
-
+
$ gnatmake my_main.adb -largs file1.o file2.o
-
+
.. index:: Binder output file
@@ -3383,7 +3420,7 @@ sources. To illustrate, we have the following example:
adafinal();
}
-
+
.. code-block:: ada
-- unit1.ads
@@ -3419,7 +3456,7 @@ sources. To illustrate, we have the following example:
return A - B;
end Sub;
end Unit2;
-
+
The build procedure for this application is similar to the last
example's:
@@ -3428,7 +3465,7 @@ example's:
.. code-block:: sh
$ gcc -c main.c
-
+
* Next, compile the Ada units to produce a set of object files and ALI
files:
@@ -3437,21 +3474,21 @@ example's:
$ gnatmake -c unit1.adb
$ gnatmake -c unit2.adb
-
+
* Run the Ada binder on every generated ALI file. Make sure to use the
:option:`-n` option to specify a foreign main program:
.. code-block:: sh
$ gnatbind -n unit1.ali unit2.ali
-
+
* Link the Ada main program, the Ada objects and the foreign language
objects. You need only list the last ALI file here:
.. code-block:: sh
$ gnatlink unit2.ali main.o -o exec_file
-
+
This procedure yields a binary executable called :file:`exec_file`.
Depending on the circumstances (for example when your non-Ada main object
@@ -3637,7 +3674,7 @@ Convention identifiers are recognized by GNAT:
function "/" (D : Distance; T : Time)
return Velocity;
pragma Import (Intrinsic, "/");
-
+
This common idiom is often programmed with a generic definition and an
explicit body. The pragma makes it simpler to introduce such declarations.
It incurs no overhead in compilation time or code size, because it is
@@ -3655,7 +3692,7 @@ Convention identifiers are recognized by GNAT:
function builtin_sqrt (F : Float) return Float;
pragma Import (Intrinsic, builtin_sqrt, "__builtin_sqrtf");
-
+
Most of the GCC builtins are accessible this way, and as for other
import conventions (e.g. C), it is the user's responsibility to ensure
that the Ada subprogram profile matches the underlying builtin
@@ -3702,7 +3739,7 @@ pragma:
.. code-block:: ada
pragma Convention_Identifier (Fortran77, Fortran);
-
+
And from now on the identifier Fortran77 may be used as a convention
identifier (for example in an `Import` pragma) with the same
meaning as Fortran.
@@ -3769,7 +3806,7 @@ considered:
$ g++ -c -fkeep-inline-functions file1.C
$ g++ -c -fkeep-inline-functions file2.C
$ gnatmake ada_unit -largs file1.o file2.o --LINK=g++
-
+
* Using GNAT and G++ from two different GCC installations: If both
compilers are on the :envvar`PATH`, the previous method may be used. It is
@@ -3789,7 +3826,7 @@ considered:
$ gnatbind ada_unit
$ gnatlink -v -v ada_unit file1.o file2.o --LINK=c++
-
+
If there is a problem due to interfering environment variables, it can
be worked around by using an intermediate script. The following example
shows the proper script to use when GNAT has not been installed at its
@@ -3803,7 +3840,7 @@ considered:
unset GCC_ROOT
c++ $*
$ gnatlink -v -v ada_unit file1.o file2.o --LINK=./my_script
-
+
* Using a non-GNU C++ compiler: The commands previously described can be
used to insure that the C++ linker is used. Nonetheless, you need to add
@@ -3819,7 +3856,7 @@ considered:
#!/bin/sh
CC $* `gcc -print-file-name=libgcc.a` `gcc -print-file-name=libgcc_eh.a`
$ gnatlink ada_unit file1.o file2.o --LINK=./my_script
-
+
where CC is the name of the non-GNU C++ compiler.
@@ -3835,7 +3872,7 @@ considered:
`gcc -print-file-name=libgcc.a` `gcc -print-file-name=libgcc_eh.a` \\
`gcc -print-file-name=crtend.o`
$ gnatlink ada_unit file1.o file2.o --LINK=./my_script
-
+
If the "zero cost exception" mechanism is used, and the platform
doesn't support automatic registration of exception tables (e.g., HP-UX
@@ -3871,7 +3908,7 @@ Here are the compilation commands:
$ g++ -c ex7.C
$ gnatbind -n simple_cpp_interface
$ gnatlink simple_cpp_interface -o cpp_main --LINK=g++ -lstdc++ ex7.o cpp_main.o
-
+
Here are the corresponding sources:
.. code-block:: cpp
@@ -3941,7 +3978,7 @@ Here are the corresponding sources:
a_value = 1010;
printf ("in A::A, a_value = %d \\n",a_value);
}
-
+
.. code-block:: ada
-- simple_cpp_interface.ads
@@ -3962,7 +3999,7 @@ Here are the corresponding sources:
pragma Export (C, Ada_Method2);
end Simple_Cpp_Interface;
-
+
.. code-block:: ada
-- simple_cpp_interface.adb
@@ -4002,7 +4039,7 @@ C++ class:
Root(int v); // 1st non-default constructor
Root(int v, int w); // 2nd non-default constructor
};
-
+
For this purpose we can write the following package spec (further
information on how to build this spec is available in
:ref:`Interfacing_with_C++_at_the_Class_Level` and
@@ -4023,14 +4060,14 @@ information on how to build this spec is available in
function Constructor return Root;
pragma Cpp_Constructor (Constructor, "_ZN4RootC1Ev");
-
+
function Constructor (v : Integer) return Root;
pragma Cpp_Constructor (Constructor, "_ZN4RootC1Ei");
function Constructor (v, w : Integer) return Root;
pragma Cpp_Constructor (Constructor, "_ZN4RootC1Eii");
end Pkg_Root;
-
+
On the Ada side the constructor is represented by a function (whose
name is arbitrary) that returns the classwide type corresponding to
the imported C++ class. Although the constructor is described as a
@@ -4059,7 +4096,7 @@ expression that initializes the object. For example:
Obj2 : Root := Constructor;
Obj3 : Root := Constructor (v => 10);
Obj4 : Root := Constructor (30, 40);
-
+
The first two declarations are equivalent: in both cases the default C++
constructor is invoked (in the former case the call to the constructor is
implicit, and in the latter case the call is explicit in the object
@@ -4206,7 +4243,7 @@ and `Domestic` animals:
public:
virtual void Set_Owner (char* Name) = 0;
};
-
+
Using these declarations, we can now say that a `Dog` is an animal that is
both Carnivore and Domestic, that is:
@@ -4273,7 +4310,7 @@ how to import these C++ declarations from the Ada side:
pragma CPP_Constructor (New_Dog);
pragma Import (CPP, New_Dog, "_ZN3DogC2Ev");
end Animals;
-
+
Thanks to the compatibility between GNAT run-time structures and the C++ ABI,
interfacing with these C++ classes is easy. The only requirement is that all
the primitives and components must be declared exactly in the same order in
@@ -4362,7 +4399,7 @@ them to C++, using the same hierarchy of our previous example:
function New_Dog return Dog'Class;
pragma Export (C_Plus_Plus, New_Dog);
end Animals;
-
+
Compared with our previous example the only differences are the use of
`pragma Convention` (instead of `pragma Import`), and the use of
`pragma Export` to indicate to the GNAT compiler that the primitives will
@@ -4406,7 +4443,7 @@ finalizing the Ada run-time system along the way:
adainit (); test(); adafinal ();
return 0;
}
-
+
.. _Generating_Ada_Bindings_for_C_and_C++_headers:
Generating Ada Bindings for C and C++ headers
@@ -4451,7 +4488,7 @@ header files needed by these files transitively. For example:
$ g++ -c -fdump-ada-spec -C /usr/include/time.h
$ gcc -c -gnat05 *.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`,
@@ -4494,7 +4531,7 @@ 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
@@ -4579,7 +4616,7 @@ For example, given the following C++ header file:
Dog();
};
-
+
The corresponding Ada code is generated:
.. code-block:: ada
@@ -4632,7 +4669,7 @@ The corresponding Ada code is generated:
pragma Import (CPP, New_Dog, "_ZN3DogC1Ev");
end;
use Class_Dog;
-
+
.. _Switches_for_Ada_Binding_Generation:
@@ -4892,7 +4929,7 @@ we have the following package spec:
package QRS is
MN : Integer;
end QRS;
-
+
.. index:: pragma Export
The variable `MN` has a full expanded Ada name of `QRS.MN`, so
@@ -4907,7 +4944,7 @@ Of course if a `pragma Export` is used this may be overridden:
Var2 : Integer;
pragma Export (Var2, C, Link_Name => "var2_link_name");
end Exports;
-
+
In this case, the link name for `Var1` is whatever link name the
C compiler would assign for the C function `var1_name`. This typically
would be either `var1_name` or `_var1_name`, depending on operating
@@ -4928,4 +4965,3 @@ names. So if we have a library level procedure such as:
procedure Hello (S : String);
the external name of this procedure will be `_ada_hello`.
-
diff --git a/gcc/ada/doc/gnat_ugn/tools_supporting_project_files.rst b/gcc/ada/doc/gnat_ugn/tools_supporting_project_files.rst
deleted file mode 100644
index 7360acb0b8..0000000000
--- a/gcc/ada/doc/gnat_ugn/tools_supporting_project_files.rst
+++ /dev/null
@@ -1,745 +0,0 @@
-.. _Tools_Supporting_Project_Files:
-
-Tools Supporting Project Files
-==============================
-
-This section describes how project files can be used in conjunction with a number of
-GNAT tools.
-
-.. _gnatmake_and_Project_Files:
-
-gnatmake and Project Files
---------------------------
-
-This section covers several topics related to *gnatmake* and
-project files: defining switches for *gnatmake*
-and for the tools that it invokes; specifying configuration pragmas;
-the use of the `Main` attribute; building and rebuilding library project
-files.
-
-.. _Switches_Related_to_Project_Files:
-
-Switches Related to Project Files
-^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-
-The following switches are used by GNAT tools that support project files:
-
-
- .. index:: -P (any project-aware tool)
-
-:samp:`-P{project}`
- Indicates the name of a project file. This project file will be parsed with
- the verbosity indicated by *-vP*x**,
- if any, and using the external references indicated
- by *-X* switches, if any.
- There may zero, one or more spaces between *-P* and `project`.
-
- There must be only one *-P* switch on the command line.
-
- Since the Project Manager parses the project file only after all the switches
- on the command line are checked, the order of the switches
- *-P*,
- *-vP*x**
- or *-X* is not significant.
-
-
- .. index:: -X (any project-aware tool)
-
-:samp:`-X{name}={value}`
- Indicates that external variable `name` has the value `value`.
- The Project Manager will use this value for occurrences of
- `external(name)` when parsing the project file.
-
- If `name` or `value` includes a space, then `name=value` should be
- put between quotes.
-
- ::
-
- -XOS=NT
- -X"user=John Doe"
-
- Several *-X* switches can be used simultaneously.
- If several *-X* switches specify the same
- `name`, only the last one is used.
-
- An external variable specified with a *-X* switch
- takes precedence over the value of the same name in the environment.
-
-
- .. index:: -vP (any project-aware tool)
-
-:samp:`-vP{x}`
- Indicates the verbosity of the parsing of GNAT project files.
-
- *-vP0* means Default;
- *-vP1* means Medium;
- *-vP2* means High.
-
- The default is Default: no output for syntactically correct
- project files.
- If several *-vP*x** switches are present,
- only the last one is used.
-
-
- .. index:: -aP (any project-aware tool)
-
-:samp:`-aP{dir}`
- Add directory `dir` at the beginning of the project search path, in order,
- after the current working directory.
-
-
- .. index:: -eL (any project-aware tool)
-
-:samp:`-eL`
- Follow all symbolic links when processing project files.
-
-
- .. index:: --subdirs= (gnatmake and gnatclean)
-
-:samp:`--subdirs={subdir}`
- This switch is recognized by *gnatmake* and *gnatclean*. It
- indicate that the real directories (except the source directories) are the
- subdirectories `subdir` of the directories specified in the project files.
- This applies in particular to object directories, library directories and
- exec directories. If the subdirectories do not exist, they are created
- automatically.
-
-
-.. _Switches_and_Project_Files:
-
-Switches and Project Files
-^^^^^^^^^^^^^^^^^^^^^^^^^^
-
-For each of the packages `Builder`, `Compiler`, `Binder`, and
-`Linker`, you can specify a `Default_Switches`
-attribute, a `Switches` attribute, or both;
-as their names imply, these switch-related
-attributes affect the switches that are used for each of these GNAT
-components when
-*gnatmake* is invoked. As will be explained below, these
-component-specific switches precede
-the switches provided on the *gnatmake* command line.
-
-The `Default_Switches` attribute is an attribute
-indexed by language name (case insensitive) whose value is a string list.
-For example:
-
- .. code-block:: gpr
-
- package Compiler is
- for Default_Switches ("Ada")
- use ("-gnaty",
- "-v");
- end Compiler;
-
-The `Switches` attribute is indexed on a file name (which may or may
-not be case sensitive, depending
-on the operating system) whose value is a string list. For example:
-
- .. code-block:: gpr
-
- package Builder is
- for Switches ("main1.adb")
- use ("-O2");
- for Switches ("main2.adb")
- use ("-g");
- end Builder;
-
-For the `Builder` package, the file names must designate source files
-for main subprograms. For the `Binder` and `Linker` packages, the
-file names must designate :file:`ALI` or source files for main subprograms.
-In each case just the file name without an explicit extension is acceptable.
-
-For each tool used in a program build (*gnatmake*, the compiler, the
-binder, and the linker), the corresponding package @dfn{contributes} a set of
-switches for each file on which the tool is invoked, based on the
-switch-related attributes defined in the package.
-In particular, the switches
-that each of these packages contributes for a given file `f` comprise:
-
-* the value of attribute `Switches (`f`)`,
- if it is specified in the package for the given file,
-* otherwise, the value of `Default_Switches ("Ada")`,
- if it is specified in the package.
-
-If neither of these attributes is defined in the package, then the package does
-not contribute any switches for the given file.
-
-When *gnatmake* is invoked on a file, the switches comprise
-two sets, in the following order: those contributed for the file
-by the `Builder` package;
-and the switches passed on the command line.
-
-When *gnatmake* invokes a tool (compiler, binder, linker) on a file,
-the switches passed to the tool comprise three sets,
-in the following order:
-
-* the applicable switches contributed for the file
- by the `Builder` package in the project file supplied on the command line;
-
-* those contributed for the file by the package (in the relevant project file --
- see below) corresponding to the tool; and
-
-* the applicable switches passed on the command line.
-
-The term *applicable switches* reflects the fact that
-*gnatmake* switches may or may not be passed to individual
-tools, depending on the individual switch.
-
-*gnatmake* may invoke the compiler on source files from different
-projects. The Project Manager will use the appropriate project file to
-determine the `Compiler` package for each source file being compiled.
-Likewise for the `Binder` and `Linker` packages.
-
-As an example, consider the following package in a project file:
-
-
- .. code-block:: gpr
-
- project Proj1 is
- package Compiler is
- for Default_Switches ("Ada")
- use ("-g");
- for Switches ("a.adb")
- use ("-O1");
- for Switches ("b.adb")
- use ("-O2",
- "-gnaty");
- end Compiler;
- end Proj1;
-
-If *gnatmake* is invoked with this project file, and it needs to
-compile, say, the files :file:`a.adb`, :file:`b.adb`, and :file:`c.adb`, then
-:file:`a.adb` will be compiled with the switch *-O1*,
-:file:`b.adb` with switches *-O2* and *-gnaty*,
-and :file:`c.adb` with *-g*.
-
-The following example illustrates the ordering of the switches
-contributed by different packages:
-
- .. code-block:: gpr
-
- project Proj2 is
- package Builder is
- for Switches ("main.adb")
- use ("-g",
- "-O1",
- "-f");
- end Builder;
-
- package Compiler is
- for Switches ("main.adb")
- use ("-O2");
- end Compiler;
- end Proj2;
-
-If you issue the command:
-
- ::
-
- $ gnatmake -Pproj2 -O0 main
-
-then the compiler will be invoked on :file:`main.adb` with the following
-sequence of switches
-
- ::
-
- -g -O1 -O2 -O0
-
-with the last *-O*
-switch having precedence over the earlier ones;
-several other switches
-(such as *-c*) are added implicitly.
-
-The switches *-g*
-and *-O1* are contributed by package
-`Builder`, *-O2* is contributed
-by the package `Compiler`
-and *-O0* comes from the command line.
-
-The *-g* switch will also be passed in the invocation of
-*Gnatlink.*
-
-A final example illustrates switch contributions from packages in different
-project files:
-
- .. code-block:: gpr
-
- project Proj3 is
- for Source_Files use ("pack.ads", "pack.adb");
- package Compiler is
- for Default_Switches ("Ada")
- use ("-gnata");
- end Compiler;
- end Proj3;
-
- with "Proj3";
- project Proj4 is
- for Source_Files use ("foo_main.adb", "bar_main.adb");
- package Builder is
- for Switches ("foo_main.adb")
- use ("-s",
- "-g");
- end Builder;
- end Proj4;
-
- .. code-block:: ada
-
- -- Ada source file:
- with Pack;
- procedure Foo_Main is
- ...
- end Foo_Main;
-
-If the command is
-
- ::
-
- $ gnatmake -PProj4 foo_main.adb -cargs -gnato
-
-then the switches passed to the compiler for :file:`foo_main.adb` are
-*-g* (contributed by the package `Proj4.Builder`) and
-*-gnato* (passed on the command line).
-When the imported package `Pack` is compiled, the switches used
-are *-g* from `Proj4.Builder`,
-*-gnata* (contributed from package `Proj3.Compiler`,
-and *-gnato* from the command line.
-
-When using *gnatmake* with project files, some switches or
-arguments may be expressed as relative paths. As the working directory where
-compilation occurs may change, these relative paths are converted to absolute
-paths. For the switches found in a project file, the relative paths
-are relative to the project file directory, for the switches on the command
-line, they are relative to the directory where *gnatmake* is invoked.
-The switches for which this occurs are:
--I,
--A,
--L,
--aO,
--aL,
--aI, as well as all arguments that are not switches (arguments to
-switch
--o, object files specified in package `Linker` or after
--largs on the command line). The exception to this rule is the switch
---RTS= for which a relative path argument is never converted.
-
-.. _Specifying_Configuration_Pragmas:
-
-Specifying Configuration Pragmas
-^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-
-When using *gnatmake* with project files, if there exists a file
-:file:`gnat.adc` that contains configuration pragmas, this file will be
-ignored.
-
-Configuration pragmas can be defined by means of the following attributes in
-project files: `Global_Configuration_Pragmas` in package `Builder`
-and `Local_Configuration_Pragmas` in package `Compiler`.
-
-Both these attributes are single string attributes. Their values is the path
-name of a file containing configuration pragmas. If a path name is relative,
-then it is relative to the project directory of the project file where the
-attribute is defined.
-
-When compiling a source, the configuration pragmas used are, in order,
-those listed in the file designated by attribute
-`Global_Configuration_Pragmas` in package `Builder` of the main
-project file, if it is specified, and those listed in the file designated by
-attribute `Local_Configuration_Pragmas` in package `Compiler` of
-the project file of the source, if it exists.
-
-.. _Project_Files_and_Main_Subprograms:
-
-Project Files and Main Subprograms
-^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-
-When using a project file, you can invoke *gnatmake*
-with one or several main subprograms, by specifying their source files on the
-command line.
-
- ::
-
- $ gnatmake -Pprj main1.adb main2.adb main3.adb
-
-Each of these needs to be a source file of the same project, except
-when the switch `-u` is used.
-
-When `-u` is not used, all the mains need to be sources of the
-same project, one of the project in the tree rooted at the project specified
-on the command line. The package `Builder` of this common project, the
-"main project" is the one that is considered by *gnatmake*.
-
-When `-u` is used, the specified source files may be in projects
-imported directly or indirectly by the project specified on the command line.
-Note that if such a source file is not part of the project specified on the
-command line, the switches found in package `Builder` of the
-project specified on the command line, if any, that are transmitted
-to the compiler will still be used, not those found in the project file of
-the source file.
-
-When using a project file, you can also invoke *gnatmake* without
-explicitly specifying any main, and the effect depends on whether you have
-defined the `Main` attribute. This attribute has a string list value,
-where each element in the list is the name of a source file (the file
-extension is optional) that contains a unit that can be a main subprogram.
-
-If the `Main` attribute is defined in a project file as a non-empty
-string list and the switch *-u* is not used on the command
-line, then invoking *gnatmake* with this project file but without any
-main on the command line is equivalent to invoking *gnatmake* with all
-the file names in the `Main` attribute on the command line.
-
-Example:
-
- .. code-block:: gpr
-
- project Prj is
- for Main use ("main1.adb", "main2.adb", "main3.adb");
- end Prj;
-
-With this project file, `"gnatmake -Pprj"`
-is equivalent to
-`"gnatmake -Pprj main1.adb main2.adb main3.adb"`.
-
-When the project attribute `Main` is not specified, or is specified
-as an empty string list, or when the switch *-u* is used on the command
-line, then invoking *gnatmake* with no main on the command line will
-result in all immediate sources of the project file being checked, and
-potentially recompiled. Depending on the presence of the switch *-u*,
-sources from other project files on which the immediate sources of the main
-project file depend are also checked and potentially recompiled. In other
-words, the *-u* switch is applied to all of the immediate sources of the
-main project file.
-
-When no main is specified on the command line and attribute `Main` exists
-and includes several mains, or when several mains are specified on the
-command line, the default switches in package `Builder` will
-be used for all mains, even if there are specific switches
-specified for one or several mains.
-
-But the switches from package `Binder` or `Linker` will be
-the specific switches for each main, if they are specified.
-
-.. _Library_Project_Files:
-
-Library Project Files
-^^^^^^^^^^^^^^^^^^^^^
-
-When *gnatmake* is invoked with a main project file that is a library
-project file, it is not allowed to specify one or more mains on the command
-line.
-
-When a library project file is specified, switches `-b` and
-`-l` have special meanings.
-
-* `-b` is only allowed for stand-alone libraries. It indicates
- to *gnatmake* that *gnatbind* should be invoked for the
- library.
-
-* `-l` may be used for all library projects. It indicates
- to *gnatmake* that the binder generated file should be compiled
- (in the case of a stand-alone library) and that the library should be built.
-
-
-.. _The_GNAT_Driver_and_Project_Files:
-
-The GNAT Driver and Project Files
----------------------------------
-
-A number of GNAT tools beyond *gnatmake*
-can benefit from project files:
-
-.. only:: PRO or GPL
-
- * *gnatbind*
- * *gnatcheck*
- * *gnatclean*
- * *gnatelim*
- * *gnatfind*
- * *gnatlink*
- * *gnatls*
- * *gnatmetric*
- * *gnatpp*
- * *gnatstub*
- * *gnatxref*
-
-.. only:: FSF
-
- * *gnatbind*
- * *gnatclean*
- * *gnatfind*
- * *gnatlink*
- * *gnatls*
- * *gnatxref*
-
-However, none of these tools can be invoked
-directly with a project file switch (*-P*).
-They must be invoked through the *gnat* driver.
-
-The *gnat* driver is a wrapper that accepts a number of commands and
-calls the corresponding tool. It was designed initially for VMS platforms (to
-convert VMS qualifiers to Unix-style switches), but it is now available on all
-GNAT platforms.
-
-On non-VMS platforms, the *gnat* driver accepts the following commands
-(case insensitive):
-
-.. only:: PRO or GPL
-
- * BIND to invoke *gnatbind*
- * CHOP to invoke *gnatchop*
- * CLEAN to invoke *gnatclean*
- * COMP or COMPILE to invoke the compiler
- * ELIM to invoke *gnatelim*
- * FIND to invoke *gnatfind*
- * KR or KRUNCH to invoke *gnatkr*
- * LINK to invoke *gnatlink*
- * LS or LIST to invoke *gnatls*
- * MAKE to invoke *gnatmake*
- * METRIC to invoke *gnatmetric*
- * NAME to invoke *gnatname*
- * PP or PRETTY to invoke *gnatpp*
- * PREP or PREPROCESS to invoke *gnatprep*
- * STUB to invoke *gnatstub*
- * XREF to invoke *gnatxref*
-
-.. only:: FSF
-
- * BIND to invoke *gnatbind*
- * CHOP to invoke *gnatchop*
- * CLEAN to invoke *gnatclean*
- * COMP or COMPILE to invoke the compiler
- * FIND to invoke *gnatfind*
- * KR or KRUNCH to invoke *gnatkr*
- * LINK to invoke *gnatlink*
- * LS or LIST to invoke *gnatls*
- * MAKE to invoke *gnatmake*
- * NAME to invoke *gnatname*
- * PREP or PREPROCESS to invoke *gnatprep*
- * XREF to invoke *gnatxref*
-
-Note that the command
-*gnatmake -c -f -u* is used to invoke the compiler.
-
-On non-VMS platforms, between *gnat* and the command, two
-special switches may be used:
-
-* *-v* to display the invocation of the tool.
-* *-dn* to prevent the *gnat* driver from removing
- the temporary files it has created. These temporary files are
- configuration files and temporary file list files.
-
-The command may be followed by switches and arguments for the invoked
-tool.
-
- ::
-
- $ gnat bind -C main.ali
- $ gnat ls -a main
- $ gnat chop foo.txt
-
-Switches may also be put in text files, one switch per line, and the text
-files may be specified with their path name preceded by '@'.
-
- ::
-
- $ gnat bind @args.txt main.ali
-
-In addition, for the following commands the project file related switches
-(*-P*, *-X* and *-vPx*) may be used in addition to
-the switches of the invoking tool:
-
-.. only:: PRO or GPL
-
- * BIND
- * COMP or COMPILE
- * FIND
- * ELIM
- * LS or LIST
- * LINK
- * METRIC
- * PP or PRETTY
- * STUB
- * XREF
-
-.. only:: FSF
-
- * BIND
- * COMP or COMPILE
- * FIND
- * LS or LIST
- * LINK
- * XREF
-
-.. only:: PRO or GPL
-
- When GNAT PP or GNAT PRETTY is used with a project file, but with no source
- specified on the command line, it invokes *gnatpp* with all
- the immediate sources of the specified project file.
-
- When GNAT METRIC is used with a project file, but with no source
- specified on the command line, it invokes *gnatmetric*
- with all the immediate sources of the specified project file and with
- *-d* with the parameter pointing to the object directory
- of the project.
-
- In addition, when GNAT PP, GNAT PRETTY or GNAT METRIC is used with
- a project file, no source is specified on the command line and
- switch -U is specified on the command line, then
- the underlying tool (gnatpp or
- gnatmetric) is invoked for all sources of all projects,
- not only for the immediate sources of the main project.
- (-U stands for Universal or Union of the project files of the project tree)
-
-For each of the following commands, there is optionally a corresponding
-package in the main project.
-
-.. only:: PRO or GPL
-
- * package `Binder` for command BIND (invoking `gnatbind`)
- * package `Check` for command CHECK (invoking `gnatcheck`)
- * package `Compiler` for command COMP or COMPILE (invoking the compiler)
- * package `Cross_Reference` for command XREF (invoking `gnatxref`)
- * package `Eliminate` for command ELIM (invoking `gnatelim`)
- * package `Finder` for command FIND (invoking `gnatfind`)
- * package `Gnatls` for command LS or LIST (invoking `gnatls`)
- * package `Gnatstub` for command STUB (invoking `gnatstub`)
- * package `Linker` for command LINK (invoking `gnatlink`)
- * package `Metrics` for command METRIC (invoking `gnatmetric`)
- * package `Pretty_Printer` for command PP or PRETTY (invoking `gnatpp`)
-
-.. only:: FSF
-
- * package `Binder` for command BIND (invoking `gnatbind`)
- * package `Compiler` for command COMP or COMPILE (invoking the compiler)
- * package `Cross_Reference` for command XREF (invoking `gnatxref`)
- * package `Finder` for command FIND (invoking `gnatfind`)
- * package `Gnatls` for command LS or LIST (invoking `gnatls`)
- * package `Linker` for command LINK (invoking `gnatlink`)
-
-Package `Gnatls` has a unique attribute `Switches`,
-a simple variable with a string list value. It contains switches
-for the invocation of `gnatls`.
-
- .. code-block:: gpr
-
- project Proj1 is
- package gnatls is
- for Switches
- use ("-a",
- "-v");
- end gnatls;
- end Proj1;
-
-All other packages have two attribute `Switches` and
-`Default_Switches`.
-
-`Switches` is an indexed attribute, indexed by the
-source file name, that has a string list value: the switches to be
-used when the tool corresponding to the package is invoked for the specific
-source file.
-
-`Default_Switches` is an attribute,
-indexed by the programming language that has a string list value.
-`Default_Switches ("Ada")` contains the
-switches for the invocation of the tool corresponding
-to the package, except if a specific `Switches` attribute
-is specified for the source file.
-
- .. code-block:: gpr
-
- project Proj is
-
- for Source_Dirs use ("");
-
- package gnatls is
- for Switches use
- ("-a",
- "-v");
- end gnatls;
-
- package Compiler is
- for Default_Switches ("Ada")
- use ("-gnatv",
- "-gnatwa");
- end Binder;
-
- package Binder is
- for Default_Switches ("Ada")
- use ("-C",
- "-e");
- end Binder;
-
- package Linker is
- for Default_Switches ("Ada")
- use ("-C");
- for Switches ("main.adb")
- use ("-C",
- "-v",
- "-v");
- end Linker;
-
- package Finder is
- for Default_Switches ("Ada")
- use ("-a",
- "-f");
- end Finder;
-
- package Cross_Reference is
- for Default_Switches ("Ada")
- use ("-a",
- "-f",
- "-d",
- "-u");
- end Cross_Reference;
- end Proj;
-
-With the above project file, commands such as
-
- ::
-
- $ gnat comp -Pproj main
- $ gnat ls -Pproj main
- $ gnat xref -Pproj main
- $ gnat bind -Pproj main.ali
- $ gnat link -Pproj main.ali
-
-will set up the environment properly and invoke the tool with the switches
-found in the package corresponding to the tool:
-`Default_Switches ("Ada")` for all tools,
-except `Switches ("main.adb")`
-for `gnatlink`.
-
-.. only:: PRO or GPL
-
- It is also possible to invoke some of the tools,
- (`gnatcheck`,
- `gnatmetric`,
- and `gnatpp`)
- on a set of project units thanks to the combination of the switches
- *-P*, *-U* and possibly the main unit when one is interested
- in its closure. For instance,
-
- ::
-
- $ gnat metric -Pproj
-
- will compute the metrics for all the immediate units of project `proj`.
-
- ::
-
- $ gnat metric -Pproj -U
-
- will compute the metrics for all the units of the closure of projects
- rooted at `proj`.
-
- ::
-
- $ gnat metric -Pproj -U main_unit
-
- will compute the metrics for the closure of units rooted at
- `main_unit`. This last possibility relies implicitly
- on *gnatbind*'s option *-R*. But if the argument files for the
- tool invoked by the *gnat* driver are explicitly specified
- either directly or through the tool *-files* option, then the tool
- is called only for these explicitly specified files.
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index b252e8c0b9..e97d1478bb 100644
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -244,8 +244,9 @@ package body Einfo is
-- Relative_Deadline_Variable Node28
-- Underlying_Record_View Node28
+ -- Anonymous_Masters Elist29
-- BIP_Initialization_Call Node29
- -- Subprograms_For_Type Node29
+ -- Subprograms_For_Type Elist29
-- Anonymous_Object Node30
-- Corresponding_Equality Node30
@@ -256,6 +257,8 @@ package body Einfo is
-- Thunk_Entity Node31
-- Activation_Record_Component Node31
+ -- Corresponding_Function Node32
+ -- Corresponding_Procedure Node32
-- Encapsulating_State Node32
-- No_Tagged_Streams_Pragma Node32
@@ -263,16 +266,17 @@ package body Einfo is
-- Contract Node34
+ -- Anonymous_Designated_Type Node35
+ -- Entry_Max_Queue_Lengths_Array Node35
-- Import_Pragma Node35
- -- Anonymous_Master Node36
-
-- Class_Wide_Preconds List38
-- Class_Wide_Postconds List39
-- SPARK_Pragma Node40
+ -- Original_Protected_Subprogram Node41
-- SPARK_Aux_Pragma Node41
---------------------------------------------
@@ -286,7 +290,7 @@ package body Einfo is
-- Is_Inlined_Always Flag1
-- Is_Hidden_Non_Overridden_Subpgm Flag2
- -- Has_Default_Init_Cond Flag3
+ -- Has_Own_DIC Flag3
-- Is_Frozen Flag4
-- Has_Discriminants Flag5
-- Is_Dispatching_Operation Flag6
@@ -428,9 +432,8 @@ package body Einfo is
-- Is_Generic_Instance Flag130
-- No_Pool_Assigned Flag131
- -- Is_Default_Init_Cond_Procedure Flag132
- -- Has_Inherited_Default_Init_Cond Flag133
- -- Returns_Limited_View Flag134
+ -- Is_DIC_Procedure Flag132
+ -- Has_Inherited_DIC Flag133
-- Has_Aliased_Components Flag135
-- No_Strict_Aliasing Flag136
-- Is_Machine_Code_Subprogram Flag137
@@ -528,7 +531,7 @@ package body Einfo is
-- Has_Pragma_Preelab_Init Flag221
-- Used_As_Generic_Actual Flag222
- -- Is_Descendent_Of_Address Flag223
+ -- Is_Descendant_Of_Address Flag223
-- Is_Raised Flag224
-- Is_Thunk Flag225
-- Is_Only_Out_Parameter Flag226
@@ -538,7 +541,7 @@ package body Einfo is
-- Has_Pragma_Inline_Always Flag230
-- Renamed_In_Spec Flag231
- -- Has_Invariants Flag232
+ -- Has_Own_Invariants Flag232
-- Has_Pragma_Unmodified Flag233
-- Is_Dispatch_Table_Entity Flag234
-- Is_Trivial_Subprogram Flag235
@@ -560,7 +563,7 @@ package body Einfo is
-- Has_Predicates Flag250
-- Has_Implicit_Dereference Flag251
- -- Is_Processed_Transient Flag252
+ -- Is_Finalized_Transient Flag252
-- Disable_Controlled Flag253
-- Is_Implementation_Defined Flag254
-- Is_Predicate_Function Flag255
@@ -597,11 +600,23 @@ package body Einfo is
-- Is_Uplevel_Referenced_Entity Flag283
-- Is_Unimplemented Flag284
-- Is_Volatile_Full_Access Flag285
- -- (unused) Flag286
+ -- Is_Exception_Handler Flag286
-- Rewritten_For_C Flag287
+ -- Predicates_Ignored Flag288
+ -- Has_Timing_Event Flag289
+
+ -- (unused) Flag290 -- ??? flag breaks einfo.h
- -- (unused) Flag288
- -- (unused) Flag289
+ -- Has_Inherited_Invariants Flag291
+ -- Is_Partial_Invariant_Procedure Flag292
+ -- Is_Actual_Subtype Flag293
+ -- Has_Pragma_Unused Flag294
+ -- Is_Ignored_Transient Flag295
+ -- Has_Partial_Visible_Refinement Flag296
+ -- Is_Entry_Wrapper Flag297
+ -- Is_Underlying_Full_View Flag298
+
+ -- (unused) Flag299
-- (unused) Flag300
-- (unused) Flag301
@@ -753,15 +768,20 @@ package body Einfo is
return Uint14 (Id);
end Alignment;
- function Anonymous_Master (Id : E) return E is
+ function Anonymous_Designated_Type (Id : E) return E is
+ begin
+ pragma Assert (Ekind (Id) = E_Variable);
+ return Node35 (Id);
+ end Anonymous_Designated_Type;
+
+ function Anonymous_Masters (Id : E) return L is
begin
pragma Assert (Ekind_In (Id, E_Function,
E_Package,
- E_Package_Body,
E_Procedure,
E_Subprogram_Body));
- return Node36 (Id);
- end Anonymous_Master;
+ return Elist29 (Id);
+ end Anonymous_Masters;
function Anonymous_Object (Id : E) return E is
begin
@@ -915,6 +935,18 @@ package body Einfo is
return Node30 (Id);
end Corresponding_Equality;
+ function Corresponding_Function (Id : E) return E is
+ begin
+ pragma Assert (Ekind (Id) = E_Procedure);
+ return Node32 (Id);
+ end Corresponding_Function;
+
+ function Corresponding_Procedure (Id : E) return E is
+ begin
+ pragma Assert (Ekind (Id) = E_Function);
+ return Node32 (Id);
+ end Corresponding_Procedure;
+
function Corresponding_Protected_Entry (Id : E) return E is
begin
pragma Assert (Ekind (Id) = E_Subprogram_Body);
@@ -1190,6 +1222,12 @@ package body Einfo is
return Node18 (Id);
end Entry_Index_Constant;
+ function Entry_Max_Queue_Lengths_Array (Id : E) return N is
+ begin
+ pragma Assert (Ekind (Id) = E_Protected_Type);
+ return Node35 (Id);
+ end Entry_Max_Queue_Lengths_Array;
+
function Contains_Ignored_Ghost_Code (Id : E) return B is
begin
pragma Assert
@@ -1489,12 +1527,6 @@ package body Einfo is
return Flag39 (Base_Type (Id));
end Has_Default_Aspect;
- function Has_Default_Init_Cond (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag3 (Base_Type (Id));
- end Has_Default_Init_Cond;
-
function Has_Delayed_Aspects (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
@@ -1581,14 +1613,20 @@ package body Einfo is
function Has_Inheritable_Invariants (Id : E) return B is
begin
pragma Assert (Is_Type (Id));
- return Flag248 (Id);
+ return Flag248 (Base_Type (Id));
end Has_Inheritable_Invariants;
- function Has_Inherited_Default_Init_Cond (Id : E) return B is
+ function Has_Inherited_DIC (Id : E) return B is
begin
pragma Assert (Is_Type (Id));
return Flag133 (Base_Type (Id));
- end Has_Inherited_Default_Init_Cond;
+ end Has_Inherited_DIC;
+
+ function Has_Inherited_Invariants (Id : E) return B is
+ begin
+ pragma Assert (Is_Type (Id));
+ return Flag291 (Base_Type (Id));
+ end Has_Inherited_Invariants;
function Has_Initial_Value (Id : E) return B is
begin
@@ -1596,12 +1634,6 @@ package body Einfo is
return Flag219 (Id);
end Has_Initial_Value;
- function Has_Invariants (Id : E) return B is
- begin
- pragma Assert (Is_Type (Id));
- return Flag232 (Id);
- end Has_Invariants;
-
function Has_Loop_Entry_Attributes (Id : E) return B is
begin
pragma Assert (Ekind (Id) = E_Loop);
@@ -1655,6 +1687,24 @@ package body Einfo is
return Flag110 (Id);
end Has_Out_Or_In_Out_Parameter;
+ function Has_Own_DIC (Id : E) return B is
+ begin
+ pragma Assert (Is_Type (Id));
+ return Flag3 (Base_Type (Id));
+ end Has_Own_DIC;
+
+ function Has_Own_Invariants (Id : E) return B is
+ begin
+ pragma Assert (Is_Type (Id));
+ return Flag232 (Base_Type (Id));
+ end Has_Own_Invariants;
+
+ function Has_Partial_Visible_Refinement (Id : E) return B is
+ begin
+ pragma Assert (Ekind (Id) = E_Abstract_State);
+ return Flag296 (Id);
+ end Has_Partial_Visible_Refinement;
+
function Has_Per_Object_Constraint (Id : E) return B is
begin
return Flag154 (Id);
@@ -1734,6 +1784,11 @@ package body Einfo is
return Flag212 (Id);
end Has_Pragma_Unreferenced_Objects;
+ function Has_Pragma_Unused (Id : E) return B is
+ begin
+ return Flag294 (Id);
+ end Has_Pragma_Unused;
+
function Has_Predicates (Id : E) return B is
begin
pragma Assert (Is_Type (Id));
@@ -1870,6 +1925,11 @@ package body Einfo is
return Flag228 (Id);
end Has_Thunks;
+ function Has_Timing_Event (Id : E) return B is
+ begin
+ return Flag289 (Base_Type (Id));
+ end Has_Timing_Event;
+
function Has_Unchecked_Union (Id : E) return B is
begin
return Flag123 (Base_Type (Id));
@@ -1976,18 +2036,18 @@ package body Einfo is
return Flag146 (Id);
end Is_Abstract_Type;
- function Is_Local_Anonymous_Access (Id : E) return B is
- begin
- pragma Assert (Is_Access_Type (Id));
- return Flag194 (Id);
- end Is_Local_Anonymous_Access;
-
function Is_Access_Constant (Id : E) return B is
begin
pragma Assert (Is_Access_Type (Id));
return Flag69 (Id);
end Is_Access_Constant;
+ function Is_Actual_Subtype (Id : E) return B is
+ begin
+ pragma Assert (Is_Type (Id));
+ return Flag293 (Id);
+ end Is_Actual_Subtype;
+
function Is_Ada_2005_Only (Id : E) return B is
begin
return Flag185 (Id);
@@ -2033,7 +2093,10 @@ package body Einfo is
function Is_Checked_Ghost_Entity (Id : E) return B is
begin
- pragma Assert (Nkind (Id) in N_Entity);
+ -- Allow this attribute to appear on unanalyzed entities
+
+ pragma Assert (Nkind (Id) in N_Entity
+ or else Ekind (Id) = E_Void);
return Flag277 (Id);
end Is_Checked_Ghost_Entity;
@@ -2095,16 +2158,16 @@ package body Einfo is
return Flag74 (Id);
end Is_CPP_Class;
- function Is_Default_Init_Cond_Procedure (Id : E) return B is
+ function Is_DIC_Procedure (Id : E) return B is
begin
pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
return Flag132 (Id);
- end Is_Default_Init_Cond_Procedure;
+ end Is_DIC_Procedure;
- function Is_Descendent_Of_Address (Id : E) return B is
+ function Is_Descendant_Of_Address (Id : E) return B is
begin
return Flag223 (Id);
- end Is_Descendent_Of_Address;
+ end Is_Descendant_Of_Address;
function Is_Discrim_SO_Function (Id : E) return B is
begin
@@ -2137,11 +2200,28 @@ package body Einfo is
return Flag52 (Id);
end Is_Entry_Formal;
+ function Is_Entry_Wrapper (Id : E) return B is
+ begin
+ return Flag297 (Id);
+ end Is_Entry_Wrapper;
+
+ function Is_Exception_Handler (Id : E) return B is
+ begin
+ pragma Assert (Ekind (Id) = E_Block);
+ return Flag286 (Id);
+ end Is_Exception_Handler;
+
function Is_Exported (Id : E) return B is
begin
return Flag99 (Id);
end Is_Exported;
+ function Is_Finalized_Transient (Id : E) return B is
+ begin
+ pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable));
+ return Flag252 (Id);
+ end Is_Finalized_Transient;
+
function Is_First_Subtype (Id : E) return B is
begin
return Flag70 (Id);
@@ -2203,10 +2283,19 @@ package body Einfo is
function Is_Ignored_Ghost_Entity (Id : E) return B is
begin
- pragma Assert (Nkind (Id) in N_Entity);
+ -- Allow this attribute to appear on unanalyzed entities
+
+ pragma Assert (Nkind (Id) in N_Entity
+ or else Ekind (Id) = E_Void);
return Flag278 (Id);
end Is_Ignored_Ghost_Entity;
+ function Is_Ignored_Transient (Id : E) return B is
+ begin
+ pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable));
+ return Flag295 (Id);
+ end Is_Ignored_Transient;
+
function Is_Immediately_Visible (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
@@ -2307,6 +2396,12 @@ package body Einfo is
return Flag25 (Id);
end Is_Limited_Record;
+ function Is_Local_Anonymous_Access (Id : E) return B is
+ begin
+ pragma Assert (Is_Access_Type (Id));
+ return Flag194 (Id);
+ end Is_Local_Anonymous_Access;
+
function Is_Machine_Code_Subprogram (Id : E) return B is
begin
pragma Assert (Is_Subprogram (Id));
@@ -2357,6 +2452,12 @@ package body Einfo is
return Flag215 (Base_Type (Id));
end Is_Param_Block_Component_Type;
+ function Is_Partial_Invariant_Procedure (Id : E) return B is
+ begin
+ pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
+ return Flag292 (Id);
+ end Is_Partial_Invariant_Procedure;
+
function Is_Potentially_Use_Visible (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
@@ -2365,13 +2466,13 @@ package body Einfo is
function Is_Predicate_Function (Id : E) return B is
begin
- pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure);
+ pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
return Flag255 (Id);
end Is_Predicate_Function;
function Is_Predicate_Function_M (Id : E) return B is
begin
- pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure);
+ pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
return Flag256 (Id);
end Is_Predicate_Function_M;
@@ -2411,12 +2512,6 @@ package body Einfo is
return Flag245 (Id);
end Is_Private_Primitive;
- function Is_Processed_Transient (Id : E) return B is
- begin
- pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable));
- return Flag252 (Id);
- end Is_Processed_Transient;
-
function Is_Public (Id : E) return B is
begin
pragma Assert (Nkind (Id) in N_Entity);
@@ -2517,6 +2612,11 @@ package body Einfo is
return Flag117 (Implementation_Base_Type (Id));
end Is_Unchecked_Union;
+ function Is_Underlying_Full_View (Id : E) return B is
+ begin
+ return Flag298 (Id);
+ end Is_Underlying_Full_View;
+
function Is_Underlying_Record_View (Id : E) return B is
begin
return Flag246 (Id);
@@ -2822,6 +2922,11 @@ package body Einfo is
return Node21 (Id);
end Original_Array_Type;
+ function Original_Protected_Subprogram (Id : E) return N is
+ begin
+ return Node41 (Id);
+ end Original_Protected_Subprogram;
+
function Original_Record_Component (Id : E) return E is
begin
pragma Assert (Ekind_In (Id, E_Void, E_Component, E_Discriminant));
@@ -2835,6 +2940,7 @@ package body Einfo is
function Overridden_Operation (Id : E) return E is
begin
+ pragma Assert (Is_Subprogram (Id) or else Is_Generic_Subprogram (Id));
return Node26 (Id);
end Overridden_Operation;
@@ -2889,6 +2995,12 @@ package body Einfo is
return Node14 (Id);
end Postconditions_Proc;
+ function Predicates_Ignored (Id : E) return B is
+ begin
+ pragma Assert (Is_Type (Id));
+ return Flag288 (Id);
+ end Predicates_Ignored;
+
function Prival (Id : E) return E is
begin
pragma Assert (Is_Protected_Component (Id));
@@ -3037,12 +3149,6 @@ package body Einfo is
return Flag90 (Id);
end Returns_By_Ref;
- function Returns_Limited_View (Id : E) return B is
- begin
- pragma Assert (Ekind (Id) = E_Function);
- return Flag134 (Id);
- end Returns_Limited_View;
-
function Reverse_Bit_Order (Id : E) return B is
begin
pragma Assert (Is_Record_Type (Id));
@@ -3277,10 +3383,10 @@ package body Einfo is
return Node18 (Id);
end String_Literal_Low_Bound;
- function Subprograms_For_Type (Id : E) return E is
+ function Subprograms_For_Type (Id : E) return L is
begin
- pragma Assert (Is_Type (Id) or else Is_Subprogram (Id));
- return Node29 (Id);
+ pragma Assert (Is_Type (Id));
+ return Elist29 (Id);
end Subprograms_For_Type;
function Subps_Index (Id : E) return U is
@@ -3653,15 +3759,20 @@ package body Einfo is
Set_Elist16 (Id, V);
end Set_Access_Disp_Table;
- procedure Set_Anonymous_Master (Id : E; V : E) is
+ procedure Set_Anonymous_Designated_Type (Id : E; V : E) is
+ begin
+ pragma Assert (Ekind (Id) = E_Variable);
+ Set_Node35 (Id, V);
+ end Set_Anonymous_Designated_Type;
+
+ procedure Set_Anonymous_Masters (Id : E; V : L) is
begin
pragma Assert (Ekind_In (Id, E_Function,
E_Package,
- E_Package_Body,
E_Procedure,
E_Subprogram_Body));
- Set_Node36 (Id, V);
- end Set_Anonymous_Master;
+ Set_Elist29 (Id, V);
+ end Set_Anonymous_Masters;
procedure Set_Anonymous_Object (Id : E; V : E) is
begin
@@ -3912,6 +4023,18 @@ package body Einfo is
Set_Node30 (Id, V);
end Set_Corresponding_Equality;
+ procedure Set_Corresponding_Function (Id : E; V : E) is
+ begin
+ pragma Assert (Ekind (Id) = E_Procedure and then Rewritten_For_C (V));
+ Set_Node32 (Id, V);
+ end Set_Corresponding_Function;
+
+ procedure Set_Corresponding_Procedure (Id : E; V : E) is
+ begin
+ pragma Assert (Ekind (Id) = E_Function and then Rewritten_For_C (Id));
+ Set_Node32 (Id, V);
+ end Set_Corresponding_Procedure;
+
procedure Set_Corresponding_Protected_Entry (Id : E; V : E) is
begin
pragma Assert (Ekind_In (Id, E_Void, E_Subprogram_Body));
@@ -4186,6 +4309,12 @@ package body Einfo is
Set_Node18 (Id, V);
end Set_Entry_Index_Constant;
+ procedure Set_Entry_Max_Queue_Lengths_Array (Id : E; V : E) is
+ begin
+ pragma Assert (Ekind (Id) = E_Protected_Type);
+ Set_Node35 (Id, V);
+ end Set_Entry_Max_Queue_Lengths_Array;
+
procedure Set_Entry_Parameters_Type (Id : E; V : E) is
begin
Set_Node15 (Id, V);
@@ -4445,12 +4574,6 @@ package body Einfo is
Set_Flag39 (Id, V);
end Set_Has_Default_Aspect;
- procedure Set_Has_Default_Init_Cond (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag3 (Base_Type (Id), V);
- end Set_Has_Default_Init_Cond;
-
procedure Set_Has_Delayed_Aspects (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
@@ -4542,14 +4665,20 @@ package body Einfo is
procedure Set_Has_Inheritable_Invariants (Id : E; V : B := True) is
begin
pragma Assert (Is_Type (Id));
- Set_Flag248 (Id, V);
+ Set_Flag248 (Base_Type (Id), V);
end Set_Has_Inheritable_Invariants;
- procedure Set_Has_Inherited_Default_Init_Cond (Id : E; V : B := True) is
+ procedure Set_Has_Inherited_DIC (Id : E; V : B := True) is
begin
pragma Assert (Is_Type (Id));
Set_Flag133 (Base_Type (Id), V);
- end Set_Has_Inherited_Default_Init_Cond;
+ end Set_Has_Inherited_DIC;
+
+ procedure Set_Has_Inherited_Invariants (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Type (Id));
+ Set_Flag291 (Base_Type (Id), V);
+ end Set_Has_Inherited_Invariants;
procedure Set_Has_Initial_Value (Id : E; V : B := True) is
begin
@@ -4557,12 +4686,6 @@ package body Einfo is
Set_Flag219 (Id, V);
end Set_Has_Initial_Value;
- procedure Set_Has_Invariants (Id : E; V : B := True) is
- begin
- pragma Assert (Is_Type (Id));
- Set_Flag232 (Id, V);
- end Set_Has_Invariants;
-
procedure Set_Has_Loop_Entry_Attributes (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) = E_Loop);
@@ -4617,6 +4740,24 @@ package body Einfo is
Set_Flag110 (Id, V);
end Set_Has_Out_Or_In_Out_Parameter;
+ procedure Set_Has_Own_DIC (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Type (Id));
+ Set_Flag3 (Base_Type (Id), V);
+ end Set_Has_Own_DIC;
+
+ procedure Set_Has_Own_Invariants (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Type (Id));
+ Set_Flag232 (Base_Type (Id), V);
+ end Set_Has_Own_Invariants;
+
+ procedure Set_Has_Partial_Visible_Refinement (Id : E; V : B := True) is
+ begin
+ pragma Assert (Ekind (Id) = E_Abstract_State);
+ Set_Flag296 (Id, V);
+ end Set_Has_Partial_Visible_Refinement;
+
procedure Set_Has_Per_Object_Constraint (Id : E; V : B := True) is
begin
Set_Flag154 (Id, V);
@@ -4698,6 +4839,11 @@ package body Einfo is
Set_Flag212 (Id, V);
end Set_Has_Pragma_Unreferenced_Objects;
+ procedure Set_Has_Pragma_Unused (Id : E; V : B := True) is
+ begin
+ Set_Flag294 (Id, V);
+ end Set_Has_Pragma_Unused;
+
procedure Set_Has_Predicates (Id : E; V : B := True) is
begin
pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Void);
@@ -4838,6 +4984,12 @@ package body Einfo is
Set_Flag228 (Id, V);
end Set_Has_Thunks;
+ procedure Set_Has_Timing_Event (Id : E; V : B := True) is
+ begin
+ pragma Assert (Id = Base_Type (Id));
+ Set_Flag289 (Id, V);
+ end Set_Has_Timing_Event;
+
procedure Set_Has_Unchecked_Union (Id : E; V : B := True) is
begin
pragma Assert (Id = Base_Type (Id));
@@ -4966,6 +5118,12 @@ package body Einfo is
Set_Flag69 (Id, V);
end Set_Is_Access_Constant;
+ procedure Set_Is_Actual_Subtype (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Type (Id));
+ Set_Flag293 (Id, V);
+ end Set_Is_Actual_Subtype;
+
procedure Set_Is_Ada_2005_Only (Id : E; V : B := True) is
begin
Set_Flag185 (Id, V);
@@ -5014,20 +5172,9 @@ package body Einfo is
procedure Set_Is_Checked_Ghost_Entity (Id : E; V : B := True) is
begin
- pragma Assert (Is_Formal (Id)
- or else Is_Object (Id)
- or else Is_Package_Or_Generic_Package (Id)
- or else Is_Subprogram_Or_Generic_Subprogram (Id)
- or else Is_Type (Id)
- or else Ekind (Id) = E_Abstract_State
- or else Ekind (Id) = E_Component
- or else Ekind (Id) = E_Discriminant
- or else Ekind (Id) = E_Exception
- or else Ekind (Id) = E_Package_Body
- or else Ekind (Id) = E_Subprogram_Body
-
- -- Allow this attribute to appear on non-analyzed entities
+ -- Allow this attribute to appear on unanalyzed entities
+ pragma Assert (Nkind (Id) in N_Entity
or else Ekind (Id) = E_Void);
Set_Flag277 (Id, V);
end Set_Is_Checked_Ghost_Entity;
@@ -5096,17 +5243,17 @@ package body Einfo is
Set_Flag74 (Id, V);
end Set_Is_CPP_Class;
- procedure Set_Is_Default_Init_Cond_Procedure (Id : E; V : B := True) is
+ procedure Set_Is_DIC_Procedure (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) = E_Procedure);
Set_Flag132 (Id, V);
- end Set_Is_Default_Init_Cond_Procedure;
+ end Set_Is_DIC_Procedure;
- procedure Set_Is_Descendent_Of_Address (Id : E; V : B := True) is
+ procedure Set_Is_Descendant_Of_Address (Id : E; V : B := True) is
begin
pragma Assert (Is_Type (Id));
Set_Flag223 (Id, V);
- end Set_Is_Descendent_Of_Address;
+ end Set_Is_Descendant_Of_Address;
procedure Set_Is_Discrim_SO_Function (Id : E; V : B := True) is
begin
@@ -5145,11 +5292,28 @@ package body Einfo is
Set_Flag52 (Id, V);
end Set_Is_Entry_Formal;
+ procedure Set_Is_Entry_Wrapper (Id : E; V : B := True) is
+ begin
+ Set_Flag297 (Id, V);
+ end Set_Is_Entry_Wrapper;
+
+ procedure Set_Is_Exception_Handler (Id : E; V : B := True) is
+ begin
+ pragma Assert (Ekind (Id) = E_Block);
+ Set_Flag286 (Id, V);
+ end Set_Is_Exception_Handler;
+
procedure Set_Is_Exported (Id : E; V : B := True) is
begin
Set_Flag99 (Id, V);
end Set_Is_Exported;
+ procedure Set_Is_Finalized_Transient (Id : E; V : B := True) is
+ begin
+ pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable));
+ Set_Flag252 (Id, V);
+ end Set_Is_Finalized_Transient;
+
procedure Set_Is_First_Subtype (Id : E; V : B := True) is
begin
Set_Flag70 (Id, V);
@@ -5213,24 +5377,19 @@ package body Einfo is
procedure Set_Is_Ignored_Ghost_Entity (Id : E; V : B := True) is
begin
- pragma Assert (Is_Formal (Id)
- or else Is_Object (Id)
- or else Is_Package_Or_Generic_Package (Id)
- or else Is_Subprogram_Or_Generic_Subprogram (Id)
- or else Is_Type (Id)
- or else Ekind (Id) = E_Abstract_State
- or else Ekind (Id) = E_Component
- or else Ekind (Id) = E_Discriminant
- or else Ekind (Id) = E_Exception
- or else Ekind (Id) = E_Package_Body
- or else Ekind (Id) = E_Subprogram_Body
-
- -- Allow this attribute to appear on non-analyzed entities
+ -- Allow this attribute to appear on unanalyzed entities
+ pragma Assert (Nkind (Id) in N_Entity
or else Ekind (Id) = E_Void);
Set_Flag278 (Id, V);
end Set_Is_Ignored_Ghost_Entity;
+ procedure Set_Is_Ignored_Transient (Id : E; V : B := True) is
+ begin
+ pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable));
+ Set_Flag295 (Id, V);
+ end Set_Is_Ignored_Transient;
+
procedure Set_Is_Immediately_Visible (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
@@ -5385,6 +5544,12 @@ package body Einfo is
Set_Flag215 (Id, V);
end Set_Is_Param_Block_Component_Type;
+ procedure Set_Is_Partial_Invariant_Procedure (Id : E; V : B := True) is
+ begin
+ pragma Assert (Ekind (Id) = E_Procedure);
+ Set_Flag292 (Id, V);
+ end Set_Is_Partial_Invariant_Procedure;
+
procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
@@ -5393,13 +5558,13 @@ package body Einfo is
procedure Set_Is_Predicate_Function (Id : E; V : B := True) is
begin
- pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure);
+ pragma Assert (Ekind (Id) = E_Function);
Set_Flag255 (Id, V);
end Set_Is_Predicate_Function;
procedure Set_Is_Predicate_Function_M (Id : E; V : B := True) is
begin
- pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure);
+ pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
Set_Flag256 (Id, V);
end Set_Is_Predicate_Function_M;
@@ -5439,12 +5604,6 @@ package body Einfo is
Set_Flag245 (Id, V);
end Set_Is_Private_Primitive;
- procedure Set_Is_Processed_Transient (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind_In (Id, E_Constant, E_Loop_Parameter, E_Variable));
- Set_Flag252 (Id, V);
- end Set_Is_Processed_Transient;
-
procedure Set_Is_Public (Id : E; V : B := True) is
begin
pragma Assert (Nkind (Id) in N_Entity);
@@ -5555,6 +5714,12 @@ package body Einfo is
Set_Flag117 (Id, V);
end Set_Is_Unchecked_Union;
+ procedure Set_Is_Underlying_Full_View (Id : E; V : B := True) is
+ begin
+ pragma Assert (Is_Type (Id));
+ Set_Flag298 (Id, V);
+ end Set_Is_Underlying_Full_View;
+
procedure Set_Is_Underlying_Record_View (Id : E; V : B := True) is
begin
pragma Assert (Ekind (Id) = E_Record_Type);
@@ -5864,6 +6029,12 @@ package body Einfo is
Set_Node21 (Id, V);
end Set_Original_Array_Type;
+ procedure Set_Original_Protected_Subprogram (Id : E; V : N) is
+ begin
+ pragma Assert (Ekind_In (Id, E_Function, E_Procedure));
+ Set_Node41 (Id, V);
+ end Set_Original_Protected_Subprogram;
+
procedure Set_Original_Record_Component (Id : E; V : E) is
begin
pragma Assert (Ekind_In (Id, E_Void, E_Component, E_Discriminant));
@@ -5877,6 +6048,7 @@ package body Einfo is
procedure Set_Overridden_Operation (Id : E; V : E) is
begin
+ pragma Assert (Is_Subprogram (Id) or else Is_Generic_Subprogram (Id));
Set_Node26 (Id, V);
end Set_Overridden_Operation;
@@ -5931,6 +6103,12 @@ package body Einfo is
Set_Node14 (Id, V);
end Set_Postconditions_Proc;
+ procedure Set_Predicates_Ignored (Id : E; V : B) is
+ begin
+ pragma Assert (Is_Type (Id));
+ Set_Flag288 (Id, V);
+ end Set_Predicates_Ignored;
+
procedure Set_Direct_Primitive_Operations (Id : E; V : L) is
begin
pragma Assert (Is_Tagged_Type (Id));
@@ -6087,12 +6265,6 @@ package body Einfo is
Set_Flag90 (Id, V);
end Set_Returns_By_Ref;
- procedure Set_Returns_Limited_View (Id : E; V : B := True) is
- begin
- pragma Assert (Ekind (Id) = E_Function);
- Set_Flag134 (Id, V);
- end Set_Returns_Limited_View;
-
procedure Set_Reverse_Bit_Order (Id : E; V : B := True) is
begin
pragma Assert
@@ -6340,10 +6512,10 @@ package body Einfo is
Set_Node18 (Id, V);
end Set_String_Literal_Low_Bound;
- procedure Set_Subprograms_For_Type (Id : E; V : E) is
+ procedure Set_Subprograms_For_Type (Id : E; V : L) is
begin
- pragma Assert (Is_Type (Id) or else Is_Subprogram (Id));
- Set_Node29 (Id, V);
+ pragma Assert (Is_Type (Id));
+ Set_Elist29 (Id, V);
end Set_Subprograms_For_Type;
procedure Set_Subps_Index (Id : E; V : U) is
@@ -6876,31 +7048,6 @@ package body Einfo is
end loop;
end Declaration_Node;
- ---------------------------------
- -- Default_Init_Cond_Procedure --
- ---------------------------------
-
- function Default_Init_Cond_Procedure (Id : E) return E is
- Subp_Id : Entity_Id;
-
- begin
- pragma Assert
- (Is_Type (Id)
- and then (Has_Default_Init_Cond (Id)
- or Has_Inherited_Default_Init_Cond (Id)));
-
- Subp_Id := Subprograms_For_Type (Base_Type (Id));
- while Present (Subp_Id) loop
- if Is_Default_Init_Cond_Procedure (Subp_Id) then
- return Subp_Id;
- end if;
-
- Subp_Id := Subprograms_For_Type (Subp_Id);
- end loop;
-
- return Empty;
- end Default_Init_Cond_Procedure;
-
---------------------
-- Designated_Type --
---------------------
@@ -6928,6 +7075,36 @@ package body Einfo is
end if;
end Designated_Type;
+ -------------------
+ -- DIC_Procedure --
+ -------------------
+
+ function DIC_Procedure (Id : E) return E is
+ Subp_Elmt : Elmt_Id;
+ Subp_Id : Entity_Id;
+ Subps : Elist_Id;
+
+ begin
+ pragma Assert (Is_Type (Id));
+
+ Subps := Subprograms_For_Type (Base_Type (Id));
+
+ if Present (Subps) then
+ Subp_Elmt := First_Elmt (Subps);
+ while Present (Subp_Elmt) loop
+ Subp_Id := Node (Subp_Elmt);
+
+ if Is_DIC_Procedure (Subp_Id) then
+ return Subp_Id;
+ end if;
+
+ Next_Elmt (Subp_Elmt);
+ end loop;
+ end if;
+
+ return Empty;
+ end DIC_Procedure;
+
----------------------
-- Entry_Index_Type --
----------------------
@@ -7004,17 +7181,19 @@ package body Einfo is
else
Formal := First_Entity (Id);
+ -- Deal with the common, non-generic case first
+
+ if No (Formal) or else Is_Formal (Formal) then
+ return Formal;
+ end if;
+
-- The first/next entity chain of a generic subprogram contains all
- -- generic formal parameters, followed by the formal parameters. Go
- -- directly to the parameters by skipping the formal part.
+ -- generic formal parameters, followed by the formal parameters.
if Is_Generic_Subprogram (Id) then
while Present (Formal) and then not Is_Formal (Formal) loop
Next_Entity (Formal);
end loop;
- end if;
-
- if Present (Formal) and then Is_Formal (Formal) then
return Formal;
else
return Empty;
@@ -7180,7 +7359,7 @@ package body Einfo is
while Present (Item) loop
if Nkind (Item) = N_Pragma
- and then Get_Pragma_Id (Pragma_Name (Item)) = Id
+ and then Get_Pragma_Id (Pragma_Name_Unmapped (Item)) = Id
then
return Item;
@@ -7243,6 +7422,15 @@ package body Einfo is
return False;
end Has_Attach_Handler;
+ -------------
+ -- Has_DIC --
+ -------------
+
+ function Has_DIC (Id : E) return B is
+ begin
+ return Has_Own_DIC (Id) or else Has_Inherited_DIC (Id);
+ end Has_DIC;
+
-----------------
-- Has_Entries --
-----------------
@@ -7304,6 +7492,15 @@ package body Einfo is
return False;
end Has_Interrupt_Handler;
+ --------------------
+ -- Has_Invariants --
+ --------------------
+
+ function Has_Invariants (Id : E) return B is
+ begin
+ return Has_Own_Invariants (Id) or else Has_Inherited_Invariants (Id);
+ end Has_Invariants;
+
--------------------------
-- Has_Non_Limited_View --
--------------------------
@@ -7316,27 +7513,41 @@ package body Einfo is
and then Present (Non_Limited_View (Id));
end Has_Non_Limited_View;
+ ---------------------------------
+ -- Has_Non_Null_Abstract_State --
+ ---------------------------------
+
+ function Has_Non_Null_Abstract_State (Id : E) return B is
+ begin
+ pragma Assert (Ekind_In (Id, E_Generic_Package, E_Package));
+
+ return
+ Present (Abstract_States (Id))
+ and then
+ not Is_Null_State (Node (First_Elmt (Abstract_States (Id))));
+ end Has_Non_Null_Abstract_State;
+
-------------------------------------
-- Has_Non_Null_Visible_Refinement --
-------------------------------------
function Has_Non_Null_Visible_Refinement (Id : E) return B is
+ Constits : Elist_Id;
+
begin
-- "Refinement" is a concept applicable only to abstract states
pragma Assert (Ekind (Id) = E_Abstract_State);
+ Constits := Refinement_Constituents (Id);
- if Has_Visible_Refinement (Id) then
- pragma Assert (Present (Refinement_Constituents (Id)));
-
- -- For a refinement to be non-null, the first constituent must be
- -- anything other than null.
+ -- A partial refinement is always non-null. For a full refinement to be
+ -- non-null, the first constituent must be anything other than null.
- return
- Nkind (Node (First_Elmt (Refinement_Constituents (Id)))) /= N_Null;
- end if;
-
- return False;
+ return
+ Has_Partial_Visible_Refinement (Id)
+ or else (Has_Visible_Refinement (Id)
+ and then Present (Constits)
+ and then Nkind (Node (First_Elmt (Constits))) /= N_Null);
end Has_Non_Null_Visible_Refinement;
-----------------------------
@@ -7357,22 +7568,21 @@ package body Einfo is
---------------------------------
function Has_Null_Visible_Refinement (Id : E) return B is
+ Constits : Elist_Id;
+
begin
-- "Refinement" is a concept applicable only to abstract states
pragma Assert (Ekind (Id) = E_Abstract_State);
+ Constits := Refinement_Constituents (Id);
- if Has_Visible_Refinement (Id) then
- pragma Assert (Present (Refinement_Constituents (Id)));
-
- -- For a refinement to be null, the state's sole constituent must be
- -- a null.
+ -- For a refinement to be null, the state's sole constituent must be a
+ -- null.
- return
- Nkind (Node (First_Elmt (Refinement_Constituents (Id)))) = N_Null;
- end if;
-
- return False;
+ return
+ Has_Visible_Refinement (Id)
+ and then Present (Constits)
+ and then Nkind (Node (First_Elmt (Constits))) = N_Null;
end Has_Null_Visible_Refinement;
--------------------
@@ -7455,26 +7665,29 @@ package body Einfo is
-------------------------
function Invariant_Procedure (Id : E) return E is
- S : Entity_Id;
+ Subp_Elmt : Elmt_Id;
+ Subp_Id : Entity_Id;
+ Subps : Elist_Id;
begin
- pragma Assert (Is_Type (Id) and then Has_Invariants (Id));
+ pragma Assert (Is_Type (Id));
- if No (Subprograms_For_Type (Id)) then
- return Empty;
+ Subps := Subprograms_For_Type (Base_Type (Id));
- else
- S := Subprograms_For_Type (Id);
- while Present (S) loop
- if Is_Invariant_Procedure (S) then
- return S;
- else
- S := Subprograms_For_Type (S);
+ if Present (Subps) then
+ Subp_Elmt := First_Elmt (Subps);
+ while Present (Subp_Elmt) loop
+ Subp_Id := Node (Subp_Elmt);
+
+ if Is_Invariant_Procedure (Subp_Id) then
+ return Subp_Id;
end if;
- end loop;
- return Empty;
+ Next_Elmt (Subp_Elmt);
+ end loop;
end if;
+
+ return Empty;
end Invariant_Procedure;
----------------------
@@ -7904,7 +8117,7 @@ package body Einfo is
when 1 .. 6 => return Uint_128;
when 7 .. 15 => return 2**10;
when 16 .. 33 => return 2**14;
- when others => return No_Uint;
+ when others => return No_Uint;
end case;
when AAMP =>
@@ -7939,14 +8152,14 @@ package body Einfo is
when 7 .. 15 => return UI_From_Int (53);
when 16 .. 18 => return Uint_64;
when 19 .. 33 => return UI_From_Int (113);
- when others => return No_Uint;
+ when others => return No_Uint;
end case;
when AAMP =>
case Digs is
when 1 .. 6 => return Uint_24;
when 7 .. 9 => return UI_From_Int (40);
- when others => return No_Uint;
+ when others => return No_Uint;
end case;
end case;
end Machine_Mantissa_Value;
@@ -7958,7 +8171,9 @@ package body Einfo is
function Machine_Radix_Value (Id : E) return U is
begin
case Float_Rep (Id) is
- when IEEE_Binary | AAMP =>
+ when AAMP
+ | IEEE_Binary
+ =>
return Uint_2;
end case;
end Machine_Radix_Value;
@@ -8183,41 +8398,164 @@ package body Einfo is
return Ekind (Id);
end Parameter_Mode;
+ ---------------------------------
+ -- Partial_Invariant_Procedure --
+ ---------------------------------
+
+ function Partial_Invariant_Procedure (Id : E) return E is
+ Subp_Elmt : Elmt_Id;
+ Subp_Id : Entity_Id;
+ Subps : Elist_Id;
+
+ begin
+ pragma Assert (Is_Type (Id));
+
+ Subps := Subprograms_For_Type (Base_Type (Id));
+
+ if Present (Subps) then
+ Subp_Elmt := First_Elmt (Subps);
+ while Present (Subp_Elmt) loop
+ Subp_Id := Node (Subp_Elmt);
+
+ if Is_Partial_Invariant_Procedure (Subp_Id) then
+ return Subp_Id;
+ end if;
+
+ Next_Elmt (Subp_Elmt);
+ end loop;
+ end if;
+
+ return Empty;
+ end Partial_Invariant_Procedure;
+
+ -------------------------------------
+ -- Partial_Refinement_Constituents --
+ -------------------------------------
+
+ function Partial_Refinement_Constituents (Id : E) return L is
+ Constits : Elist_Id := No_Elist;
+
+ procedure Add_Usable_Constituents (Item : E);
+ -- Add global item Item and/or its constituents to list Constits when
+ -- they can be used in a global refinement within the current scope. The
+ -- criteria are:
+ -- 1) If Item is an abstract state with full refinement visible, add
+ -- its constituents.
+ -- 2) If Item is an abstract state with only partial refinement
+ -- visible, add both Item and its constituents.
+ -- 3) If Item is an abstract state without a visible refinement, add
+ -- it.
+ -- 4) If Id is not an abstract state, add it.
+
+ procedure Add_Usable_Constituents (List : Elist_Id);
+ -- Apply Add_Usable_Constituents to every constituent in List
+
+ -----------------------------
+ -- Add_Usable_Constituents --
+ -----------------------------
+
+ procedure Add_Usable_Constituents (Item : E) is
+ begin
+ if Ekind (Item) = E_Abstract_State then
+ if Has_Visible_Refinement (Item) then
+ Add_Usable_Constituents (Refinement_Constituents (Item));
+
+ elsif Has_Partial_Visible_Refinement (Item) then
+ Append_New_Elmt (Item, Constits);
+ Add_Usable_Constituents (Part_Of_Constituents (Item));
+
+ else
+ Append_New_Elmt (Item, Constits);
+ end if;
+
+ else
+ Append_New_Elmt (Item, Constits);
+ end if;
+ end Add_Usable_Constituents;
+
+ procedure Add_Usable_Constituents (List : Elist_Id) is
+ Constit_Elmt : Elmt_Id;
+ begin
+ if Present (List) then
+ Constit_Elmt := First_Elmt (List);
+ while Present (Constit_Elmt) loop
+ Add_Usable_Constituents (Node (Constit_Elmt));
+ Next_Elmt (Constit_Elmt);
+ end loop;
+ end if;
+ end Add_Usable_Constituents;
+
+ -- Start of processing for Partial_Refinement_Constituents
+
+ begin
+ -- "Refinement" is a concept applicable only to abstract states
+
+ pragma Assert (Ekind (Id) = E_Abstract_State);
+
+ if Has_Visible_Refinement (Id) then
+ Constits := Refinement_Constituents (Id);
+
+ -- A refinement may be partially visible when objects declared in the
+ -- private part of a package are subject to a Part_Of indicator.
+
+ elsif Has_Partial_Visible_Refinement (Id) then
+ Add_Usable_Constituents (Part_Of_Constituents (Id));
+
+ -- Function should only be called when full or partial refinement is
+ -- visible.
+
+ else
+ raise Program_Error;
+ end if;
+
+ return Constits;
+ end Partial_Refinement_Constituents;
+
------------------------
-- Predicate_Function --
------------------------
function Predicate_Function (Id : E) return E is
- S : Entity_Id;
- T : Entity_Id;
+ Subp_Elmt : Elmt_Id;
+ Subp_Id : Entity_Id;
+ Subps : Elist_Id;
+ Typ : Entity_Id;
begin
pragma Assert (Is_Type (Id));
- -- If type is private and has a completion, predicate may be defined
- -- on the full view.
+ -- If type is private and has a completion, predicate may be defined on
+ -- the full view.
+
+ if Is_Private_Type (Id)
+ and then
+ (not Has_Predicates (Id) or else No (Subprograms_For_Type (Id)))
+ and then Present (Full_View (Id))
+ then
+ Typ := Full_View (Id);
- if Is_Private_Type (Id) and then Present (Full_View (Id)) then
- T := Full_View (Id);
else
- T := Id;
+ Typ := Id;
end if;
- if No (Subprograms_For_Type (T)) then
- return Empty;
+ Subps := Subprograms_For_Type (Typ);
- else
- S := Subprograms_For_Type (T);
- while Present (S) loop
- if Is_Predicate_Function (S) then
- return S;
- else
- S := Subprograms_For_Type (S);
+ if Present (Subps) then
+ Subp_Elmt := First_Elmt (Subps);
+ while Present (Subp_Elmt) loop
+ Subp_Id := Node (Subp_Elmt);
+
+ if Ekind (Subp_Id) = E_Function
+ and then Is_Predicate_Function (Subp_Id)
+ then
+ return Subp_Id;
end if;
- end loop;
- return Empty;
+ Next_Elmt (Subp_Elmt);
+ end loop;
end if;
+
+ return Empty;
end Predicate_Function;
--------------------------
@@ -8225,36 +8563,46 @@ package body Einfo is
--------------------------
function Predicate_Function_M (Id : E) return E is
- S : Entity_Id;
- T : Entity_Id;
+ Subp_Elmt : Elmt_Id;
+ Subp_Id : Entity_Id;
+ Subps : Elist_Id;
+ Typ : Entity_Id;
begin
pragma Assert (Is_Type (Id));
- -- If type is private and has a completion, predicate may be defined
- -- on the full view.
+ -- If type is private and has a completion, predicate may be defined on
+ -- the full view.
+
+ if Is_Private_Type (Id)
+ and then
+ (not Has_Predicates (Id) or else No (Subprograms_For_Type (Id)))
+ and then Present (Full_View (Id))
+ then
+ Typ := Full_View (Id);
- if Is_Private_Type (Id) and then Present (Full_View (Id)) then
- T := Full_View (Id);
else
- T := Id;
+ Typ := Id;
end if;
- if No (Subprograms_For_Type (T)) then
- return Empty;
+ Subps := Subprograms_For_Type (Typ);
- else
- S := Subprograms_For_Type (T);
- while Present (S) loop
- if Is_Predicate_Function_M (S) then
- return S;
- else
- S := Subprograms_For_Type (S);
+ if Present (Subps) then
+ Subp_Elmt := First_Elmt (Subps);
+ while Present (Subp_Elmt) loop
+ Subp_Id := Node (Subp_Elmt);
+
+ if Ekind (Subp_Id) = E_Function
+ and then Is_Predicate_Function_M (Subp_Id)
+ then
+ return Subp_Id;
end if;
- end loop;
- return Empty;
+ Next_Elmt (Subp_Elmt);
+ end loop;
end if;
+
+ return Empty;
end Predicate_Function_M;
-------------------------
@@ -8457,11 +8805,11 @@ package body Einfo is
and then Is_Base_Type (Id));
case V is
- when Calign_Default =>
+ when Calign_Default =>
Set_Flag128 (Id, False);
Set_Flag129 (Id, False);
- when Calign_Component_Size =>
+ when Calign_Component_Size =>
Set_Flag128 (Id, False);
Set_Flag129 (Id, True);
@@ -8469,87 +8817,157 @@ package body Einfo is
Set_Flag128 (Id, True);
Set_Flag129 (Id, False);
- when Calign_Storage_Unit =>
+ when Calign_Storage_Unit =>
Set_Flag128 (Id, True);
Set_Flag129 (Id, True);
end case;
end Set_Component_Alignment;
- -------------------------------------
- -- Set_Default_Init_Cond_Procedure --
- -------------------------------------
+ -----------------------
+ -- Set_DIC_Procedure --
+ -----------------------
- procedure Set_Default_Init_Cond_Procedure (Id : E; V : E) is
- Base_Typ : Entity_Id;
- Subp_Id : Entity_Id;
+ procedure Set_DIC_Procedure (Id : E; V : E) is
+ Base_Typ : Entity_Id;
+ Subp_Elmt : Elmt_Id;
+ Subp_Id : Entity_Id;
+ Subps : Elist_Id;
begin
- pragma Assert
- (Is_Type (Id)
- and then (Has_Default_Init_Cond (Id)
- or Has_Inherited_Default_Init_Cond (Id)));
+ pragma Assert (Is_Type (Id));
+
Base_Typ := Base_Type (Id);
+ Subps := Subprograms_For_Type (Base_Typ);
- Subp_Id := Subprograms_For_Type (Base_Typ);
- Set_Subprograms_For_Type (Base_Typ, V);
- Set_Subprograms_For_Type (V, Subp_Id);
+ if No (Subps) then
+ Subps := New_Elmt_List;
+ Set_Subprograms_For_Type (Base_Typ, Subps);
+ end if;
- -- Check for a duplicate procedure
+ Subp_Elmt := First_Elmt (Subps);
+ Prepend_Elmt (V, Subps);
- while Present (Subp_Id) loop
- if Is_Default_Init_Cond_Procedure (Subp_Id) then
+ -- Check for a duplicate default initial condition procedure
+
+ while Present (Subp_Elmt) loop
+ Subp_Id := Node (Subp_Elmt);
+
+ if Is_DIC_Procedure (Subp_Id) then
raise Program_Error;
end if;
- Subp_Id := Subprograms_For_Type (Subp_Id);
+ Next_Elmt (Subp_Elmt);
end loop;
- end Set_Default_Init_Cond_Procedure;
+ end Set_DIC_Procedure;
-----------------------------
-- Set_Invariant_Procedure --
-----------------------------
procedure Set_Invariant_Procedure (Id : E; V : E) is
- S : Entity_Id;
+ Base_Typ : Entity_Id;
+ Subp_Elmt : Elmt_Id;
+ Subp_Id : Entity_Id;
+ Subps : Elist_Id;
begin
- pragma Assert (Is_Type (Id) and then Has_Invariants (Id));
+ pragma Assert (Is_Type (Id));
+
+ Base_Typ := Base_Type (Id);
+ Subps := Subprograms_For_Type (Base_Typ);
+
+ if No (Subps) then
+ Subps := New_Elmt_List;
+ Set_Subprograms_For_Type (Base_Typ, Subps);
+ end if;
- S := Subprograms_For_Type (Id);
- Set_Subprograms_For_Type (Id, V);
- Set_Subprograms_For_Type (V, S);
+ Subp_Elmt := First_Elmt (Subps);
+ Prepend_Elmt (V, Subps);
- -- Check for duplicate entry
+ -- Check for a duplicate invariant procedure
- while Present (S) loop
- if Is_Invariant_Procedure (S) then
+ while Present (Subp_Elmt) loop
+ Subp_Id := Node (Subp_Elmt);
+
+ if Is_Invariant_Procedure (Subp_Id) then
raise Program_Error;
- else
- S := Subprograms_For_Type (S);
end if;
+
+ Next_Elmt (Subp_Elmt);
end loop;
end Set_Invariant_Procedure;
+ -------------------------------------
+ -- Set_Partial_Invariant_Procedure --
+ -------------------------------------
+
+ procedure Set_Partial_Invariant_Procedure (Id : E; V : E) is
+ Base_Typ : Entity_Id;
+ Subp_Elmt : Elmt_Id;
+ Subp_Id : Entity_Id;
+ Subps : Elist_Id;
+
+ begin
+ pragma Assert (Is_Type (Id));
+
+ Base_Typ := Base_Type (Id);
+ Subps := Subprograms_For_Type (Base_Typ);
+
+ if No (Subps) then
+ Subps := New_Elmt_List;
+ Set_Subprograms_For_Type (Base_Typ, Subps);
+ end if;
+
+ Subp_Elmt := First_Elmt (Subps);
+ Prepend_Elmt (V, Subps);
+
+ -- Check for a duplicate partial invariant procedure
+
+ while Present (Subp_Elmt) loop
+ Subp_Id := Node (Subp_Elmt);
+
+ if Is_Partial_Invariant_Procedure (Subp_Id) then
+ raise Program_Error;
+ end if;
+
+ Next_Elmt (Subp_Elmt);
+ end loop;
+ end Set_Partial_Invariant_Procedure;
+
----------------------------
-- Set_Predicate_Function --
----------------------------
procedure Set_Predicate_Function (Id : E; V : E) is
- S : Entity_Id;
+ Subp_Elmt : Elmt_Id;
+ Subp_Id : Entity_Id;
+ Subps : Elist_Id;
begin
pragma Assert (Is_Type (Id) and then Has_Predicates (Id));
- S := Subprograms_For_Type (Id);
- Set_Subprograms_For_Type (Id, V);
- Set_Subprograms_For_Type (V, S);
+ Subps := Subprograms_For_Type (Id);
+
+ if No (Subps) then
+ Subps := New_Elmt_List;
+ Set_Subprograms_For_Type (Id, Subps);
+ end if;
+
+ Subp_Elmt := First_Elmt (Subps);
+ Prepend_Elmt (V, Subps);
- while Present (S) loop
- if Is_Predicate_Function (S) then
+ -- Check for a duplicate predication function
+
+ while Present (Subp_Elmt) loop
+ Subp_Id := Node (Subp_Elmt);
+
+ if Ekind (Subp_Id) = E_Function
+ and then Is_Predicate_Function (Subp_Id)
+ then
raise Program_Error;
- else
- S := Subprograms_For_Type (S);
end if;
+
+ Next_Elmt (Subp_Elmt);
end loop;
end Set_Predicate_Function;
@@ -8558,23 +8976,35 @@ package body Einfo is
------------------------------
procedure Set_Predicate_Function_M (Id : E; V : E) is
- S : Entity_Id;
+ Subp_Elmt : Elmt_Id;
+ Subp_Id : Entity_Id;
+ Subps : Elist_Id;
begin
pragma Assert (Is_Type (Id) and then Has_Predicates (Id));
- S := Subprograms_For_Type (Id);
- Set_Subprograms_For_Type (Id, V);
- Set_Subprograms_For_Type (V, S);
+ Subps := Subprograms_For_Type (Id);
+
+ if No (Subps) then
+ Subps := New_Elmt_List;
+ Set_Subprograms_For_Type (Id, Subps);
+ end if;
- -- Check for duplicates
+ Subp_Elmt := First_Elmt (Subps);
+ Prepend_Elmt (V, Subps);
- while Present (S) loop
- if Is_Predicate_Function_M (S) then
+ -- Check for a duplicate predication function
+
+ while Present (Subp_Elmt) loop
+ Subp_Id := Node (Subp_Elmt);
+
+ if Ekind (Subp_Id) = E_Function
+ and then Is_Predicate_Function_M (Subp_Id)
+ then
raise Program_Error;
- else
- S := Subprograms_For_Type (S);
end if;
+
+ Next_Elmt (Subp_Elmt);
end loop;
end Set_Predicate_Function_M;
@@ -8605,60 +9035,68 @@ package body Einfo is
begin
case K is
- when Access_Kind =>
+ when Access_Kind =>
Kind := E_Access_Subtype;
- when E_Array_Type |
- E_Array_Subtype =>
+ when E_Array_Subtype
+ | E_Array_Type
+ =>
Kind := E_Array_Subtype;
- when E_Class_Wide_Type |
- E_Class_Wide_Subtype =>
+ when E_Class_Wide_Subtype
+ | E_Class_Wide_Type
+ =>
Kind := E_Class_Wide_Subtype;
- when E_Decimal_Fixed_Point_Type |
- E_Decimal_Fixed_Point_Subtype =>
+ when E_Decimal_Fixed_Point_Subtype
+ | E_Decimal_Fixed_Point_Type
+ =>
Kind := E_Decimal_Fixed_Point_Subtype;
- when E_Ordinary_Fixed_Point_Type |
- E_Ordinary_Fixed_Point_Subtype =>
+ when E_Ordinary_Fixed_Point_Subtype
+ | E_Ordinary_Fixed_Point_Type
+ =>
Kind := E_Ordinary_Fixed_Point_Subtype;
- when E_Private_Type |
- E_Private_Subtype =>
+ when E_Private_Subtype
+ | E_Private_Type
+ =>
Kind := E_Private_Subtype;
- when E_Limited_Private_Type |
- E_Limited_Private_Subtype =>
+ when E_Limited_Private_Subtype
+ | E_Limited_Private_Type
+ =>
Kind := E_Limited_Private_Subtype;
- when E_Record_Type_With_Private |
- E_Record_Subtype_With_Private =>
+ when E_Record_Subtype_With_Private
+ | E_Record_Type_With_Private
+ =>
Kind := E_Record_Subtype_With_Private;
- when E_Record_Type |
- E_Record_Subtype =>
+ when E_Record_Subtype
+ | E_Record_Type
+ =>
Kind := E_Record_Subtype;
- when Enumeration_Kind =>
+ when Enumeration_Kind =>
Kind := E_Enumeration_Subtype;
- when Float_Kind =>
+ when Float_Kind =>
Kind := E_Floating_Point_Subtype;
- when Signed_Integer_Kind =>
+ when Signed_Integer_Kind =>
Kind := E_Signed_Integer_Subtype;
- when Modular_Integer_Kind =>
+ when Modular_Integer_Kind =>
Kind := E_Modular_Integer_Subtype;
- when Protected_Kind =>
+ when Protected_Kind =>
Kind := E_Protected_Subtype;
- when Task_Kind =>
+ when Task_Kind =>
Kind := E_Task_Subtype;
- when others =>
+ when others =>
Kind := E_Void;
raise Program_Error;
end case;
@@ -8844,7 +9282,6 @@ package body Einfo is
W ("Has_Controlling_Result", Flag98 (Id));
W ("Has_Convention_Pragma", Flag119 (Id));
W ("Has_Default_Aspect", Flag39 (Id));
- W ("Has_Default_Init_Cond", Flag3 (Id));
W ("Has_Delayed_Aspects", Flag200 (Id));
W ("Has_Delayed_Freeze", Flag18 (Id));
W ("Has_Delayed_Rep_Aspects", Flag261 (Id));
@@ -8861,9 +9298,9 @@ package body Einfo is
W ("Has_Implicit_Dereference", Flag251 (Id));
W ("Has_Independent_Components", Flag34 (Id));
W ("Has_Inheritable_Invariants", Flag248 (Id));
- W ("Has_Inherited_Default_Init_Cond", Flag133 (Id));
+ W ("Has_Inherited_DIC", Flag133 (Id));
+ W ("Has_Inherited_Invariants", Flag291 (Id));
W ("Has_Initial_Value", Flag219 (Id));
- W ("Has_Invariants", Flag232 (Id));
W ("Has_Loop_Entry_Attributes", Flag260 (Id));
W ("Has_Machine_Radix_Clause", Flag83 (Id));
W ("Has_Master_Entity", Flag21 (Id));
@@ -8873,6 +9310,8 @@ package body Einfo is
W ("Has_Non_Standard_Rep", Flag75 (Id));
W ("Has_Out_Or_In_Out_Parameter", Flag110 (Id));
W ("Has_Object_Size_Clause", Flag172 (Id));
+ W ("Has_Own_DIC", Flag3 (Id));
+ W ("Has_Own_Invariants", Flag232 (Id));
W ("Has_Per_Object_Constraint", Flag154 (Id));
W ("Has_Pragma_Controlled", Flag27 (Id));
W ("Has_Pragma_Elaborate_Body", Flag150 (Id));
@@ -8888,6 +9327,7 @@ package body Einfo is
W ("Has_Pragma_Unmodified", Flag233 (Id));
W ("Has_Pragma_Unreferenced", Flag180 (Id));
W ("Has_Pragma_Unreferenced_Objects", Flag212 (Id));
+ W ("Has_Pragma_Unused", Flag294 (Id));
W ("Has_Predicates", Flag250 (Id));
W ("Has_Primitive_Operations", Flag120 (Id));
W ("Has_Private_Ancestor", Flag151 (Id));
@@ -8911,6 +9351,7 @@ package body Einfo is
W ("Has_Storage_Size_Clause", Flag23 (Id));
W ("Has_Stream_Size_Clause", Flag184 (Id));
W ("Has_Task", Flag30 (Id));
+ W ("Has_Timing_Event", Flag289 (Id));
W ("Has_Thunks", Flag228 (Id));
W ("Has_Unchecked_Union", Flag123 (Id));
W ("Has_Unknown_Discriminants", Flag72 (Id));
@@ -8923,6 +9364,7 @@ package body Einfo is
W ("Is_Abstract_Subprogram", Flag19 (Id));
W ("Is_Abstract_Type", Flag146 (Id));
W ("Is_Access_Constant", Flag69 (Id));
+ W ("Is_Actual_Subtype", Flag293 (Id));
W ("Is_Ada_2005_Only", Flag185 (Id));
W ("Is_Ada_2012_Only", Flag199 (Id));
W ("Is_Aliased", Flag15 (Id));
@@ -8944,15 +9386,17 @@ package body Einfo is
W ("Is_Constructor", Flag76 (Id));
W ("Is_Controlled", Flag42 (Id));
W ("Is_Controlling_Formal", Flag97 (Id));
- W ("Is_Default_Init_Cond_Procedure", Flag132 (Id));
- W ("Is_Descendent_Of_Address", Flag223 (Id));
+ W ("Is_Descendant_Of_Address", Flag223 (Id));
+ W ("Is_DIC_Procedure", Flag132 (Id));
W ("Is_Discrim_SO_Function", Flag176 (Id));
W ("Is_Discriminant_Check_Function", Flag264 (Id));
W ("Is_Dispatch_Table_Entity", Flag234 (Id));
W ("Is_Dispatching_Operation", Flag6 (Id));
W ("Is_Eliminated", Flag124 (Id));
W ("Is_Entry_Formal", Flag52 (Id));
+ W ("Is_Exception_Handler", Flag286 (Id));
W ("Is_Exported", Flag99 (Id));
+ W ("Is_Finalized_Transient", Flag252 (Id));
W ("Is_First_Subtype", Flag70 (Id));
W ("Is_For_Access_Subtype", Flag118 (Id));
W ("Is_Formal_Subprogram", Flag111 (Id));
@@ -8965,6 +9409,7 @@ package body Einfo is
W ("Is_Hidden_Non_Overridden_Subpgm", Flag2 (Id));
W ("Is_Hidden_Open_Scope", Flag171 (Id));
W ("Is_Ignored_Ghost_Entity", Flag278 (Id));
+ W ("Is_Ignored_Transient", Flag295 (Id));
W ("Is_Immediately_Visible", Flag7 (Id));
W ("Is_Implementation_Defined", Flag254 (Id));
W ("Is_Imported", Flag24 (Id));
@@ -8994,6 +9439,7 @@ package body Einfo is
W ("Is_Packed", Flag51 (Id));
W ("Is_Packed_Array_Impl_Type", Flag138 (Id));
W ("Is_Param_Block_Component_Type", Flag215 (Id));
+ W ("Is_Partial_Invariant_Procedure", Flag292 (Id));
W ("Is_Potentially_Use_Visible", Flag9 (Id));
W ("Is_Predicate_Function", Flag255 (Id));
W ("Is_Predicate_Function_M", Flag256 (Id));
@@ -9003,7 +9449,6 @@ package body Einfo is
W ("Is_Private_Composite", Flag107 (Id));
W ("Is_Private_Descendant", Flag53 (Id));
W ("Is_Private_Primitive", Flag245 (Id));
- W ("Is_Processed_Transient", Flag252 (Id));
W ("Is_Public", Flag10 (Id));
W ("Is_Pure", Flag44 (Id));
W ("Is_Pure_Unit_Access_Type", Flag189 (Id));
@@ -9023,6 +9468,7 @@ package body Einfo is
W ("Is_Trivial_Subprogram", Flag235 (Id));
W ("Is_True_Constant", Flag163 (Id));
W ("Is_Unchecked_Union", Flag117 (Id));
+ W ("Is_Underlying_Full_View", Flag298 (Id));
W ("Is_Underlying_Record_View", Flag246 (Id));
W ("Is_Unimplemented", Flag284 (Id));
W ("Is_Unsigned_Type", Flag144 (Id));
@@ -9066,10 +9512,10 @@ package body Einfo is
W ("Requires_Overriding", Flag213 (Id));
W ("Return_Present", Flag54 (Id));
W ("Returns_By_Ref", Flag90 (Id));
- W ("Returns_Limited_View", Flag134 (Id));
W ("Reverse_Bit_Order", Flag164 (Id));
W ("Reverse_Storage_Order", Flag93 (Id));
W ("Rewritten_For_C", Flag287 (Id));
+ W ("Predicates_Ignored", Flag288 (Id));
W ("Sec_Stack_Needed_For_Return", Flag167 (Id));
W ("Size_Depends_On_Discriminant", Flag177 (Id));
W ("Size_Known_At_Compile_Time", Flag92 (Id));
@@ -9159,7 +9605,6 @@ package body Einfo is
Write_Eol;
case Ekind (Id) is
-
when Discrete_Kind =>
Write_Str ("Bounds: Id = ");
@@ -9219,7 +9664,8 @@ package body Einfo is
Write_Eol;
end if;
- when others => null;
+ when others =>
+ null;
end case;
end Write_Entity_Info;
@@ -9250,34 +9696,36 @@ package body Einfo is
procedure Write_Field8_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when Type_Kind =>
+ when Type_Kind =>
Write_Str ("Associated_Node_For_Itype");
- when E_Package =>
+ when E_Package =>
Write_Str ("Dependent_Instances");
- when E_Loop =>
+ when E_Loop =>
Write_Str ("First_Exit_Statement");
- when E_Variable =>
+ when E_Variable =>
Write_Str ("Hiding_Loop_Variable");
- when Formal_Kind |
- E_Function |
- E_Subprogram_Body =>
+ when Formal_Kind
+ | E_Function
+ | E_Subprogram_Body
+ =>
Write_Str ("Mechanism");
- when E_Component |
- E_Discriminant =>
+ when E_Component
+ | E_Discriminant
+ =>
Write_Str ("Normalized_First_Bit");
- when E_Abstract_State =>
+ when E_Abstract_State =>
Write_Str ("Refinement_Constituents");
- when E_Return_Statement =>
+ when E_Return_Statement =>
Write_Str ("Return_Applies_To");
- when others =>
+ when others =>
Write_Str ("Field8??");
end case;
end Write_Field8_Name;
@@ -9289,21 +9737,22 @@ package body Einfo is
procedure Write_Field9_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when Type_Kind =>
+ when Type_Kind =>
Write_Str ("Class_Wide_Type");
- when Object_Kind =>
+ when Object_Kind =>
Write_Str ("Current_Value");
- when E_Function |
- E_Generic_Function |
- E_Generic_Package |
- E_Generic_Procedure |
- E_Package |
- E_Procedure =>
+ when E_Function
+ | E_Generic_Function
+ | E_Generic_Package
+ | E_Generic_Procedure
+ | E_Package
+ | E_Procedure
+ =>
Write_Str ("Renaming_Map");
- when others =>
+ when others =>
Write_Str ("Field9??");
end case;
end Write_Field9_Name;
@@ -9315,36 +9764,41 @@ package body Einfo is
procedure Write_Field10_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when Class_Wide_Kind |
- Incomplete_Kind |
- E_Record_Type |
- E_Record_Subtype |
- Private_Kind |
- Concurrent_Kind =>
+ when Class_Wide_Kind
+ | Incomplete_Kind
+ | E_Record_Type
+ | E_Record_Subtype
+ | Private_Kind
+ | Concurrent_Kind
+ =>
Write_Str ("Direct_Primitive_Operations");
- when E_In_Parameter |
- E_Constant =>
+ when E_Constant
+ | E_In_Parameter
+ =>
Write_Str ("Discriminal_Link");
- when Float_Kind =>
+ when Float_Kind =>
Write_Str ("Float_Rep");
- when E_Function |
- E_Package |
- E_Package_Body |
- E_Procedure =>
+ when E_Function
+ | E_Package
+ | E_Package_Body
+ | E_Procedure
+ =>
Write_Str ("Handler_Records");
- when E_Component |
- E_Discriminant =>
+ when E_Component
+ | E_Discriminant
+ =>
Write_Str ("Normalized_Position_Max");
- when E_Abstract_State |
- E_Variable =>
+ when E_Abstract_State
+ | E_Variable
+ =>
Write_Str ("Part_Of_Constituents");
- when others =>
+ when others =>
Write_Str ("Field10??");
end case;
end Write_Field10_Name;
@@ -9356,36 +9810,39 @@ package body Einfo is
procedure Write_Field11_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when E_Block =>
+ when E_Block =>
Write_Str ("Block_Node");
- when E_Component |
- E_Discriminant =>
+ when E_Component
+ | E_Discriminant
+ =>
Write_Str ("Component_Bit_Offset");
- when Formal_Kind =>
+ when Formal_Kind =>
Write_Str ("Entry_Component");
- when E_Enumeration_Literal =>
+ when E_Enumeration_Literal =>
Write_Str ("Enumeration_Pos");
- when Type_Kind |
- E_Constant =>
+ when Type_Kind
+ | E_Constant
+ =>
Write_Str ("Full_View");
- when E_Generic_Package =>
+ when E_Generic_Package =>
Write_Str ("Generic_Homonym");
- when E_Variable =>
+ when E_Variable =>
Write_Str ("Part_Of_References");
- when E_Entry |
- E_Entry_Family |
- E_Function |
- E_Procedure =>
+ when E_Entry
+ | E_Entry_Family
+ | E_Function
+ | E_Procedure
+ =>
Write_Str ("Protected_Body_Subprogram");
- when others =>
+ when others =>
Write_Str ("Field11??");
end case;
end Write_Field11_Name;
@@ -9397,32 +9854,34 @@ package body Einfo is
procedure Write_Field12_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when E_Package =>
+ when E_Package =>
Write_Str ("Associated_Formal_Package");
- when Entry_Kind =>
+ when Entry_Kind =>
Write_Str ("Barrier_Function");
- when E_Enumeration_Literal =>
+ when E_Enumeration_Literal =>
Write_Str ("Enumeration_Rep");
- when Type_Kind |
- E_Component |
- E_Constant |
- E_Discriminant |
- E_Exception |
- E_In_Parameter |
- E_In_Out_Parameter |
- E_Out_Parameter |
- E_Loop_Parameter |
- E_Variable =>
+ when Type_Kind
+ | E_Component
+ | E_Constant
+ | E_Discriminant
+ | E_Exception
+ | E_In_Parameter
+ | E_In_Out_Parameter
+ | E_Out_Parameter
+ | E_Loop_Parameter
+ | E_Variable
+ =>
Write_Str ("Esize");
- when E_Function |
- E_Procedure =>
+ when E_Function
+ | E_Procedure
+ =>
Write_Str ("Next_Inlined_Subprogram");
- when others =>
+ when others =>
Write_Str ("Field12??");
end case;
end Write_Field12_Name;
@@ -9434,26 +9893,27 @@ package body Einfo is
procedure Write_Field13_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when E_Component |
- E_Discriminant =>
+ when E_Component
+ | E_Discriminant
+ =>
Write_Str ("Component_Clause");
- when E_Function =>
- Write_Str ("Elaboration_Entity");
-
- when E_Procedure |
- E_Package |
- Generic_Unit_Kind =>
+ when E_Function
+ | E_Procedure
+ | E_Package
+ | Generic_Unit_Kind
+ =>
Write_Str ("Elaboration_Entity");
- when Formal_Kind |
- E_Variable =>
+ when Formal_Kind
+ | E_Variable
+ =>
Write_Str ("Extra_Accessibility");
- when Type_Kind =>
+ when Type_Kind =>
Write_Str ("RM_Size");
- when others =>
+ when others =>
Write_Str ("Field13??");
end case;
end Write_Field13_Name;
@@ -9465,29 +9925,33 @@ package body Einfo is
procedure Write_Field14_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when Type_Kind |
- Formal_Kind |
- E_Constant |
- E_Exception |
- E_Loop_Parameter |
- E_Variable =>
+ when Type_Kind
+ | Formal_Kind
+ | E_Constant
+ | E_Exception
+ | E_Loop_Parameter
+ | E_Variable
+ =>
Write_Str ("Alignment");
- when E_Component |
- E_Discriminant =>
+ when E_Component
+ | E_Discriminant
+ =>
Write_Str ("Normalized_Position");
- when E_Entry |
- E_Entry_Family |
- E_Function |
- E_Procedure =>
+ when E_Entry
+ | E_Entry_Family
+ | E_Function
+ | E_Procedure
+ =>
Write_Str ("Postconditions_Proc");
- when E_Generic_Package |
- E_Package =>
+ when E_Generic_Package
+ | E_Package
+ =>
Write_Str ("Shadow_Entities");
- when others =>
+ when others =>
Write_Str ("Field14??");
end case;
end Write_Field14_Name;
@@ -9499,34 +9963,37 @@ package body Einfo is
procedure Write_Field15_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when E_Discriminant =>
+ when E_Discriminant =>
Write_Str ("Discriminant_Number");
- when E_Component =>
+ when E_Component =>
Write_Str ("DT_Entry_Count");
- when E_Function |
- E_Procedure =>
+ when E_Function
+ | E_Procedure
+ =>
Write_Str ("DT_Position");
- when Entry_Kind =>
+ when Entry_Kind =>
Write_Str ("Entry_Parameters_Type");
- when Formal_Kind =>
+ when Formal_Kind =>
Write_Str ("Extra_Formal");
- when Type_Kind =>
+ when Type_Kind =>
Write_Str ("Pending_Access_Types");
- when E_Package |
- E_Package_Body =>
+ when E_Package
+ | E_Package_Body
+ =>
Write_Str ("Related_Instance");
- when E_Constant |
- E_Variable =>
+ when E_Constant
+ | E_Variable
+ =>
Write_Str ("Status_Flag_Or_Transient_Decl");
- when others =>
+ when others =>
Write_Str ("Field15??");
end case;
end Write_Field15_Name;
@@ -9538,43 +10005,48 @@ package body Einfo is
procedure Write_Field16_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when E_Record_Type |
- E_Record_Type_With_Private =>
+ when E_Record_Type
+ | E_Record_Type_With_Private
+ =>
Write_Str ("Access_Disp_Table");
- when E_Abstract_State =>
+ when E_Abstract_State =>
Write_Str ("Body_References");
- when E_Record_Subtype |
- E_Class_Wide_Subtype =>
+ when E_Class_Wide_Subtype
+ | E_Record_Subtype
+ =>
Write_Str ("Cloned_Subtype");
- when E_Function |
- E_Procedure =>
+ when E_Function
+ | E_Procedure
+ =>
Write_Str ("DTC_Entity");
- when E_Component =>
+ when E_Component =>
Write_Str ("Entry_Formal");
- when E_Package |
- E_Generic_Package |
- Concurrent_Kind =>
+ when Concurrent_Kind
+ | E_Generic_Package
+ | E_Package
+ =>
Write_Str ("First_Private_Entity");
- when Enumeration_Kind =>
+ when Enumeration_Kind =>
Write_Str ("Lit_Strings");
- when Decimal_Fixed_Point_Kind =>
+ when Decimal_Fixed_Point_Kind =>
Write_Str ("Scale_Value");
- when E_String_Literal_Subtype =>
+ when E_String_Literal_Subtype =>
Write_Str ("String_Literal_Length");
- when E_Variable |
- E_Out_Parameter =>
+ when E_Out_Parameter
+ | E_Variable
+ =>
Write_Str ("Unset_Reference");
- when others =>
+ when others =>
Write_Str ("Field16??");
end case;
end Write_Field16_Name;
@@ -9586,56 +10058,58 @@ package body Einfo is
procedure Write_Field17_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when Formal_Kind |
- E_Constant |
- E_Generic_In_Out_Parameter |
- E_Variable =>
+ when Formal_Kind
+ | E_Constant
+ | E_Generic_In_Out_Parameter
+ | E_Variable
+ =>
Write_Str ("Actual_Subtype");
- when Digits_Kind =>
+ when Digits_Kind =>
Write_Str ("Digits_Value");
- when E_Discriminant =>
+ when E_Discriminant =>
Write_Str ("Discriminal");
- when E_Block |
- Class_Wide_Kind |
- Concurrent_Kind |
- Private_Kind |
- E_Entry |
- E_Entry_Family |
- E_Function |
- E_Generic_Function |
- E_Generic_Package |
- E_Generic_Procedure |
- E_Loop |
- E_Operator |
- E_Package |
- E_Package_Body |
- E_Procedure |
- E_Record_Type |
- E_Record_Subtype |
- E_Return_Statement |
- E_Subprogram_Body |
- E_Subprogram_Type =>
+ when Class_Wide_Kind
+ | Concurrent_Kind
+ | Private_Kind
+ | E_Block
+ | E_Entry
+ | E_Entry_Family
+ | E_Function
+ | E_Generic_Function
+ | E_Generic_Package
+ | E_Generic_Procedure
+ | E_Loop
+ | E_Operator
+ | E_Package
+ | E_Package_Body
+ | E_Procedure
+ | E_Record_Type
+ | E_Record_Subtype
+ | E_Return_Statement
+ | E_Subprogram_Body
+ | E_Subprogram_Type
+ =>
Write_Str ("First_Entity");
- when Array_Kind =>
+ when Array_Kind =>
Write_Str ("First_Index");
- when Enumeration_Kind =>
+ when Enumeration_Kind =>
Write_Str ("First_Literal");
- when Access_Kind =>
+ when Access_Kind =>
Write_Str ("Master_Id");
- when Modular_Integer_Kind =>
+ when Modular_Integer_Kind =>
Write_Str ("Modulus");
- when E_Component =>
+ when E_Component =>
Write_Str ("Prival");
- when others =>
+ when others =>
Write_Str ("Field17??");
end case;
end Write_Field17_Name;
@@ -9647,60 +10121,65 @@ package body Einfo is
procedure Write_Field18_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when E_Enumeration_Literal |
- E_Function |
- E_Operator |
- E_Procedure =>
+ when E_Enumeration_Literal
+ | E_Function
+ | E_Operator
+ | E_Procedure
+ =>
Write_Str ("Alias");
- when E_Record_Type =>
+ when E_Record_Type =>
Write_Str ("Corresponding_Concurrent_Type");
- when E_Subprogram_Body =>
+ when E_Subprogram_Body =>
Write_Str ("Corresponding_Protected_Entry");
- when Concurrent_Kind =>
+ when Concurrent_Kind =>
Write_Str ("Corresponding_Record_Type");
- when E_Label |
- E_Loop |
- E_Block =>
+ when E_Block
+ | E_Label
+ | E_Loop
+ =>
Write_Str ("Enclosing_Scope");
- when E_Entry_Index_Parameter =>
+ when E_Entry_Index_Parameter =>
Write_Str ("Entry_Index_Constant");
- when E_Class_Wide_Subtype |
- E_Access_Protected_Subprogram_Type |
- E_Anonymous_Access_Protected_Subprogram_Type |
- E_Access_Subprogram_Type |
- E_Exception_Type =>
+ when E_Access_Protected_Subprogram_Type
+ | E_Access_Subprogram_Type
+ | E_Anonymous_Access_Protected_Subprogram_Type
+ | E_Exception_Type
+ | E_Class_Wide_Subtype
+ =>
Write_Str ("Equivalent_Type");
- when Fixed_Point_Kind =>
+ when Fixed_Point_Kind =>
Write_Str ("Delta_Value");
- when Enumeration_Kind =>
+ when Enumeration_Kind =>
Write_Str ("Lit_Indexes");
- when Incomplete_Or_Private_Kind |
- E_Record_Subtype =>
+ when Incomplete_Or_Private_Kind
+ | E_Record_Subtype
+ =>
Write_Str ("Private_Dependents");
- when Object_Kind =>
- Write_Str ("Renamed_Object");
-
- when E_Exception |
- E_Package |
- E_Generic_Function |
- E_Generic_Procedure |
- E_Generic_Package =>
+ when E_Exception
+ | E_Generic_Function
+ | E_Generic_Package
+ | E_Generic_Procedure
+ | E_Package
+ =>
Write_Str ("Renamed_Entity");
- when E_String_Literal_Subtype =>
+ when Object_Kind =>
+ Write_Str ("Renamed_Object");
+
+ when E_String_Literal_Subtype =>
Write_Str ("String_Literal_Low_Bound");
- when others =>
+ when others =>
Write_Str ("Field18??");
end case;
end Write_Field18_Name;
@@ -9712,52 +10191,57 @@ package body Einfo is
procedure Write_Field19_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when E_Package |
- E_Generic_Package =>
+ when E_Generic_Package
+ | E_Package
+ =>
Write_Str ("Body_Entity");
- when E_Discriminant =>
+ when E_Discriminant =>
Write_Str ("Corresponding_Discriminant");
- when Scalar_Kind =>
+ when Scalar_Kind =>
Write_Str ("Default_Aspect_Value");
- when E_Abstract_State |
- E_Class_Wide_Type |
- E_Incomplete_Type =>
- Write_Str ("Non_Limited_View");
-
- when E_Incomplete_Subtype =>
- if From_Limited_With (Id) then
- Write_Str ("Non_Limited_View");
- end if;
-
- when E_Array_Type =>
+ when E_Array_Type =>
Write_Str ("Default_Component_Value");
- when E_Protected_Type =>
+ when E_Protected_Type =>
Write_Str ("Entry_Bodies_Array");
- when E_Function |
- E_Operator |
- E_Subprogram_Type =>
+ when E_Function
+ | E_Operator
+ | E_Subprogram_Type
+ =>
Write_Str ("Extra_Accessibility_Of_Result");
- when E_Record_Type =>
+ when E_Abstract_State
+ | E_Class_Wide_Type
+ | E_Incomplete_Type
+ =>
+ Write_Str ("Non_Limited_View");
+
+ when E_Incomplete_Subtype =>
+ if From_Limited_With (Id) then
+ Write_Str ("Non_Limited_View");
+ end if;
+
+ when E_Record_Type =>
Write_Str ("Parent_Subtype");
- when E_Constant |
- E_Variable =>
+ when E_Constant
+ | E_Variable
+ =>
Write_Str ("Size_Check_Code");
- when E_Package_Body |
- Formal_Kind =>
+ when Formal_Kind
+ | E_Package_Body
+ =>
Write_Str ("Spec_Entity");
- when Private_Kind =>
+ when Private_Kind =>
Write_Str ("Underlying_Full_View");
- when others =>
+ when others =>
Write_Str ("Field19??");
end case;
end Write_Field19_Name;
@@ -9769,55 +10253,58 @@ package body Einfo is
procedure Write_Field20_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when Array_Kind =>
+ when Array_Kind =>
Write_Str ("Component_Type");
- when E_In_Parameter |
- E_Generic_In_Parameter =>
+ when E_Generic_In_Parameter
+ | E_In_Parameter
+ =>
Write_Str ("Default_Value");
- when Access_Kind =>
+ when Access_Kind =>
Write_Str ("Directly_Designated_Type");
- when E_Component =>
+ when E_Component =>
Write_Str ("Discriminant_Checking_Func");
- when E_Discriminant =>
+ when E_Discriminant =>
Write_Str ("Discriminant_Default_Value");
- when E_Block |
- Class_Wide_Kind |
- Concurrent_Kind |
- Private_Kind |
- E_Entry |
- E_Entry_Family |
- E_Function |
- E_Generic_Function |
- E_Generic_Package |
- E_Generic_Procedure |
- E_Loop |
- E_Operator |
- E_Package |
- E_Package_Body |
- E_Procedure |
- E_Record_Type |
- E_Record_Subtype |
- E_Return_Statement |
- E_Subprogram_Body |
- E_Subprogram_Type =>
+ when Class_Wide_Kind
+ | Concurrent_Kind
+ | Private_Kind
+ | E_Block
+ | E_Entry
+ | E_Entry_Family
+ | E_Function
+ | E_Generic_Function
+ | E_Generic_Package
+ | E_Generic_Procedure
+ | E_Loop
+ | E_Operator
+ | E_Package
+ | E_Package_Body
+ | E_Procedure
+ | E_Record_Type
+ | E_Record_Subtype
+ | E_Return_Statement
+ | E_Subprogram_Body
+ | E_Subprogram_Type
+ =>
Write_Str ("Last_Entity");
- when E_Constant |
- E_Variable =>
+ when E_Constant
+ | E_Variable
+ =>
Write_Str ("Prival_Link");
- when Scalar_Kind =>
- Write_Str ("Scalar_Range");
-
- when E_Exception =>
+ when E_Exception =>
Write_Str ("Register_Exception_Call");
- when others =>
+ when Scalar_Kind =>
+ Write_Str ("Scalar_Range");
+
+ when others =>
Write_Str ("Field20??");
end case;
end Write_Field20_Name;
@@ -9829,36 +10316,39 @@ package body Einfo is
procedure Write_Field21_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when Entry_Kind =>
+ when Entry_Kind =>
Write_Str ("Accept_Address");
- when E_In_Parameter =>
+ when E_In_Parameter =>
Write_Str ("Default_Expr_Function");
- when Concurrent_Kind |
- Incomplete_Or_Private_Kind |
- Class_Wide_Kind |
- E_Record_Type |
- E_Record_Subtype =>
+ when Concurrent_Kind
+ | Incomplete_Or_Private_Kind
+ | Class_Wide_Kind
+ | E_Record_Type
+ | E_Record_Subtype
+ =>
Write_Str ("Discriminant_Constraint");
- when E_Constant |
- E_Exception |
- E_Function |
- E_Generic_Function |
- E_Procedure |
- E_Generic_Procedure |
- E_Variable =>
+ when E_Constant
+ | E_Exception
+ | E_Function
+ | E_Generic_Function
+ | E_Generic_Procedure
+ | E_Procedure
+ | E_Variable
+ =>
Write_Str ("Interface_Name");
- when Array_Kind |
- Modular_Integer_Kind =>
+ when Array_Kind
+ | Modular_Integer_Kind
+ =>
Write_Str ("Original_Array_Type");
- when Fixed_Point_Kind =>
+ when Fixed_Point_Kind =>
Write_Str ("Small_Value");
- when others =>
+ when others =>
Write_Str ("Field21??");
end case;
end Write_Field21_Name;
@@ -9870,54 +10360,57 @@ package body Einfo is
procedure Write_Field22_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when Access_Kind =>
+ when Access_Kind =>
Write_Str ("Associated_Storage_Pool");
- when Array_Kind =>
+ when Array_Kind =>
Write_Str ("Component_Size");
- when E_Record_Type =>
+ when E_Record_Type =>
Write_Str ("Corresponding_Remote_Type");
- when E_Component |
- E_Discriminant =>
+ when E_Component
+ | E_Discriminant
+ =>
Write_Str ("Original_Record_Component");
- when E_Enumeration_Literal =>
+ when E_Enumeration_Literal =>
Write_Str ("Enumeration_Rep_Expr");
- when E_Record_Type_With_Private |
- E_Record_Subtype_With_Private |
- E_Private_Type |
- E_Private_Subtype |
- E_Limited_Private_Type |
- E_Limited_Private_Subtype =>
+ when E_Limited_Private_Subtype
+ | E_Limited_Private_Type
+ | E_Private_Subtype
+ | E_Private_Type
+ | E_Record_Subtype_With_Private
+ | E_Record_Type_With_Private
+ =>
Write_Str ("Private_View");
- when Formal_Kind =>
+ when Formal_Kind =>
Write_Str ("Protected_Formal");
- when E_Block |
- E_Entry |
- E_Entry_Family |
- E_Function |
- E_Loop |
- E_Package |
- E_Package_Body |
- E_Generic_Package |
- E_Generic_Function |
- E_Generic_Procedure |
- E_Procedure |
- E_Protected_Type |
- E_Return_Statement |
- E_Subprogram_Body |
- E_Task_Type =>
+ when E_Block
+ | E_Entry
+ | E_Entry_Family
+ | E_Function
+ | E_Generic_Function
+ | E_Generic_Package
+ | E_Generic_Procedure
+ | E_Loop
+ | E_Package
+ | E_Package_Body
+ | E_Procedure
+ | E_Protected_Type
+ | E_Return_Statement
+ | E_Subprogram_Body
+ | E_Task_Type
+ =>
Write_Str ("Scope_Depth_Value");
- when E_Variable =>
+ when E_Variable =>
Write_Str ("Shared_Var_Procs_Instance");
- when others =>
+ when others =>
Write_Str ("Field22??");
end case;
end Write_Field22_Name;
@@ -9929,42 +10422,46 @@ package body Einfo is
procedure Write_Field23_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when E_Discriminant =>
+ when E_Discriminant =>
Write_Str ("CR_Discriminant");
- when E_Block =>
+ when E_Block =>
Write_Str ("Entry_Cancel_Parameter");
- when E_Enumeration_Type =>
+ when E_Enumeration_Type =>
Write_Str ("Enum_Pos_To_Rep");
- when Formal_Kind |
- E_Variable =>
+ when Formal_Kind
+ | E_Variable
+ =>
Write_Str ("Extra_Constrained");
- when Access_Kind =>
+ when Access_Kind =>
Write_Str ("Finalization_Master");
- when E_Generic_Function |
- E_Generic_Package |
- E_Generic_Procedure =>
+ when E_Generic_Function
+ | E_Generic_Package
+ | E_Generic_Procedure
+ =>
Write_Str ("Inner_Instances");
- when Array_Kind =>
+ when Array_Kind =>
Write_Str ("Packed_Array_Impl_Type");
- when Entry_Kind =>
+ when Entry_Kind =>
Write_Str ("Protection_Object");
- when Concurrent_Kind |
- Incomplete_Or_Private_Kind |
- Class_Wide_Kind |
- E_Record_Type |
- E_Record_Subtype =>
+ when Class_Wide_Kind
+ | Concurrent_Kind
+ | Incomplete_Or_Private_Kind
+ | E_Record_Type
+ | E_Record_Subtype
+ =>
Write_Str ("Stored_Constraint");
- when E_Function |
- E_Procedure =>
+ when E_Function
+ | E_Procedure
+ =>
if Present (Scope (Id))
and then Is_Protected_Type (Scope (Id))
then
@@ -9973,14 +10470,14 @@ package body Einfo is
Write_Str ("Generic_Renamings");
end if;
- when E_Package =>
+ when E_Package =>
if Is_Generic_Instance (Id) then
Write_Str ("Generic_Renamings");
else
Write_Str ("Limited_View");
end if;
- when others =>
+ when others =>
Write_Str ("Field23??");
end case;
end Write_Field23_Name;
@@ -9992,20 +10489,22 @@ package body Einfo is
procedure Write_Field24_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when E_Constant |
- E_Variable |
- Type_Kind =>
+ when Type_Kind
+ | E_Constant
+ | E_Variable
+ =>
Write_Str ("Related_Expression");
- when E_Function |
- E_Operator |
- E_Procedure =>
+ when E_Function
+ | E_Operator
+ | E_Procedure
+ =>
Write_Str ("Subps_Index");
- when E_Package =>
+ when E_Package =>
Write_Str ("Incomplete_Actuals");
- when others =>
+ when others =>
Write_Str ("Field24???");
end case;
end Write_Field24_Name;
@@ -10017,44 +10516,49 @@ package body Einfo is
procedure Write_Field25_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when E_Generic_Package |
- E_Package =>
+ when E_Generic_Package
+ | E_Package
+ =>
Write_Str ("Abstract_States");
- when E_Entry |
- E_Entry_Family =>
+ when E_Entry
+ | E_Entry_Family
+ =>
Write_Str ("Contract_Wrapper");
- when E_Variable =>
+ when E_Variable =>
Write_Str ("Debug_Renaming_Link");
- when E_Component =>
+ when E_Component =>
Write_Str ("DT_Offset_To_Top_Func");
- when E_Procedure |
- E_Function =>
+ when E_Function
+ | E_Procedure
+ =>
Write_Str ("Interface_Alias");
- when E_Record_Type |
- E_Record_Subtype |
- E_Record_Type_With_Private |
- E_Record_Subtype_With_Private =>
+ when E_Record_Subtype
+ | E_Record_Subtype_With_Private
+ | E_Record_Type
+ | E_Record_Type_With_Private
+ =>
Write_Str ("Interfaces");
- when E_Array_Type |
- E_Array_Subtype =>
+ when E_Array_Subtype
+ | E_Array_Type
+ =>
Write_Str ("Related_Array_Object");
- when Task_Kind =>
- Write_Str ("Task_Body_Procedure");
-
- when Discrete_Kind =>
+ when Discrete_Kind =>
Write_Str ("Static_Discrete_Predicate");
- when Real_Kind =>
+ when Real_Kind =>
Write_Str ("Static_Real_Or_String_Predicate");
- when others =>
+ when Task_Kind =>
+ Write_Str ("Task_Body_Procedure");
+
+ when others =>
Write_Str ("Field25??");
end case;
end Write_Field25_Name;
@@ -10066,32 +10570,38 @@ package body Einfo is
procedure Write_Field26_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when E_Record_Type |
- E_Record_Type_With_Private =>
+ when E_Record_Type
+ | E_Record_Type_With_Private
+ =>
Write_Str ("Dispatch_Table_Wrappers");
- when E_In_Out_Parameter |
- E_Out_Parameter |
- E_Variable =>
+ when E_In_Out_Parameter
+ | E_Out_Parameter
+ | E_Variable
+ =>
Write_Str ("Last_Assignment");
- when E_Procedure |
- E_Function =>
+ when E_Function
+ | E_Procedure
+ =>
Write_Str ("Overridden_Operation");
- when E_Generic_Package |
- E_Package =>
+ when E_Generic_Package
+ | E_Package
+ =>
Write_Str ("Package_Instantiation");
- when E_Component |
- E_Constant =>
+ when E_Component
+ | E_Constant
+ =>
Write_Str ("Related_Type");
- when Access_Kind |
- Task_Kind =>
+ when Access_Kind
+ | Task_Kind
+ =>
Write_Str ("Storage_Size_Variable");
- when others =>
+ when others =>
Write_Str ("Field26??");
end case;
end Write_Field26_Name;
@@ -10103,20 +10613,23 @@ package body Einfo is
procedure Write_Field27_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when E_Package |
- Type_Kind =>
+ when Type_Kind
+ | E_Package
+ =>
Write_Str ("Current_Use_Clause");
- when E_Component |
- E_Constant |
- E_Variable =>
+ when E_Component
+ | E_Constant
+ | E_Variable
+ =>
Write_Str ("Related_Type");
- when E_Procedure |
- E_Function =>
+ when E_Function
+ | E_Procedure
+ =>
Write_Str ("Wrapped_Entity");
- when others =>
+ when others =>
Write_Str ("Field27??");
end case;
end Write_Field27_Name;
@@ -10128,32 +10641,35 @@ package body Einfo is
procedure Write_Field28_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when E_Entry |
- E_Entry_Family |
- E_Function |
- E_Procedure |
- E_Subprogram_Body |
- E_Subprogram_Type =>
+ when E_Entry
+ | E_Entry_Family
+ | E_Function
+ | E_Procedure
+ | E_Subprogram_Body
+ | E_Subprogram_Type
+ =>
Write_Str ("Extra_Formals");
- when E_Package |
- E_Package_Body =>
+ when E_Package
+ | E_Package_Body
+ =>
Write_Str ("Finalizer");
- when E_Constant |
- E_Variable =>
+ when E_Constant
+ | E_Variable
+ =>
Write_Str ("Initialization_Statements");
- when E_Access_Subprogram_Type =>
+ when E_Access_Subprogram_Type =>
Write_Str ("Original_Access_Type");
- when Task_Kind =>
+ when Task_Kind =>
Write_Str ("Relative_Deadline_Variable");
when E_Record_Type =>
Write_Str ("Underlying_Record_View");
- when others =>
+ when others =>
Write_Str ("Field28??");
end case;
end Write_Field28_Name;
@@ -10165,14 +10681,22 @@ package body Einfo is
procedure Write_Field29_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when E_Constant |
- E_Variable =>
+ when E_Function
+ | E_Package
+ | E_Procedure
+ | E_Subprogram_Body
+ =>
+ Write_Str ("Anonymous_Masters");
+
+ when E_Constant
+ | E_Variable
+ =>
Write_Str ("BIP_Initialization_Call");
when Type_Kind =>
Write_Str ("Subprograms_For_Type");
- when others =>
+ when others =>
Write_Str ("Field29??");
end case;
end Write_Field29_Name;
@@ -10184,21 +10708,23 @@ package body Einfo is
procedure Write_Field30_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when E_Protected_Type |
- E_Task_Type =>
+ when E_Protected_Type
+ | E_Task_Type
+ =>
Write_Str ("Anonymous_Object");
- when E_Function =>
+ when E_Function =>
Write_Str ("Corresponding_Equality");
- when E_Constant |
- E_Variable =>
+ when E_Constant
+ | E_Variable
+ =>
Write_Str ("Last_Aggregate_Assignment");
- when E_Procedure =>
+ when E_Procedure =>
Write_Str ("Static_Initialization");
- when others =>
+ when others =>
Write_Str ("Field30??");
end case;
end Write_Field30_Name;
@@ -10210,22 +10736,24 @@ package body Einfo is
procedure Write_Field31_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when E_Procedure |
- E_Function =>
- Write_Str ("Thunk_Entity");
+ when E_Constant
+ | E_In_Parameter
+ | E_In_Out_Parameter
+ | E_Loop_Parameter
+ | E_Out_Parameter
+ | E_Variable
+ =>
+ Write_Str ("Activation_Record_Component");
- when Type_Kind =>
+ when Type_Kind =>
Write_Str ("Derived_Type_Link");
- when E_Constant |
- E_In_Parameter |
- E_In_Out_Parameter |
- E_Loop_Parameter |
- E_Out_Parameter |
- E_Variable =>
- Write_Str ("Activation_Record_Component");
+ when E_Function
+ | E_Procedure
+ =>
+ Write_Str ("Thunk_Entity");
- when others =>
+ when others =>
Write_Str ("Field31??");
end case;
end Write_Field31_Name;
@@ -10237,15 +10765,22 @@ package body Einfo is
procedure Write_Field32_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when E_Abstract_State |
- E_Constant |
- E_Variable =>
+ when E_Procedure =>
+ Write_Str ("Corresponding_Function");
+
+ when E_Function =>
+ Write_Str ("Corresponding_Procedure");
+
+ when E_Abstract_State
+ | E_Constant
+ | E_Variable
+ =>
Write_Str ("Encapsulating_State");
- when Type_Kind =>
+ when Type_Kind =>
Write_Str ("No_Tagged_Streams_Pragma");
- when others =>
+ when others =>
Write_Str ("Field32??");
end case;
end Write_Field32_Name;
@@ -10257,13 +10792,14 @@ package body Einfo is
procedure Write_Field33_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when E_Constant |
- E_Variable |
- Subprogram_Kind |
- Type_Kind =>
+ when Subprogram_Kind
+ | Type_Kind
+ | E_Constant
+ | E_Variable
+ =>
Write_Str ("Linker_Section_Pragma");
- when others =>
+ when others =>
Write_Str ("Field33??");
end case;
end Write_Field33_Name;
@@ -10275,26 +10811,27 @@ package body Einfo is
procedure Write_Field34_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when E_Constant |
- E_Entry |
- E_Entry_Family |
- E_Function |
- E_Generic_Function |
- E_Generic_Package |
- E_Generic_Procedure |
- E_Operator |
- E_Package |
- E_Package_Body |
- E_Procedure |
- E_Protected_Type |
- E_Subprogram_Body |
- E_Task_Body |
- E_Task_Type |
- E_Variable |
- E_Void =>
+ when E_Constant
+ | E_Entry
+ | E_Entry_Family
+ | E_Function
+ | E_Generic_Function
+ | E_Generic_Package
+ | E_Generic_Procedure
+ | E_Operator
+ | E_Package
+ | E_Package_Body
+ | E_Procedure
+ | E_Protected_Type
+ | E_Subprogram_Body
+ | E_Task_Body
+ | E_Task_Type
+ | E_Variable
+ | E_Void
+ =>
Write_Str ("Contract");
- when others =>
+ when others =>
Write_Str ("Field34??");
end case;
end Write_Field34_Name;
@@ -10306,10 +10843,18 @@ package body Einfo is
procedure Write_Field35_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when Subprogram_Kind =>
+ when E_Variable =>
+ Write_Str ("Anonymous_Designated_Type");
+
+ when E_Entry
+ | E_Entry_Family
+ =>
+ Write_Str ("Entry_Max_Queue_Lenghts_Array");
+
+ when Subprogram_Kind =>
Write_Str ("Import_Pragma");
- when others =>
+ when others =>
Write_Str ("Field35??");
end case;
end Write_Field35_Name;
@@ -10319,19 +10864,9 @@ package body Einfo is
------------------------
procedure Write_Field36_Name (Id : Entity_Id) is
+ pragma Unreferenced (Id);
begin
- case Ekind (Id) is
- when E_Function |
- E_Operator |
- E_Package |
- E_Package_Body |
- E_Procedure |
- E_Subprogram_Body =>
- Write_Str ("Anonymous_Master");
-
- when others =>
- Write_Str ("Field36??");
- end case;
+ Write_Str ("Field36??");
end Write_Field36_Name;
------------------------
@@ -10351,11 +10886,12 @@ package body Einfo is
procedure Write_Field38_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when E_Function |
- E_Procedure =>
- Write_Str ("Class-wide preconditions");
+ when E_Function
+ | E_Procedure
+ =>
+ Write_Str ("Class_Wide_Preconditions");
- when others =>
+ when others =>
Write_Str ("Field38??");
end case;
end Write_Field38_Name;
@@ -10367,11 +10903,12 @@ package body Einfo is
procedure Write_Field39_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when E_Function |
- E_Procedure =>
- Write_Str ("Class-wide postcondition");
+ when E_Function
+ | E_Procedure
+ =>
+ Write_Str ("Class_Wide_Postcondition");
- when others =>
+ when others =>
Write_Str ("Field39??");
end case;
end Write_Field39_Name;
@@ -10383,25 +10920,26 @@ package body Einfo is
procedure Write_Field40_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when E_Entry |
- E_Entry_Family |
- E_Function |
- E_Generic_Function |
- E_Generic_Package |
- E_Generic_Procedure |
- E_Operator |
- E_Package |
- E_Package_Body |
- E_Procedure |
- E_Protected_Body |
- E_Protected_Type |
- E_Subprogram_Body |
- E_Task_Body |
- E_Task_Type |
- E_Variable =>
+ when E_Entry
+ | E_Entry_Family
+ | E_Function
+ | E_Generic_Function
+ | E_Generic_Package
+ | E_Generic_Procedure
+ | E_Operator
+ | E_Package
+ | E_Package_Body
+ | E_Procedure
+ | E_Protected_Body
+ | E_Protected_Type
+ | E_Subprogram_Body
+ | E_Task_Body
+ | E_Task_Type
+ | E_Variable
+ =>
Write_Str ("SPARK_Pragma");
- when others =>
+ when others =>
Write_Str ("Field40??");
end case;
end Write_Field40_Name;
@@ -10413,14 +10951,20 @@ package body Einfo is
procedure Write_Field41_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
- when E_Generic_Package |
- E_Package |
- E_Package_Body |
- E_Protected_Type |
- E_Task_Type =>
+ when E_Function
+ | E_Procedure
+ =>
+ Write_Str ("Original_Protected_Subprogram");
+
+ when E_Generic_Package
+ | E_Package
+ | E_Package_Body
+ | E_Protected_Type
+ | E_Task_Type
+ =>
Write_Str ("SPARK_Aux_Pragma");
- when others =>
+ when others =>
Write_Str ("Field41??");
end case;
end Write_Field41_Name;
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index cd5a4fb254..5a762abcae 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -393,9 +393,11 @@ package Einfo is
-- attribute is applied directly to the entity, i.e. the entity is the
-- entity of the prefix of the attribute reference. Also set if the
-- entity is the second argument of an Asm_Input or Asm_Output attribute,
--- as the construct may entail taking its address. Used by the backend to
--- make sure that the address can be meaningfully taken, and also in the
--- case of subprograms to control output of certain warnings.
+-- as the construct may entail taking its address. And also set if the
+-- entity is a subprogram and the Access or Unchecked_Access attribute is
+-- applied. Used by the backend to make sure that the address can be
+-- meaningfully taken, and also in the case of subprograms to control
+-- output of certain warnings.
-- Aft_Value (synthesized)
-- Applies to fixed and decimal types. Computes a universal integer that
@@ -438,11 +440,15 @@ package Einfo is
-- definition clause with an (obsolescent) mod clause is converted
-- into an attribute definition clause for this purpose.
--- Anonymous_Master (Node36)
--- Defined in the entities of non-generic packages, subprograms and their
--- corresponding bodies. Contains the entity of a special heterogeneous
--- finalization master that services most anonymous access-to-controlled
--- allocations that occur within the unit.
+-- Anonymous_Designated_Type (Node35)
+-- Defined in variables which represent anonymous finalization masters.
+-- Contains the designated type which is being serviced by the master.
+
+-- Anonymous_Masters (Elist29)
+-- Defined in packages, subprograms, and subprogram bodies. Contains a
+-- list of anonymous finalization masters declared within the related
+-- unit. The list acts as a mapping between a master and a designated
+-- type.
-- Anonymous_Object (Node30)
-- Present in protected and task type entities. Contains the entity of
@@ -535,7 +541,7 @@ package Einfo is
-- a build-in-place function call. Contains the relocated build-in-place
-- call after the expansion has decoupled the call from the object. This
-- attribute is used by the finalization machinery to insert cleanup code
--- for all additional transient variables found in the transient block.
+-- for all additional transient objects found in the transient block.
-- C_Pass_By_Copy (Flag125) [implementation base type only]
-- Defined in record types. Set if a pragma Convention for the record
@@ -664,14 +670,13 @@ package Einfo is
-- stored in a non-standard way, see body for details.
-- Component_Bit_Offset (Uint11)
--- Defined in record components (E_Component, E_Discriminant) if a
--- component clause applies to the component. First bit position of
--- given component, computed from the first bit and position values
--- given in the component clause. A value of No_Uint means that the
--- value is not yet known. The value can be set by the appearance of
--- an explicit component clause in a record representation clause,
--- or it can be set by the front-end in package Layout, or it can be
--- set by the backend. By the time backend processing is completed,
+-- Defined in record components (E_Component, E_Discriminant). First
+-- bit position of given component, computed from the first bit and
+-- position values given in the component clause. A value of No_Uint
+-- means that the value is not yet known. The value can be set by the
+-- appearance of an explicit component clause in a record representation
+-- clause, or it can be set by the front-end in package Layout, or it can
+-- be set by the backend. By the time backend processing is completed,
-- this field is always set. A negative value is used to represent
-- a value which is not known at compile time, and must be computed
-- at run-time (this happens if fields of a record have variable
@@ -738,6 +743,17 @@ package Einfo is
-- other function entities, only in implicit inequality routines,
-- where Comes_From_Source is always False.
+-- Corresponding_Function (Node32)
+-- Defined on procedures internally built with an extra out parameter
+-- to return a constrained array type, when Modify_Tree_For_C is set.
+-- Denotes the function that returns the constrained array type for
+-- which this procedure was built.
+
+-- Corresponding_Procedure (Node32)
+-- Defined on functions that return a constrained array type, when
+-- Modify_Tree_For_C is set. Denotes the internally built procedure
+-- with an extra out parameter created for it.
+
-- Corresponding_Protected_Entry (Node18)
-- Defined in subprogram bodies. Set for subprogram bodies that implement
-- a protected type entry to point to the entity for the entry.
@@ -833,16 +849,6 @@ package Einfo is
-- default expressions (see Freeze.Process_Default_Expressions), which
-- would not only waste time, but also generate false error messages.
--- Default_Init_Cond_Procedure (synthesized)
--- Defined in all types. Set for private [sub]types subject to pragma
--- Default_Initial_Condition, their corresponding full views and derived
--- types with at least one parent subject to the pragma. Contains the
--- entity of the procedure which takes a single argument of the given
--- type and verifies the assumption of the pragma.
---
--- Note: the reason this is marked as a synthesized attribute is that the
--- way this is stored is as an element of the Subprograms_For_Type field.
-
-- Default_Value (Node20)
-- Defined in formal parameters. Points to the node representing the
-- expression for the default value for the parameter. Empty if the
@@ -917,6 +923,16 @@ package Einfo is
-- incomplete type, and the full type is available, then this full type
-- is returned instead of the incomplete type.
+-- DIC_Procedure (synthesized)
+-- Defined in all type entities. Set for a private type and its full view
+-- when the type is subject to pragma Default_Initial_Condition (DIC), or
+-- when the type inherits a DIC pragma from a parent type. Points to the
+-- entity of a procedure which takes a single argument of the given type
+-- and verifies the assertion expression of the DIC pragma at run time.
+
+-- Note: the reason this is marked as a synthesized attribute is that the
+-- way this is stored is as an element of the Subprograms_For_Type field.
+
-- Digits_Value (Uint17)
-- Defined in floating point types and subtypes and decimal types and
-- subtypes. Contains the Digits value specified in the declaration.
@@ -1139,6 +1155,11 @@ package Einfo is
-- accept statement for a member of the family, and in the prefix of
-- 'COUNT when it applies to a family member.
+-- Entry_Max_Queue_Lengths_Array (Node35)
+-- Defined in protected types for which Has_Entries is true. Contains the
+-- defining identifier for the array of naturals used by the runtime to
+-- limit the queue size of each entry individually.
+
-- Entry_Parameters_Type (Node15)
-- Defined in entries. Points to the access-to-record type that is
-- constructed by the expander to hold a reference to the parameter
@@ -1554,11 +1575,6 @@ package Einfo is
-- value is set, but it may be overridden by an aspect declaration on
-- type derivation.
--- Has_Default_Init_Cond (Flag3) [base type only]
--- Defined in all type entities. Set if pragma Default_Initial_Condition
--- applies to a private type and by extension to its full view. This flag
--- is mutually exclusive with flag Has_Inherited_Default_Init_Cond.
-
-- Has_Delayed_Aspects (Flag200)
-- Defined in all entities. Set if the Rep_Item chain for the entity has
-- one or more N_Aspect_Definition nodes chained which are not to be
@@ -1580,6 +1596,11 @@ package Einfo is
-- set, signalling that Freeze.Inherit_Delayed_Rep_Aspects must be called
-- at the freeze point of the derived type.
+-- Has_DIC (syntherized)
+-- Defined in all type entities. Set for a private type and its full view
+-- when the type is subject to pragma Default_Initial_Condition (DIC), or
+-- when the type inherits a DIC pragma from a parent type.
+
-- Has_Discriminants (Flag5)
-- Defined in all types and subtypes. For types that are allowed to have
-- discriminants (record types and subtypes, task types and subtypes,
@@ -1686,19 +1707,21 @@ package Einfo is
-- will be chained to the rep item chain of the first subtype in the
-- usual manner.
--- Has_Inheritable_Invariants (Flag248)
--- Defined in all type entities. Set in private types from which one
--- or more Invariant'Class aspects will be inherited if a another type is
--- derived from the type (i.e. those types which have an Invariant'Class
--- aspect, or which inherit one or more Invariant'Class aspects). Also
--- set in the corresponding full types. Note that it might be the full
--- type which has inheritable invariants, and in this case the flag will
--- also be set in the private type.
+-- Has_Inheritable_Invariants (Flag248) [base type only]
+-- Defined in all type entities. Set on private types and interface types
+-- which define at least one class-wide invariant. Such invariants must
+-- be inherited by derived types. The flag is also set on the full view
+-- of a private type for completeness.
--- Has_Inherited_Default_Init_Cond (Flag133) [base type only]
--- Defined in all type entities. Set when a derived type inherits pragma
--- Default_Initial_Condition from its parent type. This flag is mutually
--- exclusive with flag Has_Default_Init_Cond.
+-- Has_Inherited_DIC (Flag133) [base type only]
+-- Defined in all type entities. Set for a derived type which inherits
+-- pragma Default_Initial_Condition from a parent type.
+
+-- Has_Inherited_Invariants (Flag291) [base type only]
+-- Defined in all type entities. Set on private extensions and derived
+-- types which inherit at least on class-wide invariant from a parent or
+-- an interface type. The flag is also set on the full view of a private
+-- extension for completeness.
-- Has_Initial_Value (Flag219)
-- Defined in entities for variables and out parameters. Set if there
@@ -1714,15 +1737,10 @@ package Einfo is
-- definition contains at least one procedure to which a pragma
-- Interrupt_Handler applies.
--- Has_Invariants (Flag232)
--- Defined in all type entities and in subprogram entities. Set in
--- private types if an Invariant or Invariant'Class aspect applies to the
--- type, or if the type inherits one or more Invariant'Class aspects.
--- Also set in the corresponding full type. Note: if this flag is set
--- True, then usually the Invariant_Procedure attribute is set once the
--- type is frozen, however this may not be true in some error situations.
--- Note that it might be the full type which has inheritable invariants,
--- and then the flag will also be set in the private type.
+-- Has_Invariants (synthesized)
+-- Defined in all type entities. True if the type defines at least one
+-- invariant of its own or inherits at least one class-wide invariant
+-- from a parent type or an interface.
-- Has_Loop_Entry_Attributes (Flag260)
-- Defined in E_Loop entities. Set when the loop is subject to at least
@@ -1743,7 +1761,7 @@ package Einfo is
-- Defined in functions and generic functions. Set if there is one or
-- more missing return statements in the function. This is used to
-- control wrapping of the body in Exp_Ch6 to ensure that the program
--- error exception is correctly raised in this case at runtime.
+-- error exception is correctly raised in this case at run time.
-- Has_Nested_Block_With_Handler (Flag101)
-- Defined in scope entities. Set if there is a nested block within the
@@ -1761,6 +1779,10 @@ package Einfo is
-- E_Abstract_State entities. True if their Non_Limited_View attribute
-- is present.
+-- Has_Non_Null_Abstract_State (synth)
+-- Defined in package entities. True if the package is subject to a non-
+-- null Abstract_State aspect/pragma.
+
-- Has_Non_Null_Visible_Refinement (synth)
-- Defined in E_Abstract_State entities. True if the state has a visible
-- refinement of at least one variable or state constituent as expressed
@@ -1794,6 +1816,23 @@ package Einfo is
-- families. Set if they have at least one OUT or IN OUT parameter
-- (allowed for functions only in Ada 2012).
+-- Has_Own_DIC (Flag3) [base type only]
+-- Defined in all type entities. Set for a private type and its full view
+-- when the type is subject to pragma Default_Initial_Condition.
+
+-- Has_Own_Invariants (Flag232) [base type only]
+-- Defined in all type entities. Set on any type which defines at least
+-- one invariant of its own. The flag is also set on the full view of a
+-- private type for completeness.
+
+-- Has_Partial_Visible_Refinement (Flag296)
+-- Defined in E_Abstract_State entities. Set when a state has at least
+-- one refinement constituent subject to indicator Part_Of, and analysis
+-- is in the region between the declaration of the first constituent for
+-- this abstract state (in the private part of the package) and the end
+-- of the package spec or body with visibility over this private part
+-- (which includes the package itself and its child packages).
+
-- Has_Per_Object_Constraint (Flag154)
-- Defined in E_Component entities. Set if the subtype of the component
-- has a per object constraint. Per object constraints result from the
@@ -1884,17 +1923,27 @@ package Einfo is
-- that clients should generally not test this flag directly, but instead
-- use function Has_Unreferenced.
+-- ??? this real description was clobbered
+
-- Has_Pragma_Unreferenced_Objects (Flag212)
--- Defined in type and subtype entities. Set if a valid pragma
--- Unreferenced_Objects applies to the type, indicating that no warning
--- should be given for objects of such a type for being unreferenced
--- (but unlike the case with pragma Unreferenced, it is ok to reference
--- such an object and no warning is generated.
+-- Defined in all entities. Set if a valid pragma Unused applies to an
+-- entity, indicating that warnings should be given if the entity is
+-- modified or referenced. This pragma is equivalent to a pair of
+-- Unmodified and Unreferenced pragmas.
+
+-- Has_Pragma_Unused (Flag294)
+-- Defined in all entries. Set if a valid pragma Unused applies to a
+-- variable or entity, indicating that warnings should not be given if
+-- it is never modified or referenced. Note: This pragma is exactly
+-- equivalent Unmodified and Unreference combined.
-- Has_Predicates (Flag250)
-- Defined in type and subtype entities. Set if a pragma Predicate or
-- Predicate aspect applies to the type or subtype, or if it inherits a
-- Predicate aspect from its parent or progenitor types.
+--
+-- Note: this flag is set on both partial and full view of types to which
+-- a Predicate pragma or aspect applies.
-- Has_Primitive_Operations (Flag120) [base type only]
-- Defined in all type entities. Set if at least one primitive operation
@@ -1918,10 +1967,10 @@ package Einfo is
-- Has_Protected (Flag271) [base type only]
-- Defined in all type entities. Set on protected types themselves, and
-- also (recursively) on any composite type which has a component for
--- which Has_Protected is set. The meaning is that an allocator for
--- or declaration of such an object must create the required protected
--- objects. Note: the flag is not set on access types, even if they
--- designate an object that Has_Protected.
+-- which Has_Protected is set, unless the protected type is declared in
+-- the private part of an internal unit. The meaning is that restrictions
+-- for protected types apply to this type. Note: the flag is not set on
+-- access types, even if they designate an object that Has_Protected.
-- Has_Qualified_Name (Flag161)
-- Defined in all entities. Set if the name in the Chars field has
@@ -2032,6 +2081,12 @@ package Einfo is
-- such an object must create the required tasks. Note: the flag is not
-- set on access types, even if they designate an object that Has_Task.
+-- Has_Timing_Event (Flag289) [base type only]
+-- Defined in all type entities. Set on language defined type
+-- Ada.Real_Time.Timing_Events.Timing_Event, and also (recursively) on
+-- any composite type which has a component for which Has_Timing_Event
+-- is set. Used for the No_Local_Timing_Event restriction.
+
-- Has_Thunks (Flag228)
-- Applies to E_Constant entities marked Is_Tag. True for secondary tag
-- referencing a dispatch table whose contents are pointers to thunks.
@@ -2165,15 +2220,18 @@ package Einfo is
-- ancestors (Ada 2005: AI-251).
-- Invariant_Procedure (synthesized)
--- Defined in types and subtypes. Set for private types if one or more
--- Invariant, or Invariant'Class, or inherited Invariant'Class aspects
--- apply to the type. Points to the entity for a procedure which checks
--- the invariant. This invariant procedure takes a single argument of the
--- given type, and returns if the invariant holds, or raises exception
--- Assertion_Error with an appropriate message if it does not hold. This
--- attribute is defined but always empty for private subtypes. This
--- attribute is also set for the corresponding full type.
---
+-- Defined in types and subtypes. Set for private types and their full
+-- views if one or more [class-wide] invariants apply to the type, or
+-- when the type inherits class-wide invariants from a parent type or
+-- an interface, or when the type is an array and its component type is
+-- subject to an invariant, or when the type is record and contains a
+-- component subject to an invariant (property is recursive). Points to
+-- to the entity for a procedure which checks all these invariants. The
+-- invariant procedure takes a single argument of the given type, and
+-- returns if the invariant holds, or raises exception Assertion_Error
+-- with an appropriate message if it does not hold. This attribute is
+-- defined but always Empty for private subtypes.
+
-- Note: the reason this is marked as a synthesized attribute is that the
-- way this is stored is as an element of the Subprograms_For_Type field.
@@ -2202,6 +2260,10 @@ package Einfo is
-- Is_Access_Type (synthesized)
-- Applies to all entities, true for access types and subtypes
+-- Is_Actual_Subtype (Flag293)
+-- Defined on all types, true for the generated constrained subtypes
+-- that are built for unconstrained composite actuals.
+
-- Is_Ada_2005_Only (Flag185)
-- Defined in all entities, true if a valid pragma Ada_05 or Ada_2005
-- applies to the entity which specifically names the entity, indicating
@@ -2243,16 +2305,16 @@ package Einfo is
-- applies to both the partial view and the full view.
-- Is_Base_Type (synthesized)
--- Applies to type and subtype entities. True if entity is a base type
+-- Applies to type and subtype entities. True if entity is a base type.
-- Is_Bit_Packed_Array (Flag122) [implementation base type only]
-- Defined in all entities. This flag is set for a packed array type that
--- is bit packed (i.e. the component size is known by the front end and
+-- is bit-packed (i.e. the component size is known by the front end and
-- is in the range 1-7, 9-15, 17-31, or 33-63). Is_Packed is always set
-- if Is_Bit_Packed_Array is set, but it is possible for Is_Packed to be
--- set without Is_Bit_Packed_Array for the case of an array having one or
--- more index types that are enumeration types with non-standard
--- enumeration representations.
+-- set without Is_Bit_Packed_Array if the component size is not known by
+-- the front-end or for the case of an array having one or more index
+-- types that are enumeration types with non-standard representation.
-- Is_Boolean_Type (synthesized)
-- Applies to all entities, true for boolean types and subtypes,
@@ -2301,15 +2363,15 @@ package Einfo is
-- which are not Completely_Hidden (e.g. discriminants of a root type).
-- Is_Composite_Type (synthesized)
--- Applies to all entities, true for all composite types and
--- subtypes. Either Is_Composite_Type or Is_Elementary_Type (but
--- not both) is true of any type.
+-- Applies to all entities, true for all composite types and subtypes.
+-- Either Is_Composite_Type or Is_Elementary_Type (but not both) is true
+-- of any type.
-- Is_Concurrent_Record_Type (Flag20)
-- Defined in record types and subtypes. Set if the type was created
-- by the expander to represent a task or protected type. For every
-- concurrent type, such as record type is constructed, and task and
--- protected objects are instances of this record type at runtime
+-- protected objects are instances of this record type at run time
-- (The backend will replace declarations of the concurrent type using
-- the declarations of the corresponding record type). See Exp_Ch9 for
-- further details.
@@ -2364,14 +2426,15 @@ package Einfo is
-- Applies to all type entities, true for decimal fixed point
-- types and subtypes.
--- Is_Default_Init_Cond_Procedure (Flag132)
--- Defined in functions and procedures. Set for a generated procedure
--- which verifies the assumption of pragma Default_Initial_Condition.
-
--- Is_Descendent_Of_Address (Flag223)
+-- Is_Descendant_Of_Address (Flag223)
-- Defined in all entities. True if the entity is type System.Address,
-- or (recursively) a subtype or derived type of System.Address.
+-- Is_DIC_Procedure (Flag132)
+-- Defined in functions and procedures. Set for a generated procedure
+-- which verifies the assumption of pragma Default_Initial_Condition at
+-- run time.
+
-- Is_Discrete_Or_Fixed_Point_Type (synthesized)
-- Applies to all entities, true for all discrete types and subtypes
-- and all fixed-point types and subtypes.
@@ -2425,9 +2488,17 @@ package Einfo is
-- be in, in-out or out parameters). This flag is used to speed up the
-- test for the need to replace references in Exp_Ch2.
+-- Is_Entry_Wrapper (Flag297)
+-- Defined on wrappers created for entries that have precondition aspects
+
-- Is_Enumeration_Type (synthesized)
-- Defined in all entities, true for enumeration types and subtypes
+-- Is_Exception_Handler (Flag286)
+-- Defined in blocks. Set if the block serves only as a scope of an
+-- exception handler with a choice parameter. Such a block does not
+-- physically appear in the tree.
+
-- Is_Exported (Flag99)
-- Defined in all entities. Set if the entity is exported. For now we
-- only allow the export of constants, exceptions, functions, procedures
@@ -2438,6 +2509,12 @@ package Einfo is
-- Applies to all entities, true for abstract states that are subject to
-- option External.
+-- Is_Finalized_Transient (Flag252)
+-- Defined in constants, loop parameters of generalized iterators, and
+-- variables. Set when a transient object has been finalized by one of
+-- the transient finalization mechanisms. The flag prevents the double
+-- finalization of the object.
+
-- Is_Finalizer (synthesized)
-- Applies to all entities, true for procedures containing finalization
-- code to process local or library level objects.
@@ -2549,6 +2626,13 @@ package Einfo is
-- pragma Ghost or inherit "ghostness" from an enclosing construct, and
-- subject to Assertion_Policy Ghost => Ignore.
+-- Is_Ignored_Transient (Flag295)
+-- Defined in constants, loop parameters of generalized iterators, and
+-- variables. Set when a transient object must be processed by one of
+-- the transient finalization mechanisms. Once marked, a transient is
+-- intentionally ignored by the general finalization mechanism because
+-- its clean up actions are context specific.
+
-- Is_Immediately_Visible (Flag7)
-- Defined in all entities. Set if entity is immediately visible, i.e.
-- is defined in some currently open scope (RM 8.3(4)).
@@ -2646,17 +2730,20 @@ package Einfo is
-- Is_Intrinsic_Subprogram (Flag64)
-- Defined in functions and procedures. It is set if a valid pragma
--- Interface or Import is present for this subprogram specifying pragma
--- Intrinsic. Valid means that the name and profile of the subprogram
--- match the requirements of one of the recognized intrinsic subprograms
--- (see package Sem_Intr for details). Note: the value of Convention for
--- such an entity will be set to Convention_Intrinsic, but it is the
--- setting of Is_Intrinsic_Subprogram, NOT simply having convention set
--- to intrinsic, which causes intrinsic code to be generated.
+-- Interface or Import is present for this subprogram specifying
+-- convention Intrinsic. Valid means that the name and profile of the
+-- subprogram match the requirements of one of the recognized intrinsic
+-- subprograms (see package Sem_Intr for details). Note: the value of
+-- Convention for such an entity will be set to Convention_Intrinsic,
+-- but it is the setting of Is_Intrinsic_Subprogram, NOT simply having
+-- convention set to intrinsic, which causes intrinsic code to be
+-- generated.
-- Is_Invariant_Procedure (Flag257)
-- Defined in functions and procedures. Set for a generated invariant
--- procedure to identify it easily.
+-- procedure which verifies the invariants of both the partial and full
+-- views of a private type or private extension as well as any inherited
+-- class-wide invariants from parent types or interfaces.
-- Is_Itype (Flag91)
-- Defined in all entities. Set to indicate that a type is an Itype,
@@ -2829,49 +2916,49 @@ package Einfo is
-- Is_Packed (Flag51) [implementation base type only]
-- Defined in all type entities. This flag is set only for record and
--- array types which have a packed representation. There are three
--- cases which cause packing:
+-- array types which have a packed representation. There are four cases
+-- which cause packing:
--
--- 1. Explicit use of pragma Pack for an array of package components
--- 2. Explicit use of pragma Pack to pack a record
--- 4. Setting Component_Size of an array to a bit-packable value
--- 3. Indexing an array with a non-standard enumeration type.
+-- 1. Explicit use of pragma Pack to pack a record.
+-- 2. Explicit use of pragma Pack to pack an array.
+-- 3. Setting Component_Size of an array to a packable value.
+-- 4. Indexing an array with a non-standard enumeration type.
--
--- For records, Is_Packed is always set if Has_Pragma_Pack is set,
--- and can also be set on its own in a derived type which inherited
--- its packed status.
---
--- For arrays, Is_Packed is set if an array is bit packed (i.e. the
--- component size is known at compile time and is 1-7, 9-15 or 17-31),
--- or if the array has one or more index types that are enumeration
--- types with non-standard representations (in GNAT, we store such
--- arrays compactly, using the Pos of the enumeration type value).
---
--- As for the case of records, Is_Packed can be set on its own for a
--- derived type, with the same dual before/after freeze meaning.
--- Is_Packed can also be set as the result of an explicit component
--- size clause that specifies an appropriate component size.
---
--- In the bit packed array case, Is_Bit_Packed_Array will be set in
--- the bit packed case once the array type is frozen.
+-- For records, Is_Packed is always set if Has_Pragma_Pack is set, and
+-- can also be set on its own in a derived type which inherited its
+-- packed status.
--
+-- For arrays, Is_Packed is set if either Has_Pragma_Pack is set and the
+-- component size is either not known at compile time or known but not
+-- 8/16/32/64 bits, or a Component_Size clause exists and the specified
+-- value is smaller than 64 bits but not 8/16/32, or if the array has one
+-- or more index types that are enumeration types with a non-standard
+-- representation (in GNAT, we store such arrays compactly, using the Pos
+-- of the enumeration type value). As for the case of records, Is_Packed
+-- can be set on its own for a derived type.
+
-- Before an array type is frozen, Is_Packed will always be set if
-- Has_Pragma_Pack is set. Before the freeze point, it is not possible
-- to know the component size, since the component type is not frozen
-- until the array type is frozen. Thus Is_Packed for an array type
-- before it is frozen means that packed is required. Then if it turns
--- out that the component size is not suitable for bit packing, the
--- Is_Packed flag gets turned off.
+-- out that the component size doesn't require packing, the Is_Packed
+-- flag gets turned off.
+-- In the bit-packed array case (i.e. component size is known at compile
+-- time and is 1-7, 9-15, 17-31 or 33-63), Is_Bit_Packed_Array will be
+-- set once the array type is frozen.
+--
-- Is_Packed_Array (synth)
-- Applies to all entities, true if entity is for a packed array.
-- Is_Packed_Array_Impl_Type (Flag138)
-- Defined in all entities. This flag is set on the entity for the type
--- used to implement a packed array (either a modular type, or a subtype
--- of Packed_Bytes{1,2,4} as appropriate). The flag is set if and only
+-- used to implement a packed array (either a modular type or a subtype
+-- of Packed_Bytes{1,2,4} in the bit-packed array case, a regular array
+-- in the non-standard enumeration index case). It is set if and only
-- if the type appears in the Packed_Array_Impl_Type field of some other
--- entity. It is used by the backend to activate the special processing
+-- entity. It is used by the back end to activate the special processing
-- for such types (unchecked conversions that would not otherwise be
-- allowed are allowed for such types). If Is_Packed_Array_Impl_Type is
-- set in an entity, then the Original_Array_Type field of this entity
@@ -2882,6 +2969,11 @@ package Einfo is
-- component of the parameter block record type generated by the compiler
-- for an entry or a select statement. Read by CodePeer.
+-- Is_Partial_Invariant_Procedure (Flag292)
+-- Defined in functions and procedures. Set for a generated invariant
+-- procedure which verifies the invariants of the partial view of a
+-- private type or private extension.
+
-- Is_Potentially_Use_Visible (Flag9)
-- Defined in all entities. Set if entity is potentially use visible,
-- i.e. it is defined in a package that appears in a currently active
@@ -2929,7 +3021,7 @@ package Einfo is
-- Is_Private_Descendant (Flag53)
-- Defined in entities that can represent library units (packages,
-- functions, procedures). Set if the library unit is itself a private
--- child unit, or if it is the descendent of a private child unit.
+-- child unit, or if it is the descendant of a private child unit.
-- Is_Private_Primitive (Flag245)
-- Defined in subprograms. Set if the operation is a primitive of a
@@ -2943,13 +3035,6 @@ package Einfo is
-- Applies to all entities, true for private types and subtypes,
-- as well as for record with private types as subtypes.
--- Is_Processed_Transient (Flag252)
--- Defined in variables, loop parameters, and constants, including the
--- loop parameters of generalized iterators. Set when a transient object
--- needs to be finalized and has already been processed by the transient
--- scope machinery. This flag signals the general finalization mechanism
--- to ignore the transient object.
-
-- Is_Protected_Component (synthesized)
-- Applicable to all entities, true if the entity denotes a private
-- component of a protected type.
@@ -3151,6 +3236,11 @@ package Einfo is
-- Defined in all entities. Set only in record types to which the
-- pragma Unchecked_Union has been validly applied.
+-- Is_Underlying_Full_View (Flag298)
+-- Defined in all entities. Set for types which represent the true full
+-- view of a private type completed by another private type. For further
+-- details, see attribute Underlying_Full_View.
+
-- Is_Underlying_Record_View (Flag246) [base type only]
-- Defined in all entities. Set only in record types that represent the
-- underlying record view. This view is built for derivations of types
@@ -3385,7 +3475,7 @@ package Einfo is
-- Needs_No_Actuals (Flag22)
-- Defined in callable entities (subprograms, entries, access to
--- subprograms) which can be called without actuals because all of
+-- subprograms) which can be called without actuals because all of
-- their formals (if any) have default values. This flag simplifies the
-- resolution of the syntactic ambiguity involving a call to these
-- entities when the return type is an array type, and a call can be
@@ -3449,7 +3539,7 @@ package Einfo is
-- Next_Discriminant (synthesized)
-- Applies to discriminants returned by First/Next_Discriminant. Returns
--- the next language-defined (ie: perhaps non-girder) discriminant by
+-- the next language-defined (i.e. perhaps non-girder) 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
@@ -3562,8 +3652,8 @@ package Einfo is
-- depends on discriminants. In this case, the Normalized_Position_Max
-- field represents the maximum possible value of Normalized_Position
-- assuming min/max values for discriminant subscripts in all fields.
--- This is used by Layout in front end layout mode to properly computed
--- the maximum size such records (needed for allocation purposes when
+-- This is used by Layout in front end layout mode to properly compute
+-- the maximum size of such records (needed for allocation purposes when
-- there are default discriminants, and also for the 'Size value).
-- Number_Dimensions (synthesized)
@@ -3624,6 +3714,11 @@ package Einfo is
-- points to the original array type for which this is the packed
-- array implementation type.
+-- Original_Protected_Subprogram (Node41)
+-- Defined in functions and procedures. Set only on internally built
+-- dispatching subprograms of protected types to reference their original
+-- non-dispatching protected subprogram since their names differ.
+
-- Original_Record_Component (Node22)
-- Defined in components, including discriminants. The usage depends
-- on whether the record is a base type and whether it is tagged.
@@ -3670,16 +3765,17 @@ package Einfo is
-- with formal packages. ???
-- Packed_Array_Impl_Type (Node23)
--- Defined in array types and subtypes, including the string literal
--- subtype case, if the corresponding type is packed (either bit packed
--- or packed to eliminate holes in non-contiguous enumeration type index
--- types). References the type used to represent the packed array, which
--- is either a modular type for short static arrays, or an array of
--- System.Unsigned. Note that in some situations (internal types, and
--- references to fields of variant records), it is not always possible
--- to construct this type in advance of its use. If this field is empty,
--- then the necessary type is declared on the fly for each reference to
--- the array.
+-- Defined in array types and subtypes, except for the string literal
+-- subtype case, if the corresponding type is packed and implemented
+-- specially (either bit-packed or packed to eliminate holes in the
+-- non-contiguous enumeration index types). References the type used to
+-- represent the packed array, which is either a modular type for short
+-- static arrays or an array of System.Unsigned in the bit-packed case,
+-- or a regular array in the non-standard enumeration index case). Note
+-- that in some situations (internal types and references to fields of
+-- variant records), it is not always possible to construct this type in
+-- advance of its use. If this field is empty, then the necessary type
+-- is declared on the fly for each reference to the array.
-- Parameter_Mode (synthesized)
-- Applies to formal parameter entities. This is a synonym for Ekind,
@@ -3702,6 +3798,25 @@ package Einfo is
-- of a single protected/task type, the references are examined as they
-- must appear only within the type defintion and the corresponding body.
+-- Partial_Invariant_Procedure (synthesized)
+-- Defined in types and subtypes. Set for private types when one or more
+-- [class-wide] type invariants apply to them. Points to the entity for a
+-- procedure which checks the invariant. This invariant procedure takes a
+-- single argument of the given type, and returns if the invariant holds,
+-- or raises exception Assertion_Error with an appropriate message if it
+-- does not hold. This attribute is defined but always Empty for private
+-- subtypes. This attribute is also set for the corresponding full type.
+--
+-- Note: the reason this is marked as a synthesized attribute is that the
+-- way this is stored is as an element of the Subprograms_For_Type field.
+
+-- Partial_Refinement_Constituents (synthesized)
+-- Defined in abstract state entities. Returns the constituents that
+-- refine the state in the current scope, which are allowed in a global
+-- refinement in this scope. These consist of those constituents that are
+-- abstract states with no or only partial refinement visible, and those
+-- that are not themselves abstract states.
+
-- Partial_View_Has_Unknown_Discr (Flag280)
-- Present in all types. Set to Indicate that the partial view of a type
-- has unknown discriminants. A default initialization of an object of
@@ -3727,6 +3842,14 @@ package Einfo is
-- which takes a single argument of the given type, and returns True if
-- the predicate holds and False if it does not.
--
+-- Note: flag Has_Predicate does not imply that Predicate_Function is set
+-- to a non-empty entity; this happens, for example, for itypes created
+-- when instantiating generic units with private types with predicates.
+-- However, if an explicit pragma Predicate or Predicate aspect is given
+-- either for private or full type declaration then both Has_Predicates
+-- and a non-empty Predicate_Function will be set on both the partial and
+-- full views of the type.
+--
-- Note: the reason this is marked as a synthesized attribute is that the
-- way this is stored is as an element of the Subprograms_For_Type field.
@@ -3736,6 +3859,11 @@ package Einfo is
-- is the special version created for membership tests, where if one of
-- these raise expressions is executed, the result is to return False.
+-- Predicates_Ignored (Flag288)
+-- Defined on all types. Indicates whether the subtype declaration is in
+-- a context where Assertion_Policy is Ignore, in which case no checks
+-- (static or dynamic) must be generated for objects of the type.
+
-- Primitive_Operations (synthesized)
-- Defined in concurrent types, tagged record types and subtypes, tagged
-- private types and tagged incomplete types. For concurrent types whose
@@ -3834,7 +3962,7 @@ package Einfo is
-- the expanded N_Procedure_Call_Statement node for this call. It
-- is used for Import/Export_Exception processing to modify the
-- register call to make appropriate entries in the special tables
--- used for handling these pragmas at runtime.
+-- used for handling these pragmas at run time.
-- Related_Array_Object (Node25)
-- Defined in array types and subtypes. Used only for the base type
@@ -3886,17 +4014,16 @@ package Einfo is
-- package can see the entities in the package via the renaming.
-- Renamed_Object (Node18)
--- Defined in all objects (constants, variables, components, formal
--- parameters, generic formal parameters, and loop parameters).
--- ??? Defined in discriminants?
--- Set non-Empty if the object was declared by a renaming declaration,
--- in which case it references the tree node for the name of the renamed
--- object. This is only possible for the variable and constant cases.
--- For formal parameters, this field is used in the course of inline
--- expansion, to map the formals of a subprogram into the corresponding
--- actuals. For formals of a task entry, it denotes the local renaming
--- that replaces the actual within the accept statement. The field is
--- Empty otherwise (it is always empty for loop parameters).
+-- Defined in components, constants, discriminants, formal parameters,
+-- generic formals, loop parameters, and variables. Set to non-Empty if
+-- the object was declared by a renaming declaration. For constants and
+-- variables, the attribute references the tree node for the name of the
+-- renamed object. For formal parameters, the field is used in inlining
+-- and maps the entities of all formal parameters of a subprogram to the
+-- entities of the corresponding actuals. For formals of a task entry,
+-- the attribute denotes the local renaming that replaces the actual
+-- within an accept statement. For all remaining cases (discriminants,
+-- loop parameters) the field is Empty.
-- Renaming_Map (Uint9)
-- Defined in generic subprograms, generic packages, and their
@@ -3932,12 +4059,6 @@ package Einfo is
-- by reference, either because its return type is a by-reference-type
-- or because the function explicitly uses the secondary stack.
--- Returns_Limited_View (Flag134)
--- Defined in function entities. Set if the return type of the function
--- at the point of definition is a limited view. Used to handle the late
--- freezing of the function when it is called in the current semantic
--- unit while it is still unfrozen.
-
-- Reverse_Bit_Order (Flag164) [base type only]
-- Defined in all record type entities. Set if entity has a Bit_Order
-- aspect (set by an aspect clause or attribute definition clause) that
@@ -4162,9 +4283,9 @@ package Einfo is
-- of the predicate function. This is the original expression given as
-- the predicate except that occurrences of the type are replaced by
-- occurrences of the formal parameter of the predicate function (note
--- that the spec of this function including this formal parameter name)
--- is available from the Subprograms_For_Type field (it can be accessed
--- as Predicate_Function (typ). Also, in the case where a predicate is
+-- that the spec of this function including this formal parameter name
+-- is available from the Subprograms_For_Type field; it can be accessed
+-- as Predicate_Function (typ)). Also, in the case where a predicate is
-- inherited, the expression is of the form:
--
-- xxxPredicate (typ2 (ent)) AND THEN expression
@@ -4221,15 +4342,14 @@ package Einfo is
-- the low bound of the applicable index constraint if there is one,
-- or a copy of the low bound of the index base type if not.
--- Subprograms_For_Type (Node29)
--- Defined in all type and subprogram entities. This is used to hold
--- a list of subprogram entities for subprograms associated with the
--- type, linked through the Subprograms_For_Type field of the subprogram
--- entity. Basically this is a way of multiplexing the single field to
--- hold more than one entity (since we ran out of space in some type
--- entities). This is currently used for Invariant_Procedure and also
--- for Predicate_Function, and clients will always use the latter two
--- names to access entries in this list.
+-- Subprograms_For_Type (Elist29)
+-- Defined in all types. The list may contain the entities of the default
+-- initial condition procedure, invariant procedure, and the two versions
+-- of the predicate function.
+--
+-- Historical note: This attribute used to be a direct linked list of
+-- entities rather than an Elist. The Elist allows greater flexibility
+-- in inheritance of subprograms between views of the same type.
-- Subps_Index (Uint24)
-- Present in subprogram entries. Set if the subprogram contains nested
@@ -4442,9 +4562,9 @@ package Einfo is
-- protected operation, etc).
-- b) Alias applies to overloadable entities, and the value is an overloadable
--- entity. so this is a subset of the previous one. We use the term Alias to
+-- entity. So this is a subset of the previous one. We use the term Alias to
-- cover both renamings and inherited operations, because both cases are
--- handled in the same way when expanding a call. namely the Alias of a given
+-- handled in the same way when expanding a call. Namely the Alias of a given
-- subprogram is the subprogram that will actually be called.
-- Both a) and b) are set transitively, so that in fact it is not necessary to
@@ -4472,7 +4592,7 @@ package Einfo is
-- The flag Has_Delayed_Freeze indicates that an entity carries an explicit
-- freeze node, which appears later in the expanded tree.
--- a) The flag is used by the front-end to trigger expansion actions
+-- a) The flag is used by the front-end to trigger expansion actions
-- which include the generation of that freeze node. Typically this happens at
-- the end of the current compilation unit, or before the first subprogram
-- body is encountered in the current unit. See files freeze and exp_ch13 for
@@ -4480,7 +4600,7 @@ package Einfo is
-- construction of initialization procedures and dispatch tables.
-- b) The flag is used by the backend to defer elaboration of the entity until
--- its freeze node is seen. In the absence of an explicit freeze node, an
+-- its freeze node is seen. In the absence of an explicit freeze node, an
-- entity is frozen (and elaborated) at the point of declaration.
-- For object declarations, the flag is set when an address clause for the
@@ -5327,6 +5447,7 @@ package Einfo is
-- Has_Pragma_Thread_Local_Storage (Flag169)
-- Has_Pragma_Unmodified (Flag233)
-- Has_Pragma_Unreferenced (Flag180)
+ -- Has_Pragma_Unused (Flag294)
-- Has_Private_Declaration (Flag155)
-- Has_Qualified_Name (Flag161)
-- Has_Stream_Size_Clause (Flag184)
@@ -5341,7 +5462,7 @@ package Einfo is
-- Is_Checked_Ghost_Entity (Flag277)
-- Is_Child_Unit (Flag73)
-- Is_Compilation_Unit (Flag149)
- -- Is_Descendent_Of_Address (Flag223)
+ -- Is_Descendant_Of_Address (Flag223)
-- Is_Discrim_SO_Function (Flag176)
-- Is_Discriminant_Check_Function (Flag264)
-- Is_Dispatch_Table_Entity (Flag234)
@@ -5418,7 +5539,7 @@ package Einfo is
-- The following list of access functions applies to all entities for
-- types and subtypes. References to this list appear subsequently as
- -- as "(plus type attributes)" for each appropriate Entity_Kind.
+ -- "(plus type attributes)" for each appropriate Entity_Kind.
-- Associated_Node_For_Itype (Node8)
-- Class_Wide_Type (Node9)
@@ -5429,7 +5550,7 @@ package Einfo is
-- Pending_Access_Types (Elist15)
-- Related_Expression (Node24)
-- Current_Use_Clause (Node27)
- -- Subprograms_For_Type (Node29)
+ -- Subprograms_For_Type (Elist29)
-- Derived_Type_Link (Node31)
-- No_Tagged_Streams_Pragma (Node32)
-- Linker_Section_Pragma (Node33)
@@ -5447,16 +5568,17 @@ package Einfo is
-- Has_Constrained_Partial_View (Flag187)
-- Has_Controlled_Component (Flag43) (base type only)
-- Has_Default_Aspect (Flag39) (base type only)
- -- Has_Default_Init_Cond (Flag3) (base type only)
-- Has_Delayed_Rep_Aspects (Flag261)
-- Has_Discriminants (Flag5)
-- Has_Dynamic_Predicate_Aspect (Flag258)
-- Has_Independent_Components (Flag34) (base type only)
- -- Has_Inheritable_Invariants (Flag248)
- -- Has_Inherited_Default_Init_Cond (Flag133) (base type only)
- -- Has_Invariants (Flag232)
+ -- Has_Inheritable_Invariants (Flag248) (base type only)
+ -- Has_Inherited_DIC (Flag133) (base type only)
+ -- Has_Inherited_Invariants (Flag291) (base type only)
-- Has_Non_Standard_Rep (Flag75) (base type only)
-- Has_Object_Size_Clause (Flag172)
+ -- Has_Own_DIC (Flag3) (base type only)
+ -- Has_Own_Invariants (Flag232) (base type only)
-- Has_Pragma_Preelab_Init (Flag221)
-- Has_Pragma_Unreferenced_Objects (Flag212)
-- Has_Predicates (Flag250)
@@ -5471,6 +5593,7 @@ package Einfo is
-- Has_Static_Predicate (Flag269)
-- Has_Static_Predicate_Aspect (Flag259)
-- Has_Task (Flag30) (base type only)
+ -- Has_Timing_Event (Flag289) (base type only)
-- Has_Unchecked_Union (Flag123) (base type only)
-- Has_Volatile_Components (Flag87) (base type only)
-- In_Use (Flag8)
@@ -5508,12 +5631,15 @@ package Einfo is
-- Alignment_Clause (synth)
-- Base_Type (synth)
- -- Default_Init_Cond_Procedure (synth)
+ -- DIC_Procedure (synth)
+ -- Has_DIC (synth)
+ -- Has_Invariants (synth)
-- Implementation_Base_Type (synth)
-- Invariant_Procedure (synth)
-- Is_Access_Protected_Subprogram_Type (synth)
-- Is_Atomic_Or_VFA (synth)
-- Is_Controlled_Active (synth)
+ -- Partial_Invariant_Procedure (synth)
-- Predicate_Function (synth)
-- Predicate_Function_M (synth)
-- Root_Type (synth)
@@ -5530,6 +5656,7 @@ package Einfo is
-- Non_Limited_View (Node19)
-- Encapsulating_State (Node32)
-- From_Limited_With (Flag159)
+ -- Has_Partial_Visible_Refinement (Flag296)
-- Has_Visible_Refinement (Flag263)
-- Has_Non_Limited_View (synth)
-- Has_Non_Null_Visible_Refinement (synth)
@@ -5537,6 +5664,7 @@ package Einfo is
-- Is_External_State (synth)
-- Is_Null_State (synth)
-- Is_Synchronized_State (synth)
+ -- Partial_Refinement_Constituents (synth)
-- E_Access_Protected_Subprogram_Type
-- Equivalent_Type (Node18)
@@ -5622,6 +5750,7 @@ package Einfo is
-- Discard_Names (Flag88)
-- Has_Master_Entity (Flag21)
-- Has_Nested_Block_With_Handler (Flag101)
+ -- Is_Exception_Handler (Flag286)
-- Sec_Stack_Needed_For_Return (Flag167)
-- Uses_Sec_Stack (Flag95)
-- Scope_Depth (synth)
@@ -5632,8 +5761,8 @@ package Einfo is
-- Cloned_Subtype (Node16) (subtype case only)
-- First_Entity (Node17)
-- Equivalent_Type (Node18) (always Empty for type)
- -- Last_Entity (Node20)
-- Non_Limited_View (Node19)
+ -- Last_Entity (Node20)
-- SSO_Set_High_By_Default (Flag273) (base type only)
-- SSO_Set_Low_By_Default (Flag272) (base type only)
-- First_Component (synth)
@@ -5702,8 +5831,9 @@ package Einfo is
-- Has_Volatile_Components (Flag87)
-- Is_Atomic (Flag85)
-- Is_Eliminated (Flag124)
+ -- Is_Finalized_Transient (Flag252)
+ -- Is_Ignored_Transient (Flag295)
-- Is_Independent (Flag268)
- -- Is_Processed_Transient (Flag252) (constants only)
-- Is_Return_Object (Flag209)
-- Is_True_Constant (Flag163)
-- Is_Uplevel_Referenced_Entity (Flag283)
@@ -5777,6 +5907,7 @@ package Einfo is
-- Sec_Stack_Needed_For_Return (Flag167)
-- Has_Expanded_Contract (Flag240)
-- SPARK_Pragma_Inherited (Flag265) (protected kind)
+ -- Is_Entry_Wrapper (Flag297)
-- Address_Clause (synth)
-- Entry_Index_Type (synth)
-- First_Formal (synth)
@@ -5876,16 +6007,17 @@ package Einfo is
-- Overridden_Operation (Node26)
-- Wrapped_Entity (Node27) (non-generic case only)
-- Extra_Formals (Node28)
- -- Subprograms_For_Type (Node29)
+ -- Anonymous_Masters (Elist29) (non-generic case only)
-- Corresponding_Equality (Node30) (implicit /= only)
-- Thunk_Entity (Node31) (thunk case only)
+ -- Corresponding_Procedure (Node32) (generate C code only)
-- Linker_Section_Pragma (Node33)
-- Contract (Node34)
-- Import_Pragma (Node35) (non-generic case only)
- -- Anonymous_Master (Node36) (non-generic case only)
-- Class_Wide_Preconds (List38)
-- Class_Wide_Postconds (List39)
-- SPARK_Pragma (Node40)
+ -- Original_Protected_Subprogram (Node41)
-- Body_Needed_For_SAL (Flag40)
-- Contains_Ignored_Ghost_Code (Flag279)
-- Default_Expressions_Processed (Flag108)
@@ -5896,7 +6028,6 @@ package Einfo is
-- Has_Completion (Flag26)
-- Has_Controlling_Result (Flag98)
-- Has_Expanded_Contract (Flag240) (non-generic case only)
- -- Has_Invariants (Flag232)
-- Has_Master_Entity (Flag21)
-- Has_Missing_Return (Flag142)
-- Has_Nested_Block_With_Handler (Flag101)
@@ -5906,6 +6037,7 @@ package Einfo is
-- Is_Abstract_Subprogram (Flag19) (non-generic case only)
-- Is_Called (Flag102) (non-generic case only)
-- Is_Constructor (Flag76)
+ -- Is_DIC_Procedure (Flag132) (non-generic case only)
-- Is_Discrim_SO_Function (Flag176)
-- Is_Discriminant_Check_Function (Flag264)
-- Is_Eliminated (Flag124)
@@ -5916,6 +6048,7 @@ package Einfo is
-- Is_Intrinsic_Subprogram (Flag64)
-- Is_Invariant_Procedure (Flag257) (non-generic case only)
-- Is_Machine_Code_Subprogram (Flag137) (non-generic case only)
+ -- Is_Partial_Invariant_Procedure (Flag292) (non-generic case only)
-- Is_Predicate_Function (Flag255) (non-generic case only)
-- Is_Predicate_Function_M (Flag256) (non-generic case only)
-- Is_Primitive (Flag218)
@@ -5928,8 +6061,7 @@ package Einfo is
-- Requires_Overriding (Flag213) (non-generic case only)
-- Return_Present (Flag54)
-- Returns_By_Ref (Flag90)
- -- Returns_Limited_View (Flag134) (non-generic case only)
- -- Rewritten_For_C (Flag287)
+ -- Rewritten_For_C (Flag287) (generate C code only)
-- Sec_Stack_Needed_For_Return (Flag167)
-- SPARK_Pragma_Inherited (Flag265)
-- Uses_Sec_Stack (Flag95)
@@ -6049,13 +6181,11 @@ package Einfo is
-- Last_Entity (Node20)
-- Subps_Index (Uint24)
-- Overridden_Operation (Node26)
- -- Subprograms_For_Type (Node29)
-- Linker_Section_Pragma (Node33)
-- Contract (Node34)
-- Import_Pragma (Node35)
-- SPARK_Pragma (Node40)
-- Default_Expressions_Processed (Flag108)
- -- Has_Invariants (Flag232)
-- Has_Nested_Subprogram (Flag282)
-- Is_Intrinsic_Subprogram (Flag64)
-- Is_Machine_Code_Subprogram (Flag137)
@@ -6103,8 +6233,8 @@ package Einfo is
-- Package_Instantiation (Node26)
-- Current_Use_Clause (Node27)
-- Finalizer (Node28) (non-generic case only)
+ -- Anonymous_Masters (Elist29) (non-generic case only)
-- Contract (Node34)
- -- Anonymous_Master (Node36) (non-generic case only)
-- SPARK_Pragma (Node40)
-- SPARK_Aux_Pragma (Node41)
-- Delay_Subprogram_Descriptors (Flag50)
@@ -6128,6 +6258,7 @@ package Einfo is
-- SPARK_Aux_Pragma_Inherited (Flag266)
-- SPARK_Pragma_Inherited (Flag265)
-- Static_Elaboration_Desired (Flag77) (non-generic case only)
+ -- Has_Non_Null_Abstract_State (synth)
-- Has_Null_Abstract_State (synth)
-- Is_Wrapper_Package (synth) (non-generic case only)
-- Scope_Depth (synth)
@@ -6141,7 +6272,6 @@ package Einfo is
-- Scope_Depth_Value (Uint22)
-- Finalizer (Node28) (non-generic case only)
-- Contract (Node34)
- -- Anonymous_Master (Node36)
-- SPARK_Pragma (Node40)
-- SPARK_Aux_Pragma (Node41)
-- Contains_Ignored_Ghost_Code (Flag279)
@@ -6189,15 +6319,17 @@ package Einfo is
-- Overridden_Operation (Node26) (never for init proc)
-- Wrapped_Entity (Node27) (non-generic case only)
-- Extra_Formals (Node28)
+ -- Anonymous_Masters (Elist29) (non-generic case only)
-- Static_Initialization (Node30) (init_proc only)
-- Thunk_Entity (Node31) (thunk case only)
+ -- Corresponding_Function (Node32) (generate C code only)
-- Linker_Section_Pragma (Node33)
-- Contract (Node34)
-- Import_Pragma (Node35) (non-generic case only)
- -- Anonymous_Master (Node36) (non-generic case only)
-- Class_Wide_Preconds (List38)
-- Class_Wide_Postconds (List39)
-- SPARK_Pragma (Node40)
+ -- Original_Protected_Subprogram (Node41)
-- Body_Needed_For_SAL (Flag40)
-- Contains_Ignored_Ghost_Code (Flag279)
-- Delay_Cleanups (Flag114)
@@ -6209,7 +6341,6 @@ package Einfo is
-- Discard_Names (Flag88)
-- Has_Completion (Flag26)
-- Has_Expanded_Contract (Flag240) (non-generic case only)
- -- Has_Invariants (Flag232)
-- Has_Master_Entity (Flag21)
-- Has_Nested_Block_With_Handler (Flag101)
-- Has_Nested_Subprogram (Flag282)
@@ -6217,7 +6348,7 @@ package Einfo is
-- Is_Asynchronous (Flag81)
-- Is_Called (Flag102) (non-generic case only)
-- Is_Constructor (Flag76)
- -- Is_Default_Init_Cond_Procedure (Flag132) (non-generic case only)
+ -- Is_DIC_Procedure (Flag132) (non-generic case only)
-- Is_Eliminated (Flag124)
-- Is_Generic_Actual_Subprogram (Flag274) (non-generic case only)
-- Is_Hidden_Non_Overridden_Subpgm (Flag2) (non-generic case only)
@@ -6228,6 +6359,7 @@ package Einfo is
-- Is_Invariant_Procedure (Flag257) (non-generic case only)
-- Is_Machine_Code_Subprogram (Flag137) (non-generic case only)
-- Is_Null_Init_Proc (Flag178)
+ -- Is_Partial_Invariant_Procedure (Flag292) (non-generic case only)
-- Is_Predicate_Function (Flag255) (non-generic case only)
-- Is_Predicate_Function_M (Flag256) (non-generic case only)
-- Is_Primitive (Flag218)
@@ -6269,6 +6401,7 @@ package Einfo is
-- Stored_Constraint (Elist23)
-- Anonymous_Object (Node30)
-- Contract (Node34)
+ -- Entry_Max_Queue_Lengths_Array (Node35)
-- SPARK_Pragma (Node40)
-- SPARK_Aux_Pragma (Node41)
-- Sec_Stack_Needed_For_Return (Flag167) ???
@@ -6379,8 +6512,8 @@ package Einfo is
-- Last_Entity (Node20)
-- Scope_Depth_Value (Uint22)
-- Extra_Formals (Node28)
+ -- Anonymous_Masters (Elist29)
-- Contract (Node34)
- -- Anonymous_Master (Node36)
-- SPARK_Pragma (Node40)
-- Contains_Ignored_Ghost_Code (Flag279)
-- SPARK_Pragma_Inherited (Flag265)
@@ -6461,6 +6594,7 @@ package Einfo is
-- Encapsulating_State (Node32)
-- Linker_Section_Pragma (Node33)
-- Contract (Node34)
+ -- Anonymous_Designated_Type (Node35)
-- SPARK_Pragma (Node40)
-- Has_Alignment_Clause (Flag46)
-- Has_Atomic_Components (Flag86)
@@ -6471,8 +6605,9 @@ package Einfo is
-- Has_Volatile_Components (Flag87)
-- Is_Atomic (Flag85)
-- Is_Eliminated (Flag124)
+ -- Is_Finalized_Transient (Flag252)
+ -- Is_Ignored_Transient (Flag295)
-- Is_Independent (Flag268)
- -- Is_Processed_Transient (Flag252)
-- Is_Return_Object (Flag209)
-- Is_Safe_To_Reevaluate (Flag249)
-- Is_Shared_Passive (Flag60)
@@ -6733,7 +6868,8 @@ package Einfo is
function Address_Taken (Id : E) return B;
function Alias (Id : E) return E;
function Alignment (Id : E) return U;
- function Anonymous_Master (Id : E) return E;
+ function Anonymous_Designated_Type (Id : E) return E;
+ function Anonymous_Masters (Id : E) return L;
function Anonymous_Object (Id : E) return E;
function Associated_Entity (Id : E) return E;
function Associated_Formal_Package (Id : E) return E;
@@ -6764,6 +6900,8 @@ package Einfo is
function Corresponding_Concurrent_Type (Id : E) return E;
function Corresponding_Discriminant (Id : E) return E;
function Corresponding_Equality (Id : E) return E;
+ function Corresponding_Function (Id : E) return E;
+ function Corresponding_Procedure (Id : E) return E;
function Corresponding_Protected_Entry (Id : E) return E;
function Corresponding_Record_Type (Id : E) return E;
function Corresponding_Remote_Type (Id : E) return E;
@@ -6811,6 +6949,7 @@ package Einfo is
function Entry_Formal (Id : E) return E;
function Entry_Index_Constant (Id : E) return E;
function Entry_Index_Type (Id : E) return E;
+ function Entry_Max_Queue_Lengths_Array (Id : E) return E;
function Entry_Parameters_Type (Id : E) return E;
function Enum_Pos_To_Rep (Id : E) return E;
function Enumeration_Pos (Id : E) return U;
@@ -6854,10 +6993,10 @@ package Einfo is
function Has_Controlling_Result (Id : E) return B;
function Has_Convention_Pragma (Id : E) return B;
function Has_Default_Aspect (Id : E) return B;
- function Has_Default_Init_Cond (Id : E) return B;
function Has_Delayed_Aspects (Id : E) return B;
function Has_Delayed_Freeze (Id : E) return B;
function Has_Delayed_Rep_Aspects (Id : E) return B;
+ function Has_DIC (Id : E) return B;
function Has_Discriminants (Id : E) return B;
function Has_Dispatch_Table (Id : E) return B;
function Has_Dynamic_Predicate_Aspect (Id : E) return B;
@@ -6871,7 +7010,8 @@ package Einfo is
function Has_Implicit_Dereference (Id : E) return B;
function Has_Independent_Components (Id : E) return B;
function Has_Inheritable_Invariants (Id : E) return B;
- function Has_Inherited_Default_Init_Cond (Id : E) return B;
+ function Has_Inherited_DIC (Id : E) return B;
+ function Has_Inherited_Invariants (Id : E) return B;
function Has_Initial_Value (Id : E) return B;
function Has_Interrupt_Handler (Id : E) return B;
function Has_Invariants (Id : E) return B;
@@ -6884,6 +7024,9 @@ package Einfo is
function Has_Non_Standard_Rep (Id : E) return B;
function Has_Object_Size_Clause (Id : E) return B;
function Has_Out_Or_In_Out_Parameter (Id : E) return B;
+ function Has_Own_DIC (Id : E) return B;
+ function Has_Own_Invariants (Id : E) return B;
+ function Has_Partial_Visible_Refinement (Id : E) return B;
function Has_Per_Object_Constraint (Id : E) return B;
function Has_Pragma_Controlled (Id : E) return B;
function Has_Pragma_Elaborate_Body (Id : E) return B;
@@ -6899,6 +7042,7 @@ package Einfo is
function Has_Pragma_Unmodified (Id : E) return B;
function Has_Pragma_Unreferenced (Id : E) return B;
function Has_Pragma_Unreferenced_Objects (Id : E) return B;
+ function Has_Pragma_Unused (Id : E) return B;
function Has_Predicates (Id : E) return B;
function Has_Primitive_Operations (Id : E) return B;
function Has_Private_Ancestor (Id : E) return B;
@@ -6922,6 +7066,7 @@ package Einfo is
function Has_Storage_Size_Clause (Id : E) return B;
function Has_Stream_Size_Clause (Id : E) return B;
function Has_Task (Id : E) return B;
+ function Has_Timing_Event (Id : E) return B;
function Has_Thunks (Id : E) return B;
function Has_Unchecked_Union (Id : E) return B;
function Has_Unknown_Discriminants (Id : E) return B;
@@ -6943,6 +7088,7 @@ package Einfo is
function Is_Abstract_Subprogram (Id : E) return B;
function Is_Abstract_Type (Id : E) return B;
function Is_Access_Constant (Id : E) return B;
+ function Is_Actual_Subtype (Id : E) return B;
function Is_Ada_2005_Only (Id : E) return B;
function Is_Ada_2012_Only (Id : E) return B;
function Is_Aliased (Id : E) return B;
@@ -6964,15 +7110,18 @@ package Einfo is
function Is_Controlled (Id : E) return B;
function Is_Controlling_Formal (Id : E) return B;
function Is_CPP_Class (Id : E) return B;
- function Is_Default_Init_Cond_Procedure (Id : E) return B;
- function Is_Descendent_Of_Address (Id : E) return B;
+ function Is_Descendant_Of_Address (Id : E) return B;
+ function Is_DIC_Procedure (Id : E) return B;
function Is_Discrim_SO_Function (Id : E) return B;
function Is_Discriminant_Check_Function (Id : E) return B;
function Is_Dispatch_Table_Entity (Id : E) return B;
function Is_Dispatching_Operation (Id : E) return B;
function Is_Eliminated (Id : E) return B;
function Is_Entry_Formal (Id : E) return B;
+ function Is_Entry_Wrapper (Id : E) return B;
+ function Is_Exception_Handler (Id : E) return B;
function Is_Exported (Id : E) return B;
+ function Is_Finalized_Transient (Id : E) return B;
function Is_First_Subtype (Id : E) return B;
function Is_For_Access_Subtype (Id : E) return B;
function Is_Frozen (Id : E) return B;
@@ -6981,6 +7130,7 @@ package Einfo is
function Is_Hidden_Non_Overridden_Subpgm (Id : E) return B;
function Is_Hidden_Open_Scope (Id : E) return B;
function Is_Ignored_Ghost_Entity (Id : E) return B;
+ function Is_Ignored_Transient (Id : E) return B;
function Is_Immediately_Visible (Id : E) return B;
function Is_Implementation_Defined (Id : E) return B;
function Is_Imported (Id : E) return B;
@@ -7010,6 +7160,7 @@ package Einfo is
function Is_Packed_Array_Impl_Type (Id : E) return B;
function Is_Potentially_Use_Visible (Id : E) return B;
function Is_Param_Block_Component_Type (Id : E) return B;
+ function Is_Partial_Invariant_Procedure (Id : E) return B;
function Is_Predicate_Function (Id : E) return B;
function Is_Predicate_Function_M (Id : E) return B;
function Is_Preelaborated (Id : E) return B;
@@ -7018,7 +7169,6 @@ package Einfo is
function Is_Private_Composite (Id : E) return B;
function Is_Private_Descendant (Id : E) return B;
function Is_Private_Primitive (Id : E) return B;
- function Is_Processed_Transient (Id : E) return B;
function Is_Public (Id : E) return B;
function Is_Pure (Id : E) return B;
function Is_Pure_Unit_Access_Type (Id : E) return B;
@@ -7038,6 +7188,7 @@ package Einfo is
function Is_Trivial_Subprogram (Id : E) return B;
function Is_True_Constant (Id : E) return B;
function Is_Unchecked_Union (Id : E) return B;
+ function Is_Underlying_Full_View (Id : E) return B;
function Is_Underlying_Record_View (Id : E) return B;
function Is_Unimplemented (Id : E) return B;
function Is_Unsigned_Type (Id : E) return B;
@@ -7089,6 +7240,7 @@ package Einfo is
function Optimize_Alignment_Time (Id : E) return B;
function Original_Access_Type (Id : E) return E;
function Original_Array_Type (Id : E) return E;
+ function Original_Protected_Subprogram (Id : E) return N;
function Original_Record_Component (Id : E) return E;
function Overlays_Constant (Id : E) return B;
function Overridden_Operation (Id : E) return E;
@@ -7100,6 +7252,7 @@ package Einfo is
function Partial_View_Has_Unknown_Discr (Id : E) return B;
function Pending_Access_Types (Id : E) return L;
function Postconditions_Proc (Id : E) return E;
+ function Predicates_Ignored (Id : E) return B;
function Prival (Id : E) return E;
function Prival_Link (Id : E) return E;
function Private_Dependents (Id : E) return L;
@@ -7126,7 +7279,6 @@ package Einfo is
function Return_Applies_To (Id : E) return N;
function Return_Present (Id : E) return B;
function Returns_By_Ref (Id : E) return B;
- function Returns_Limited_View (Id : E) return B;
function Reverse_Bit_Order (Id : E) return B;
function Reverse_Storage_Order (Id : E) return B;
function Rewritten_For_C (Id : E) return B;
@@ -7159,7 +7311,7 @@ package Einfo is
function Strict_Alignment (Id : E) return B;
function String_Literal_Length (Id : E) return U;
function String_Literal_Low_Bound (Id : E) return N;
- function Subprograms_For_Type (Id : E) return E;
+ function Subprograms_For_Type (Id : E) return L;
function Subps_Index (Id : E) return U;
function Suppress_Elaboration_Warnings (Id : E) return B;
function Suppress_Initialization (Id : E) return B;
@@ -7264,6 +7416,7 @@ package Einfo is
function Has_Entries (Id : E) return B;
function Has_Foreign_Convention (Id : E) return B;
function Has_Non_Limited_View (Id : E) return B;
+ function Has_Non_Null_Abstract_State (Id : E) return B;
function Has_Non_Null_Visible_Refinement (Id : E) return B;
function Has_Null_Abstract_State (Id : E) return B;
function Has_Null_Visible_Refinement (Id : E) return B;
@@ -7311,6 +7464,7 @@ package Einfo is
function Number_Entries (Id : E) return Nat;
function Number_Formals (Id : E) return Pos;
function Parameter_Mode (Id : E) return Formal_Kind;
+ function Partial_Refinement_Constituents (Id : E) return L;
function Primitive_Operations (Id : E) return L;
function Root_Type (Id : E) return E;
function Safe_Emax_Value (Id : E) return U;
@@ -7398,7 +7552,8 @@ package Einfo is
procedure Set_Address_Taken (Id : E; V : B := True);
procedure Set_Alias (Id : E; V : E);
procedure Set_Alignment (Id : E; V : U);
- procedure Set_Anonymous_Master (Id : E; V : E);
+ procedure Set_Anonymous_Designated_Type (Id : E; V : E);
+ procedure Set_Anonymous_Masters (Id : E; V : L);
procedure Set_Anonymous_Object (Id : E; V : E);
procedure Set_Associated_Entity (Id : E; V : E);
procedure Set_Associated_Formal_Package (Id : E; V : E);
@@ -7429,6 +7584,8 @@ package Einfo is
procedure Set_Corresponding_Concurrent_Type (Id : E; V : E);
procedure Set_Corresponding_Discriminant (Id : E; V : E);
procedure Set_Corresponding_Equality (Id : E; V : E);
+ procedure Set_Corresponding_Function (Id : E; V : E);
+ procedure Set_Corresponding_Procedure (Id : E; V : E);
procedure Set_Corresponding_Protected_Entry (Id : E; V : E);
procedure Set_Corresponding_Record_Type (Id : E; V : E);
procedure Set_Corresponding_Remote_Type (Id : E; V : E);
@@ -7449,6 +7606,7 @@ package Einfo is
procedure Set_Depends_On_Private (Id : E; V : B := True);
procedure Set_Derived_Type_Link (Id : E; V : E);
procedure Set_Digits_Value (Id : E; V : U);
+ procedure Set_Predicates_Ignored (Id : E; V : B);
procedure Set_Direct_Primitive_Operations (Id : E; V : L);
procedure Set_Directly_Designated_Type (Id : E; V : E);
procedure Set_Disable_Controlled (Id : E; V : B := True);
@@ -7475,6 +7633,7 @@ package Einfo is
procedure Set_Entry_Component (Id : E; V : E);
procedure Set_Entry_Formal (Id : E; V : E);
procedure Set_Entry_Index_Constant (Id : E; V : E);
+ procedure Set_Entry_Max_Queue_Lengths_Array (Id : E; V : E);
procedure Set_Entry_Parameters_Type (Id : E; V : E);
procedure Set_Enum_Pos_To_Rep (Id : E; V : E);
procedure Set_Enumeration_Pos (Id : E; V : U);
@@ -7518,7 +7677,6 @@ package Einfo is
procedure Set_Has_Controlling_Result (Id : E; V : B := True);
procedure Set_Has_Convention_Pragma (Id : E; V : B := True);
procedure Set_Has_Default_Aspect (Id : E; V : B := True);
- procedure Set_Has_Default_Init_Cond (Id : E; V : B := True);
procedure Set_Has_Delayed_Aspects (Id : E; V : B := True);
procedure Set_Has_Delayed_Freeze (Id : E; V : B := True);
procedure Set_Has_Delayed_Rep_Aspects (Id : E; V : B := True);
@@ -7535,9 +7693,9 @@ package Einfo is
procedure Set_Has_Implicit_Dereference (Id : E; V : B := True);
procedure Set_Has_Independent_Components (Id : E; V : B := True);
procedure Set_Has_Inheritable_Invariants (Id : E; V : B := True);
- procedure Set_Has_Inherited_Default_Init_Cond (Id : E; V : B := True);
+ procedure Set_Has_Inherited_DIC (Id : E; V : B := True);
+ procedure Set_Has_Inherited_Invariants (Id : E; V : B := True);
procedure Set_Has_Initial_Value (Id : E; V : B := True);
- procedure Set_Has_Invariants (Id : E; V : B := True);
procedure Set_Has_Loop_Entry_Attributes (Id : E; V : B := True);
procedure Set_Has_Machine_Radix_Clause (Id : E; V : B := True);
procedure Set_Has_Master_Entity (Id : E; V : B := True);
@@ -7547,6 +7705,9 @@ package Einfo is
procedure Set_Has_Non_Standard_Rep (Id : E; V : B := True);
procedure Set_Has_Object_Size_Clause (Id : E; V : B := True);
procedure Set_Has_Out_Or_In_Out_Parameter (Id : E; V : B := True);
+ procedure Set_Has_Own_DIC (Id : E; V : B := True);
+ procedure Set_Has_Own_Invariants (Id : E; V : B := True);
+ procedure Set_Has_Partial_Visible_Refinement (Id : E; V : B := True);
procedure Set_Has_Per_Object_Constraint (Id : E; V : B := True);
procedure Set_Has_Pragma_Controlled (Id : E; V : B := True);
procedure Set_Has_Pragma_Elaborate_Body (Id : E; V : B := True);
@@ -7562,6 +7723,7 @@ package Einfo is
procedure Set_Has_Pragma_Unmodified (Id : E; V : B := True);
procedure Set_Has_Pragma_Unreferenced (Id : E; V : B := True);
procedure Set_Has_Pragma_Unreferenced_Objects (Id : E; V : B := True);
+ procedure Set_Has_Pragma_Unused (Id : E; V : B := True);
procedure Set_Has_Predicates (Id : E; V : B := True);
procedure Set_Has_Primitive_Operations (Id : E; V : B := True);
procedure Set_Has_Private_Ancestor (Id : E; V : B := True);
@@ -7585,6 +7747,7 @@ package Einfo is
procedure Set_Has_Storage_Size_Clause (Id : E; V : B := True);
procedure Set_Has_Stream_Size_Clause (Id : E; V : B := True);
procedure Set_Has_Task (Id : E; V : B := True);
+ procedure Set_Has_Timing_Event (Id : E; V : B := True);
procedure Set_Has_Thunks (Id : E; V : B := True);
procedure Set_Has_Unchecked_Union (Id : E; V : B := True);
procedure Set_Has_Unknown_Discriminants (Id : E; V : B := True);
@@ -7606,6 +7769,7 @@ package Einfo is
procedure Set_Is_Abstract_Subprogram (Id : E; V : B := True);
procedure Set_Is_Abstract_Type (Id : E; V : B := True);
procedure Set_Is_Access_Constant (Id : E; V : B := True);
+ procedure Set_Is_Actual_Subtype (Id : E; V : B := True);
procedure Set_Is_Ada_2005_Only (Id : E; V : B := True);
procedure Set_Is_Ada_2012_Only (Id : E; V : B := True);
procedure Set_Is_Aliased (Id : E; V : B := True);
@@ -7627,15 +7791,18 @@ package Einfo is
procedure Set_Is_Controlled (Id : E; V : B := True);
procedure Set_Is_Controlling_Formal (Id : E; V : B := True);
procedure Set_Is_CPP_Class (Id : E; V : B := True);
- procedure Set_Is_Default_Init_Cond_Procedure (Id : E; V : B := True);
- procedure Set_Is_Descendent_Of_Address (Id : E; V : B := True);
+ procedure Set_Is_Descendant_Of_Address (Id : E; V : B := True);
+ procedure Set_Is_DIC_Procedure (Id : E; V : B := True);
procedure Set_Is_Discrim_SO_Function (Id : E; V : B := True);
procedure Set_Is_Discriminant_Check_Function (Id : E; V : B := True);
procedure Set_Is_Dispatch_Table_Entity (Id : E; V : B := True);
procedure Set_Is_Dispatching_Operation (Id : E; V : B := True);
procedure Set_Is_Eliminated (Id : E; V : B := True);
procedure Set_Is_Entry_Formal (Id : E; V : B := True);
+ procedure Set_Is_Entry_Wrapper (Id : E; V : B := True);
+ procedure Set_Is_Exception_Handler (Id : E; V : B := True);
procedure Set_Is_Exported (Id : E; V : B := True);
+ procedure Set_Is_Finalized_Transient (Id : E; V : B := True);
procedure Set_Is_First_Subtype (Id : E; V : B := True);
procedure Set_Is_For_Access_Subtype (Id : E; V : B := True);
procedure Set_Is_Formal_Subprogram (Id : E; V : B := True);
@@ -7648,6 +7815,7 @@ package Einfo is
procedure Set_Is_Hidden_Non_Overridden_Subpgm (Id : E; V : B := True);
procedure Set_Is_Hidden_Open_Scope (Id : E; V : B := True);
procedure Set_Is_Ignored_Ghost_Entity (Id : E; V : B := True);
+ procedure Set_Is_Ignored_Transient (Id : E; V : B := True);
procedure Set_Is_Immediately_Visible (Id : E; V : B := True);
procedure Set_Is_Implementation_Defined (Id : E; V : B := True);
procedure Set_Is_Imported (Id : E; V : B := True);
@@ -7677,6 +7845,7 @@ package Einfo is
procedure Set_Is_Packed (Id : E; V : B := True);
procedure Set_Is_Packed_Array_Impl_Type (Id : E; V : B := True);
procedure Set_Is_Param_Block_Component_Type (Id : E; V : B := True);
+ procedure Set_Is_Partial_Invariant_Procedure (Id : E; V : B := True);
procedure Set_Is_Potentially_Use_Visible (Id : E; V : B := True);
procedure Set_Is_Predicate_Function (Id : E; V : B := True);
procedure Set_Is_Predicate_Function_M (Id : E; V : B := True);
@@ -7686,7 +7855,6 @@ package Einfo is
procedure Set_Is_Private_Composite (Id : E; V : B := True);
procedure Set_Is_Private_Descendant (Id : E; V : B := True);
procedure Set_Is_Private_Primitive (Id : E; V : B := True);
- procedure Set_Is_Processed_Transient (Id : E; V : B := True);
procedure Set_Is_Public (Id : E; V : B := True);
procedure Set_Is_Pure (Id : E; V : B := True);
procedure Set_Is_Pure_Unit_Access_Type (Id : E; V : B := True);
@@ -7706,6 +7874,7 @@ package Einfo is
procedure Set_Is_Trivial_Subprogram (Id : E; V : B := True);
procedure Set_Is_True_Constant (Id : E; V : B := True);
procedure Set_Is_Unchecked_Union (Id : E; V : B := True);
+ procedure Set_Is_Underlying_Full_View (Id : E; V : B := True);
procedure Set_Is_Underlying_Record_View (Id : E; V : B := True);
procedure Set_Is_Unimplemented (Id : E; V : B := True);
procedure Set_Is_Unsigned_Type (Id : E; V : B := True);
@@ -7757,6 +7926,7 @@ package Einfo is
procedure Set_Optimize_Alignment_Time (Id : E; V : B := True);
procedure Set_Original_Access_Type (Id : E; V : E);
procedure Set_Original_Array_Type (Id : E; V : E);
+ procedure Set_Original_Protected_Subprogram (Id : E; V : N);
procedure Set_Original_Record_Component (Id : E; V : E);
procedure Set_Overlays_Constant (Id : E; V : B := True);
procedure Set_Overridden_Operation (Id : E; V : E);
@@ -7794,7 +7964,6 @@ package Einfo is
procedure Set_Return_Applies_To (Id : E; V : N);
procedure Set_Return_Present (Id : E; V : B := True);
procedure Set_Returns_By_Ref (Id : E; V : B := True);
- procedure Set_Returns_Limited_View (Id : E; V : B := True);
procedure Set_Reverse_Bit_Order (Id : E; V : B := True);
procedure Set_Reverse_Storage_Order (Id : E; V : B := True);
procedure Set_Rewritten_For_C (Id : E; V : B := True);
@@ -7827,7 +7996,7 @@ package Einfo is
procedure Set_Strict_Alignment (Id : E; V : B := True);
procedure Set_String_Literal_Length (Id : E; V : U);
procedure Set_String_Literal_Low_Bound (Id : E; V : N);
- procedure Set_Subprograms_For_Type (Id : E; V : E);
+ procedure Set_Subprograms_For_Type (Id : E; V : L);
procedure Set_Subps_Index (Id : E; V : U);
procedure Set_Suppress_Elaboration_Warnings (Id : E; V : B := True);
procedure Set_Suppress_Initialization (Id : E; V : B := True);
@@ -7854,15 +8023,17 @@ package Einfo is
-- Access to Subprograms in Subprograms_For_Type --
---------------------------------------------------
- function Default_Init_Cond_Procedure (Id : E) return E;
- function Invariant_Procedure (Id : E) return E;
- function Predicate_Function (Id : E) return E;
- function Predicate_Function_M (Id : E) return E;
+ function DIC_Procedure (Id : E) return E;
+ function Invariant_Procedure (Id : E) return E;
+ function Partial_Invariant_Procedure (Id : E) return E;
+ function Predicate_Function (Id : E) return E;
+ function Predicate_Function_M (Id : E) return E;
- procedure Set_Default_Init_Cond_Procedure (Id : E; V : E);
- procedure Set_Invariant_Procedure (Id : E; V : E);
- procedure Set_Predicate_Function (Id : E; V : E);
- procedure Set_Predicate_Function_M (Id : E; V : E);
+ procedure Set_DIC_Procedure (Id : E; V : E);
+ procedure Set_Invariant_Procedure (Id : E; V : E);
+ procedure Set_Partial_Invariant_Procedure (Id : E; V : E);
+ procedure Set_Predicate_Function (Id : E; V : E);
+ procedure Set_Predicate_Function_M (Id : E; V : E);
-----------------------------------
-- Field Initialization Routines --
@@ -8183,7 +8354,8 @@ package Einfo is
pragma Inline (Address_Taken);
pragma Inline (Alias);
pragma Inline (Alignment);
- pragma Inline (Anonymous_Master);
+ pragma Inline (Anonymous_Designated_Type);
+ pragma Inline (Anonymous_Masters);
pragma Inline (Anonymous_Object);
pragma Inline (Associated_Entity);
pragma Inline (Associated_Formal_Package);
@@ -8301,7 +8473,6 @@ package Einfo is
pragma Inline (Has_Controlling_Result);
pragma Inline (Has_Convention_Pragma);
pragma Inline (Has_Default_Aspect);
- pragma Inline (Has_Default_Init_Cond);
pragma Inline (Has_Delayed_Aspects);
pragma Inline (Has_Delayed_Freeze);
pragma Inline (Has_Delayed_Rep_Aspects);
@@ -8318,9 +8489,9 @@ package Einfo is
pragma Inline (Has_Implicit_Dereference);
pragma Inline (Has_Independent_Components);
pragma Inline (Has_Inheritable_Invariants);
- pragma Inline (Has_Inherited_Default_Init_Cond);
+ pragma Inline (Has_Inherited_DIC);
+ pragma Inline (Has_Inherited_Invariants);
pragma Inline (Has_Initial_Value);
- pragma Inline (Has_Invariants);
pragma Inline (Has_Loop_Entry_Attributes);
pragma Inline (Has_Machine_Radix_Clause);
pragma Inline (Has_Master_Entity);
@@ -8330,6 +8501,9 @@ package Einfo is
pragma Inline (Has_Non_Standard_Rep);
pragma Inline (Has_Object_Size_Clause);
pragma Inline (Has_Out_Or_In_Out_Parameter);
+ pragma Inline (Has_Own_DIC);
+ pragma Inline (Has_Own_Invariants);
+ pragma Inline (Has_Partial_Visible_Refinement);
pragma Inline (Has_Per_Object_Constraint);
pragma Inline (Has_Pragma_Controlled);
pragma Inline (Has_Pragma_Elaborate_Body);
@@ -8345,6 +8519,7 @@ package Einfo is
pragma Inline (Has_Pragma_Unmodified);
pragma Inline (Has_Pragma_Unreferenced);
pragma Inline (Has_Pragma_Unreferenced_Objects);
+ pragma Inline (Has_Pragma_Unused);
pragma Inline (Has_Predicates);
pragma Inline (Has_Primitive_Operations);
pragma Inline (Has_Private_Ancestor);
@@ -8368,6 +8543,7 @@ package Einfo is
pragma Inline (Has_Storage_Size_Clause);
pragma Inline (Has_Stream_Size_Clause);
pragma Inline (Has_Task);
+ pragma Inline (Has_Timing_Event);
pragma Inline (Has_Thunks);
pragma Inline (Has_Unchecked_Union);
pragma Inline (Has_Unknown_Discriminants);
@@ -8388,6 +8564,7 @@ package Einfo is
pragma Inline (Is_Abstract_Subprogram);
pragma Inline (Is_Abstract_Type);
pragma Inline (Is_Access_Constant);
+ pragma Inline (Is_Actual_Subtype);
pragma Inline (Is_Access_Protected_Subprogram_Type);
pragma Inline (Is_Access_Subprogram_Type);
pragma Inline (Is_Access_Type);
@@ -8421,8 +8598,8 @@ package Einfo is
pragma Inline (Is_Controlling_Formal);
pragma Inline (Is_CPP_Class);
pragma Inline (Is_Decimal_Fixed_Point_Type);
- pragma Inline (Is_Default_Init_Cond_Procedure);
- pragma Inline (Is_Descendent_Of_Address);
+ pragma Inline (Is_Descendant_Of_Address);
+ pragma Inline (Is_DIC_Procedure);
pragma Inline (Is_Digits_Type);
pragma Inline (Is_Discrete_Or_Fixed_Point_Type);
pragma Inline (Is_Discrete_Type);
@@ -8434,8 +8611,11 @@ package Einfo is
pragma Inline (Is_Eliminated);
pragma Inline (Is_Entry);
pragma Inline (Is_Entry_Formal);
+ pragma Inline (Is_Entry_Wrapper);
pragma Inline (Is_Enumeration_Type);
+ pragma Inline (Is_Exception_Handler);
pragma Inline (Is_Exported);
+ pragma Inline (Is_Finalized_Transient);
pragma Inline (Is_First_Subtype);
pragma Inline (Is_Fixed_Point_Type);
pragma Inline (Is_Floating_Point_Type);
@@ -8455,6 +8635,7 @@ package Einfo is
pragma Inline (Is_Hidden_Non_Overridden_Subpgm);
pragma Inline (Is_Hidden_Open_Scope);
pragma Inline (Is_Ignored_Ghost_Entity);
+ pragma Inline (Is_Ignored_Transient);
pragma Inline (Is_Immediately_Visible);
pragma Inline (Is_Implementation_Defined);
pragma Inline (Is_Imported);
@@ -8493,6 +8674,7 @@ package Einfo is
pragma Inline (Is_Packed);
pragma Inline (Is_Packed_Array_Impl_Type);
pragma Inline (Is_Param_Block_Component_Type);
+ pragma Inline (Is_Partial_Invariant_Procedure);
pragma Inline (Is_Potentially_Use_Visible);
pragma Inline (Is_Predicate_Function);
pragma Inline (Is_Predicate_Function_M);
@@ -8503,7 +8685,6 @@ package Einfo is
pragma Inline (Is_Private_Descendant);
pragma Inline (Is_Private_Primitive);
pragma Inline (Is_Private_Type);
- pragma Inline (Is_Processed_Transient);
pragma Inline (Is_Protected_Type);
pragma Inline (Is_Public);
pragma Inline (Is_Pure);
@@ -8531,6 +8712,7 @@ package Einfo is
pragma Inline (Is_True_Constant);
pragma Inline (Is_Type);
pragma Inline (Is_Unchecked_Union);
+ pragma Inline (Is_Underlying_Full_View);
pragma Inline (Is_Underlying_Record_View);
pragma Inline (Is_Unimplemented);
pragma Inline (Is_Unsigned_Type);
@@ -8583,6 +8765,7 @@ package Einfo is
pragma Inline (Optimize_Alignment_Time);
pragma Inline (Original_Access_Type);
pragma Inline (Original_Array_Type);
+ pragma Inline (Original_Protected_Subprogram);
pragma Inline (Original_Record_Component);
pragma Inline (Overlays_Constant);
pragma Inline (Overridden_Operation);
@@ -8595,6 +8778,7 @@ package Einfo is
pragma Inline (Partial_View_Has_Unknown_Discr);
pragma Inline (Pending_Access_Types);
pragma Inline (Postconditions_Proc);
+ pragma Inline (Predicates_Ignored);
pragma Inline (Prival);
pragma Inline (Prival_Link);
pragma Inline (Private_Dependents);
@@ -8621,7 +8805,6 @@ package Einfo is
pragma Inline (Return_Applies_To);
pragma Inline (Return_Present);
pragma Inline (Returns_By_Ref);
- pragma Inline (Returns_Limited_View);
pragma Inline (Reverse_Bit_Order);
pragma Inline (Reverse_Storage_Order);
pragma Inline (Rewritten_For_C);
@@ -8692,7 +8875,8 @@ package Einfo is
pragma Inline (Set_Address_Taken);
pragma Inline (Set_Alias);
pragma Inline (Set_Alignment);
- pragma Inline (Set_Anonymous_Master);
+ pragma Inline (Set_Anonymous_Designated_Type);
+ pragma Inline (Set_Anonymous_Masters);
pragma Inline (Set_Anonymous_Object);
pragma Inline (Set_Associated_Entity);
pragma Inline (Set_Associated_Formal_Package);
@@ -8767,6 +8951,7 @@ package Einfo is
pragma Inline (Set_Entry_Cancel_Parameter);
pragma Inline (Set_Entry_Component);
pragma Inline (Set_Entry_Formal);
+ pragma Inline (Set_Entry_Max_Queue_Lengths_Array);
pragma Inline (Set_Entry_Parameters_Type);
pragma Inline (Set_Enum_Pos_To_Rep);
pragma Inline (Set_Enumeration_Pos);
@@ -8808,7 +8993,6 @@ package Einfo is
pragma Inline (Set_Has_Controlling_Result);
pragma Inline (Set_Has_Convention_Pragma);
pragma Inline (Set_Has_Default_Aspect);
- pragma Inline (Set_Has_Default_Init_Cond);
pragma Inline (Set_Has_Delayed_Aspects);
pragma Inline (Set_Has_Delayed_Freeze);
pragma Inline (Set_Has_Delayed_Rep_Aspects);
@@ -8825,9 +9009,9 @@ package Einfo is
pragma Inline (Set_Has_Implicit_Dereference);
pragma Inline (Set_Has_Independent_Components);
pragma Inline (Set_Has_Inheritable_Invariants);
- pragma Inline (Set_Has_Inherited_Default_Init_Cond);
+ pragma Inline (Set_Has_Inherited_DIC);
+ pragma Inline (Set_Has_Inherited_Invariants);
pragma Inline (Set_Has_Initial_Value);
- pragma Inline (Set_Has_Invariants);
pragma Inline (Set_Has_Loop_Entry_Attributes);
pragma Inline (Set_Has_Machine_Radix_Clause);
pragma Inline (Set_Has_Master_Entity);
@@ -8837,6 +9021,9 @@ package Einfo is
pragma Inline (Set_Has_Non_Standard_Rep);
pragma Inline (Set_Has_Object_Size_Clause);
pragma Inline (Set_Has_Out_Or_In_Out_Parameter);
+ pragma Inline (Set_Has_Own_DIC);
+ pragma Inline (Set_Has_Own_Invariants);
+ pragma Inline (Set_Has_Partial_Visible_Refinement);
pragma Inline (Set_Has_Per_Object_Constraint);
pragma Inline (Set_Has_Pragma_Controlled);
pragma Inline (Set_Has_Pragma_Elaborate_Body);
@@ -8875,6 +9062,7 @@ package Einfo is
pragma Inline (Set_Has_Storage_Size_Clause);
pragma Inline (Set_Has_Stream_Size_Clause);
pragma Inline (Set_Has_Task);
+ pragma Inline (Set_Has_Timing_Event);
pragma Inline (Set_Has_Thunks);
pragma Inline (Set_Has_Unchecked_Union);
pragma Inline (Set_Has_Unknown_Discriminants);
@@ -8895,6 +9083,7 @@ package Einfo is
pragma Inline (Set_Is_Abstract_Subprogram);
pragma Inline (Set_Is_Abstract_Type);
pragma Inline (Set_Is_Access_Constant);
+ pragma Inline (Set_Is_Actual_Subtype);
pragma Inline (Set_Is_Ada_2005_Only);
pragma Inline (Set_Is_Ada_2012_Only);
pragma Inline (Set_Is_Aliased);
@@ -8916,15 +9105,18 @@ package Einfo is
pragma Inline (Set_Is_Controlled);
pragma Inline (Set_Is_Controlling_Formal);
pragma Inline (Set_Is_CPP_Class);
- pragma Inline (Set_Is_Default_Init_Cond_Procedure);
- pragma Inline (Set_Is_Descendent_Of_Address);
+ pragma Inline (Set_Is_Descendant_Of_Address);
+ pragma Inline (Set_Is_DIC_Procedure);
pragma Inline (Set_Is_Discrim_SO_Function);
pragma Inline (Set_Is_Discriminant_Check_Function);
pragma Inline (Set_Is_Dispatch_Table_Entity);
pragma Inline (Set_Is_Dispatching_Operation);
pragma Inline (Set_Is_Eliminated);
pragma Inline (Set_Is_Entry_Formal);
+ pragma Inline (Set_Is_Entry_Wrapper);
+ pragma Inline (Set_Is_Exception_Handler);
pragma Inline (Set_Is_Exported);
+ pragma Inline (Set_Is_Finalized_Transient);
pragma Inline (Set_Is_First_Subtype);
pragma Inline (Set_Is_For_Access_Subtype);
pragma Inline (Set_Is_Formal_Subprogram);
@@ -8937,6 +9129,7 @@ package Einfo is
pragma Inline (Set_Is_Hidden_Non_Overridden_Subpgm);
pragma Inline (Set_Is_Hidden_Open_Scope);
pragma Inline (Set_Is_Ignored_Ghost_Entity);
+ pragma Inline (Set_Is_Ignored_Transient);
pragma Inline (Set_Is_Immediately_Visible);
pragma Inline (Set_Is_Implementation_Defined);
pragma Inline (Set_Is_Imported);
@@ -8966,6 +9159,7 @@ package Einfo is
pragma Inline (Set_Is_Packed);
pragma Inline (Set_Is_Packed_Array_Impl_Type);
pragma Inline (Set_Is_Param_Block_Component_Type);
+ pragma Inline (Set_Is_Partial_Invariant_Procedure);
pragma Inline (Set_Is_Potentially_Use_Visible);
pragma Inline (Set_Is_Predicate_Function);
pragma Inline (Set_Is_Predicate_Function_M);
@@ -8975,7 +9169,6 @@ package Einfo is
pragma Inline (Set_Is_Private_Composite);
pragma Inline (Set_Is_Private_Descendant);
pragma Inline (Set_Is_Private_Primitive);
- pragma Inline (Set_Is_Processed_Transient);
pragma Inline (Set_Is_Public);
pragma Inline (Set_Is_Pure);
pragma Inline (Set_Is_Pure_Unit_Access_Type);
@@ -8995,6 +9188,7 @@ package Einfo is
pragma Inline (Set_Is_Trivial_Subprogram);
pragma Inline (Set_Is_True_Constant);
pragma Inline (Set_Is_Unchecked_Union);
+ pragma Inline (Set_Is_Underlying_Full_View);
pragma Inline (Set_Is_Underlying_Record_View);
pragma Inline (Set_Is_Unimplemented);
pragma Inline (Set_Is_Unsigned_Type);
@@ -9046,6 +9240,7 @@ package Einfo is
pragma Inline (Set_Optimize_Alignment_Time);
pragma Inline (Set_Original_Access_Type);
pragma Inline (Set_Original_Array_Type);
+ pragma Inline (Set_Original_Protected_Subprogram);
pragma Inline (Set_Original_Record_Component);
pragma Inline (Set_Overlays_Constant);
pragma Inline (Set_Overridden_Operation);
@@ -9057,6 +9252,7 @@ package Einfo is
pragma Inline (Set_Partial_View_Has_Unknown_Discr);
pragma Inline (Set_Pending_Access_Types);
pragma Inline (Set_Postconditions_Proc);
+ pragma Inline (Set_Predicates_Ignored);
pragma Inline (Set_Prival);
pragma Inline (Set_Prival_Link);
pragma Inline (Set_Private_Dependents);
@@ -9083,7 +9279,6 @@ package Einfo is
pragma Inline (Set_Return_Applies_To);
pragma Inline (Set_Return_Present);
pragma Inline (Set_Returns_By_Ref);
- pragma Inline (Set_Returns_Limited_View);
pragma Inline (Set_Reverse_Bit_Order);
pragma Inline (Set_Reverse_Storage_Order);
pragma Inline (Set_Rewritten_For_C);
diff --git a/gcc/ada/env.c b/gcc/ada/env.c
index 8469876679..da6b7b0ad7 100644
--- a/gcc/ada/env.c
+++ b/gcc/ada/env.c
@@ -302,7 +302,7 @@ void __gnat_clearenv (void)
#elif defined (__MINGW32__) || defined (__FreeBSD__) || defined (__APPLE__) \
|| (defined (__vxworks) && defined (__RTP__)) || defined (__CYGWIN__) \
|| defined (__NetBSD__) || defined (__OpenBSD__) || defined (__rtems__) \
- || defined (__DragonFly__)
+ || defined (__DragonFly__) || defined (__DJGPP__)
/* On Windows, FreeBSD and MacOS there is no function to clean all the
environment but there is a "clean" way to unset a variable. So go
through the environ table and call __gnat_unsetenv on all entries */
diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb
index 7c2a097119..7a244fb580 100644
--- a/gcc/ada/errout.adb
+++ b/gcc/ada/errout.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -60,6 +60,13 @@ package body Errout is
Finalize_Called : Boolean := False;
-- Set True if the Finalize routine has been called
+ Record_Compilation_Errors : Boolean := False;
+ -- Record that a compilation error was witnessed during a given phase of
+ -- analysis for gnat2why. This is needed as Warning_Mode is modified twice
+ -- in gnat2why, hence Erroutc.Compilation_Errors can only return a suitable
+ -- value for each phase of analysis separately. This is updated at each
+ -- call to Compilation_Errors.
+
Warn_On_Instance : Boolean;
-- Flag set true for warning message to be posted on instance
@@ -236,8 +243,17 @@ package body Errout is
begin
if not Finalize_Called then
raise Program_Error;
+
+ -- Record that a compilation error was witnessed during a given phase of
+ -- analysis for gnat2why. This is needed as Warning_Mode is modified
+ -- twice in gnat2why, hence Erroutc.Compilation_Errors can only return a
+ -- suitable value for each phase of analysis separately.
+
else
- return Erroutc.Compilation_Errors;
+ Record_Compilation_Errors :=
+ Record_Compilation_Errors or else Erroutc.Compilation_Errors;
+
+ return Record_Compilation_Errors;
end if;
end Compilation_Errors;
@@ -1082,8 +1098,7 @@ package body Errout is
end loop;
end if;
- -- Now we insert the new message in the error chain. The insertion
- -- point for the message is after Prev_Msg and before Next_Msg.
+ -- Now we insert the new message in the error chain.
-- The possible insertion point for the new message is after Prev_Msg
-- and before Next_Msg. However, this is where we do a special check
@@ -1101,7 +1116,7 @@ package body Errout is
and then not All_Errors_Mode
then
-- Don't delete unconditional messages and at this stage, don't
- -- delete continuation lines (we attempted to delete those earlier
+ -- delete continuation lines; we attempted to delete those earlier
-- if the parent message was deleted.
if not Errors.Table (Cur_Msg).Uncond
@@ -1125,10 +1140,9 @@ package body Errout is
-- All tests passed, delete the message by simply returning
-- without any further processing.
- if not Continuation then
- Last_Killed := True;
- end if;
+ pragma Assert (not Continuation);
+ Last_Killed := True;
return;
end if;
end if;
@@ -1153,15 +1167,22 @@ package body Errout is
end if;
end if;
- -- Bump appropriate statistics count
+ -- Bump appropriate statistics counts
- if Errors.Table (Cur_Msg).Warn or else Errors.Table (Cur_Msg).Style then
- Warnings_Detected := Warnings_Detected + 1;
+ if Errors.Table (Cur_Msg).Info then
+ Info_Messages := Info_Messages + 1;
+
+ -- Could be (usually is) both "info" and "warning"
- if Errors.Table (Cur_Msg).Info then
- Info_Messages := Info_Messages + 1;
+ if Errors.Table (Cur_Msg).Warn then
+ Warnings_Detected := Warnings_Detected + 1;
end if;
+ elsif Errors.Table (Cur_Msg).Warn
+ or else Errors.Table (Cur_Msg).Style
+ then
+ Warnings_Detected := Warnings_Detected + 1;
+
elsif Errors.Table (Cur_Msg).Check then
Check_Messages := Check_Messages + 1;
@@ -1298,9 +1319,7 @@ package body Errout is
Last_Killed := True;
end if;
- if not (Is_Warning_Msg or Is_Style_Msg) then
- Set_Posted (N);
- end if;
+ Set_Posted (N);
end Error_Msg_NEL;
------------------
@@ -1612,13 +1631,13 @@ package body Errout is
Last_Error_Msg := No_Error_Msg;
Serious_Errors_Detected := 0;
Total_Errors_Detected := 0;
- Warnings_Treated_As_Errors := 0;
- Warnings_Detected := 0;
- Info_Messages := 0;
- Warnings_As_Errors_Count := 0;
Cur_Msg := No_Error_Msg;
List_Pragmas.Init;
+ -- Reset counts for warnings
+
+ Reset_Warnings;
+
-- Initialize warnings tables
Warnings.Init;
@@ -2354,11 +2373,26 @@ package body Errout is
end if;
end Remove_Warning_Messages;
+ --------------------
+ -- Reset_Warnings --
+ --------------------
+
+ procedure Reset_Warnings is
+ begin
+ Warnings_Treated_As_Errors := 0;
+ Warnings_Detected := 0;
+ Info_Messages := 0;
+ Warnings_As_Errors_Count := 0;
+ end Reset_Warnings;
+
----------------------
-- Adjust_Name_Case --
----------------------
- procedure Adjust_Name_Case (Loc : Source_Ptr) is
+ procedure Adjust_Name_Case
+ (Buf : in out Bounded_String;
+ Loc : Source_Ptr)
+ is
begin
-- We have an all lower case name from Namet, and now we want to set
-- the appropriate case. If possible we copy the actual casing from
@@ -2387,10 +2421,10 @@ package body Errout is
Sbuffer := Source_Text (Src_Ind);
- while Ref_Ptr <= Name_Len loop
+ while Ref_Ptr <= Buf.Length loop
exit when
Fold_Lower (Sbuffer (Src_Ptr)) /=
- Fold_Lower (Name_Buffer (Ref_Ptr));
+ Fold_Lower (Buf.Chars (Ref_Ptr));
Ref_Ptr := Ref_Ptr + 1;
Src_Ptr := Src_Ptr + 1;
end loop;
@@ -2398,23 +2432,28 @@ package body Errout is
-- If we get through the loop without a mismatch, then output the
-- name the way it is cased in the source program
- if Ref_Ptr > Name_Len then
+ if Ref_Ptr > Buf.Length then
Src_Ptr := Loc;
- for J in 1 .. Name_Len loop
- Name_Buffer (J) := Sbuffer (Src_Ptr);
+ for J in 1 .. Buf.Length loop
+ Buf.Chars (J) := Sbuffer (Src_Ptr);
Src_Ptr := Src_Ptr + 1;
end loop;
-- Otherwise set the casing using the default identifier casing
else
- Set_Casing (Identifier_Casing (Src_Ind), Mixed_Case);
+ Set_Casing (Buf, Identifier_Casing (Src_Ind));
end if;
end if;
end;
end Adjust_Name_Case;
+ procedure Adjust_Name_Case (Loc : Source_Ptr) is
+ begin
+ Adjust_Name_Case (Global_Name_Buffer, Loc);
+ end Adjust_Name_Case;
+
---------------------------
-- Set_Identifier_Casing --
---------------------------
@@ -2775,7 +2814,9 @@ package body Errout is
Set_Msg_Node (Defining_Identifier (Node));
return;
- when N_Selected_Component | N_Expanded_Name =>
+ when N_Expanded_Name
+ | N_Selected_Component
+ =>
Set_Msg_Node (Prefix (Node));
Set_Msg_Char ('.');
Set_Msg_Node (Selector_Name (Node));
@@ -2874,7 +2915,7 @@ package body Errout is
end if;
-- Remaining step is to adjust casing and possibly add 'Class
- Adjust_Name_Case (Loc);
+ Adjust_Name_Case (Global_Name_Buffer, Loc);
Set_Msg_Name_Buffer;
Add_Class;
end Set_Msg_Node;
@@ -2981,7 +3022,7 @@ package body Errout is
when '\' =>
Continuation := True;
- if Text (P) = '\' then
+ if P <= Text'Last and then Text (P) = '\' then
Continuation_New_Line := True;
P := P + 1;
end if;
@@ -3387,10 +3428,13 @@ package body Errout is
case Warning_Msg_Char is
when '?' =>
return "??";
+
when 'a' .. 'z' | 'A' .. 'Z' | '*' | '$' =>
return '?' & Warning_Msg_Char & '?';
+
when ' ' =>
return "?";
+
when others =>
raise Program_Error;
end case;
diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads
index 4540c9380a..a8e4d6c15a 100644
--- a/gcc/ada/errout.ads
+++ b/gcc/ada/errout.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -324,7 +324,7 @@ package Errout is
-- "[restriction warning]" at the end of the warning message. For
-- continuations, use this on each continuation message.
- -- Insertion character ?$? (elaboration information messages)
+ -- Insertion character ?$? (elaboration informational messages)
-- Like ?, but if the flag Warn_Doc_Switch is True, adds the string
-- "[-gnatel]" at the end of the info message. This is used for the
-- messages generated by the switch -gnatel. For continuations, use
@@ -419,12 +419,13 @@ package Errout is
-- message. Style messages are also considered to be warnings, but
-- they do not get a tag.
- -- Insertion sequence "info: " (information message)
+ -- Insertion sequence "info: " (informational message)
-- This appears only at the start of the message (and not any of its
-- continuations, if any), and indicates that the message is an info
-- message. The message will be output with this prefix, and if there
-- are continuations that are not printed using the -gnatj switch they
- -- will also have this prefix.
+ -- will also have this prefix. Informational messages are usually also
+ -- warnings, but they don't have to be.
-- Insertion sequence "low: " or "medium: " or "high: " (check message)
-- This appears only at the start of the message (and not any of its
@@ -793,7 +794,7 @@ package Errout is
procedure Remove_Warning_Messages (N : Node_Id);
-- Remove any warning messages corresponding to the Sloc of N or any
- -- of its descendent nodes. No effect if no such warnings. Note that
+ -- of its descendant nodes. No effect if no such warnings. Note that
-- style messages (identified by the fact that they start with "(style)")
-- are not removed by this call. Basically the idea behind this procedure
-- is to remove warnings about execution conditions from known dead code.
@@ -802,6 +803,11 @@ package Errout is
-- Remove warnings on all elements of a list (Calls Remove_Warning_Messages
-- on each element of the list, see above).
+ procedure Reset_Warnings;
+ -- Reset the counts related to warnings. This is used both to initialize
+ -- these counts and to reset them after each phase of analysis for a given
+ -- value of Opt.Warning_Mode in gnat2why.
+
procedure Set_Ignore_Errors (To : Boolean);
-- Following a call to this procedure with To=True, all error calls are
-- ignored. A call with To=False restores the default treatment in which
@@ -851,9 +857,9 @@ package Errout is
function Compilation_Errors return Boolean;
-- Returns True if errors have been detected, or warnings in -gnatwe (treat
-- warnings as errors) mode. Note that it is mandatory to call Finalize
- -- before calling this routine. Always returns False in formal verification
- -- mode, because errors issued when analyzing code are not compilation
- -- errors, and should not result in exiting with an error status.
+ -- before calling this routine. To account for changes to Warning_Mode in
+ -- gnat2why between phases, the past or current presence of an error is
+ -- recorded in a global variable at each call.
procedure Error_Msg_CRT (Feature : String; N : Node_Id);
-- Posts a non-fatal message on node N saying that the feature identified
@@ -904,11 +910,17 @@ package Errout is
-- Utility Interface for Casing Control --
------------------------------------------
+ procedure Adjust_Name_Case
+ (Buf : in out Bounded_String;
+ Loc : Source_Ptr);
+ -- Given a name stored in Buf, set proper casing. Loc is an associated
+ -- source position, and if we can find a match between the name in Buf and
+ -- the name at that source location, we copy the casing from the source,
+ -- otherwise we set appropriate default casing.
+
procedure Adjust_Name_Case (Loc : Source_Ptr);
- -- Given a name stored in Name_Buffer (1 .. Name_Len), set proper casing.
- -- Loc is an associated source position, if we can find a match between
- -- the name in Name_Buffer and the name at that source location, we copy
- -- the casing from the source, otherwise we set appropriate default casing.
+ -- Uses Buf => Global_Name_Buffer. There are no calls to this in the
+ -- compiler, but it is called in SPARK 2014.
procedure Set_Identifier_Casing
(Identifier_Name : System.Address;
diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb
index d74a3ee983..ada93157af 100644
--- a/gcc/ada/erroutc.adb
+++ b/gcc/ada/erroutc.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -66,7 +66,7 @@ package body Erroutc is
Class_Flag := False;
Set_Msg_Char (''');
Get_Name_String (Name_Class);
- Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
+ Set_Casing (Identifier_Casing (Flag_Source));
Set_Msg_Name_Buffer;
end if;
end Add_Class;
@@ -633,7 +633,7 @@ package body Erroutc is
-- Deal with warning case
- if Errors.Table (E).Warn then
+ if Errors.Table (E).Warn or else Errors.Table (E).Info then
-- For info messages, prefix message with "info: "
@@ -855,7 +855,7 @@ package body Erroutc is
end if;
end loop;
- if Is_Warning_Msg or Is_Style_Msg or Is_Check_Msg then
+ if Is_Info_Msg or Is_Warning_Msg or Is_Style_Msg or Is_Check_Msg then
Is_Serious_Error := False;
end if;
end Prescan_Message;
@@ -1187,7 +1187,7 @@ package body Erroutc is
-- Else output with surrounding quotes in proper casing mode
else
- Set_Casing (Identifier_Casing (Flag_Source), Mixed_Case);
+ Set_Casing (Identifier_Casing (Flag_Source));
Set_Msg_Quote;
Set_Msg_Name_Buffer;
Set_Msg_Quote;
diff --git a/gcc/ada/errutil.adb b/gcc/ada/errutil.adb
index 9fd67e16a7..3a8f0fbf5d 100644
--- a/gcc/ada/errutil.adb
+++ b/gcc/ada/errutil.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1991-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1991-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -302,18 +302,22 @@ package body Errutil is
Errors.Table (Cur_Msg).Next := Next_Msg;
- -- Bump appropriate statistics count
+ -- Bump appropriate statistics counts
- if Errors.Table (Cur_Msg).Warn
- or else
- Errors.Table (Cur_Msg).Style
- then
- Warnings_Detected := Warnings_Detected + 1;
+ if Errors.Table (Cur_Msg).Info then
+ Info_Messages := Info_Messages + 1;
+
+ -- Could be (usually is) both "info" and "warning"
- if Errors.Table (Cur_Msg).Info then
- Info_Messages := Info_Messages + 1;
+ if Errors.Table (Cur_Msg).Warn then
+ Warnings_Detected := Warnings_Detected + 1;
end if;
+ elsif Errors.Table (Cur_Msg).Warn
+ or else Errors.Table (Cur_Msg).Style
+ then
+ Warnings_Detected := Warnings_Detected + 1;
+
elsif Errors.Table (Cur_Msg).Check then
Check_Messages := Check_Messages + 1;
diff --git a/gcc/ada/eval_fat.adb b/gcc/ada/eval_fat.adb
index 5b56ddd5ea..48208444bd 100644
--- a/gcc/ada/eval_fat.adb
+++ b/gcc/ada/eval_fat.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -373,7 +373,7 @@ package body Eval_Fat is
Fraction := Fraction + 1;
end if;
- when Round =>
+ when Round =>
-- Do not round to even as is done with IEEE arithmetic, but
-- instead round away from zero when the result is exactly
@@ -390,7 +390,7 @@ package body Eval_Fat is
Fraction := Fraction + 1;
end if;
- when Floor =>
+ when Floor =>
if N > Uint_0 and then UR_Is_Negative (X) then
Fraction := Fraction + 1;
end if;
@@ -666,7 +666,7 @@ package body Eval_Fat is
Result := Truncation (RT, abs X);
Tail := abs X - Result;
- if Tail >= Ureal_Half then
+ if Tail >= Ureal_Half then
Result := Result + Ureal_1;
end if;
@@ -761,7 +761,7 @@ package body Eval_Fat is
Result := Truncation (RT, Abs_X);
Tail := Abs_X - Result;
- if Tail > Ureal_Half then
+ if Tail > Ureal_Half then
Result := Result + Ureal_1;
elsif Tail = Ureal_Half then
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 002579bf36..6a0b0d5324 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -84,6 +84,9 @@ package body Exp_Aggr is
-- expression with actions, which becomes the Initialization_Statements for
-- Obj.
+ procedure Expand_Delta_Array_Aggregate (N : Node_Id; Deltas : List_Id);
+ procedure Expand_Delta_Record_Aggregate (N : Node_Id; Deltas : List_Id);
+
function Has_Default_Init_Comps (N : Node_Id) return Boolean;
-- N is an aggregate (record or array). Checks the presence of default
-- initialization (<>) in any component (Ada 2005: AI-287).
@@ -95,6 +98,25 @@ package body Exp_Aggr is
-- Returns true if N is an aggregate used to initialize the components
-- of a statically allocated dispatch table.
+ function Late_Expansion
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Target : Node_Id) return List_Id;
+ -- This routine implements top-down expansion of nested aggregates. In
+ -- doing so, it avoids the generation of temporaries at each level. N is
+ -- a nested record or array aggregate with the Expansion_Delayed flag.
+ -- Typ is the expected type of the aggregate. Target is a (duplicatable)
+ -- expression that will hold the result of the aggregate expansion.
+
+ function Make_OK_Assignment_Statement
+ (Sloc : Source_Ptr;
+ Name : Node_Id;
+ Expression : Node_Id) return Node_Id;
+ -- This is like Make_Assignment_Statement, except that Assignment_OK
+ -- is set in the left operand. All assignments built by this unit use
+ -- this routine. This is needed to deal with assignments to initialized
+ -- constants that are done in place.
+
function Must_Slide
(Obj_Type : Entity_Id;
Typ : Entity_Id) return Boolean;
@@ -109,6 +131,41 @@ package body Exp_Aggr is
-- when a component may be given with bounds that differ from those of the
-- component type.
+ function Number_Of_Choices (N : Node_Id) return Nat;
+ -- Returns the number of discrete choices (not including the others choice
+ -- if present) contained in (sub-)aggregate N.
+
+ procedure Process_Transient_Component
+ (Loc : Source_Ptr;
+ Comp_Typ : Entity_Id;
+ Init_Expr : Node_Id;
+ Fin_Call : out Node_Id;
+ Hook_Clear : out Node_Id;
+ Aggr : Node_Id := Empty;
+ Stmts : List_Id := No_List);
+ -- Subsidiary to the expansion of array and record aggregates. Generate
+ -- part of the necessary code to finalize a transient component. Comp_Typ
+ -- is the component type. Init_Expr is the initialization expression of the
+ -- component which is always a function call. Fin_Call is the finalization
+ -- call used to clean up the transient function result. Hook_Clear is the
+ -- hook reset statement. Aggr and Stmts both control the placement of the
+ -- generated code. Aggr is the related aggregate. If present, all code is
+ -- inserted prior to Aggr using Insert_Action. Stmts is the initialization
+ -- statements of the component. If present, all code is added to Stmts.
+
+ procedure Process_Transient_Component_Completion
+ (Loc : Source_Ptr;
+ Aggr : Node_Id;
+ Fin_Call : Node_Id;
+ Hook_Clear : Node_Id;
+ Stmts : List_Id);
+ -- Subsidiary to the expansion of array and record aggregates. Generate
+ -- part of the necessary code to finalize a transient component. Aggr is
+ -- the related aggregate. Fin_Clear is the finalization call used to clean
+ -- up the transient component. Hook_Clear is the hook reset statment. Stmts
+ -- is the initialization statement list for the component. All generated
+ -- code is added to Stmts.
+
procedure Sort_Case_Table (Case_Table : in out Case_Table_Type);
-- Sort the Case Table using the Lower Bound of each Choice as the key.
-- A simple insertion sort is used since the number of choices in a case
@@ -202,7 +259,7 @@ package body Exp_Aggr is
-- N is the (sub-)aggregate node to be expanded into code. This node has
-- been fully analyzed, and its Etype is properly set.
--
- -- Index is the index node corresponding to the array sub-aggregate N
+ -- Index is the index node corresponding to the array subaggregate N
--
-- Into is the target expression into which we are copying the aggregate.
-- Note that this node may not have been analyzed yet, and so the Etype
@@ -260,29 +317,6 @@ package body Exp_Aggr is
-- an array that is suitable for this optimization: it returns True if Typ
-- is a two dimensional bit packed array with component size 1, 2, or 4.
- function Late_Expansion
- (N : Node_Id;
- Typ : Entity_Id;
- Target : Node_Id) return List_Id;
- -- This routine implements top-down expansion of nested aggregates. In
- -- doing so, it avoids the generation of temporaries at each level. N is
- -- a nested record or array aggregate with the Expansion_Delayed flag.
- -- Typ is the expected type of the aggregate. Target is a (duplicatable)
- -- expression that will hold the result of the aggregate expansion.
-
- function Make_OK_Assignment_Statement
- (Sloc : Source_Ptr;
- Name : Node_Id;
- Expression : Node_Id) return Node_Id;
- -- This is like Make_Assignment_Statement, except that Assignment_OK
- -- is set in the left operand. All assignments built by this unit use
- -- this routine. This is needed to deal with assignments to initialized
- -- constants that are done in place.
-
- function Number_Of_Choices (N : Node_Id) return Nat;
- -- Returns the number of discrete choices (not including the others choice
- -- if present) contained in (sub-)aggregate N.
-
function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean;
-- Given an array aggregate, this function handles the case of a packed
-- array aggregate with all constant values, where the aggregate can be
@@ -317,7 +351,7 @@ package body Exp_Aggr is
-- This avoids running away with attempts to convert huge aggregates,
-- which hit memory limits in the backend.
- function Component_Count (T : Entity_Id) return Int;
+ function Component_Count (T : Entity_Id) return Nat;
-- The limit is applied to the total number of components that the
-- aggregate will have, which is the number of static expressions
-- that will appear in the flattened array. This requires a recursive
@@ -327,8 +361,8 @@ package body Exp_Aggr is
-- Component_Count --
---------------------
- function Component_Count (T : Entity_Id) return Int is
- Res : Int := 0;
+ function Component_Count (T : Entity_Id) return Nat is
+ Res : Nat := 0;
Comp : Entity_Id;
begin
@@ -351,13 +385,19 @@ package body Exp_Aggr is
Hi : constant Node_Id :=
Type_High_Bound (Etype (First_Index (T)));
- Siz : constant Int := Component_Count (Component_Type (T));
+ Siz : constant Nat := Component_Count (Component_Type (T));
begin
+ -- Check for superflat arrays, i.e. arrays with such bounds
+ -- as 4 .. 2, to insure that this function never returns a
+ -- meaningless negative value.
+
if not Compile_Time_Known_Value (Lo)
or else not Compile_Time_Known_Value (Hi)
+ or else Expr_Value (Hi) < Expr_Value (Lo)
then
return 0;
+
else
return
Siz * UI_To_Int (Expr_Value (Hi) - Expr_Value (Lo) + 1);
@@ -455,7 +495,8 @@ package body Exp_Aggr is
then
if Present (Component_Associations (N)) then
Indx :=
- First (Choices (First (Component_Associations (N))));
+ First
+ (Choice_List (First (Component_Associations (N))));
if Is_Entity_Name (Indx)
and then not Is_Type (Entity (Indx))
@@ -539,23 +580,52 @@ package body Exp_Aggr is
-- 10. No controlled actions need to be generated for components
+ -- 11. When generating C code, N must be part of a N_Object_Declaration
+
+ -- 12. When generating C code, N must not include function calls
+
function Backend_Processing_Possible (N : Node_Id) return Boolean is
Typ : constant Entity_Id := Etype (N);
-- Typ is the correct constrained array subtype of the aggregate
function Component_Check (N : Node_Id; Index : Node_Id) return Boolean;
-- This routine checks components of aggregate N, enforcing checks
- -- 1, 7, 8, and 9. In the multi-dimensional case, these checks are
- -- performed on subaggregates. The Index value is the current index
- -- being checked in the multi-dimensional case.
+ -- 1, 7, 8, 9, 11, and 12. In the multidimensional case, these checks
+ -- are performed on subaggregates. The Index value is the current index
+ -- being checked in the multidimensional case.
---------------------
-- Component_Check --
---------------------
function Component_Check (N : Node_Id; Index : Node_Id) return Boolean is
+ function Ultimate_Original_Expression (N : Node_Id) return Node_Id;
+ -- Given a type conversion or an unchecked type conversion N, return
+ -- its innermost original expression.
+
+ ----------------------------------
+ -- Ultimate_Original_Expression --
+ ----------------------------------
+
+ function Ultimate_Original_Expression (N : Node_Id) return Node_Id is
+ Expr : Node_Id := Original_Node (N);
+
+ begin
+ while Nkind_In (Expr, N_Type_Conversion,
+ N_Unchecked_Type_Conversion)
+ loop
+ Expr := Original_Node (Expression (Expr));
+ end loop;
+
+ return Expr;
+ end Ultimate_Original_Expression;
+
+ -- Local variables
+
Expr : Node_Id;
+ -- Start of processing for Component_Check
+
begin
-- Checks 1: (no component associations)
@@ -563,6 +633,17 @@ package body Exp_Aggr is
return False;
end if;
+ -- Checks 11: (part of an object declaration)
+
+ if Modify_Tree_For_C
+ and then Nkind (Parent (N)) /= N_Object_Declaration
+ and then
+ (Nkind (Parent (N)) /= N_Qualified_Expression
+ or else Nkind (Parent (Parent (N))) /= N_Object_Declaration)
+ then
+ return False;
+ end if;
+
-- Checks on components
-- Recurse to check subaggregates, which may appear in qualified
@@ -594,6 +675,15 @@ package body Exp_Aggr is
return False;
end if;
+ -- Checks 12: (no function call)
+
+ if Modify_Tree_For_C
+ and then
+ Nkind (Ultimate_Original_Expression (Expr)) = N_Function_Call
+ then
+ return False;
+ end if;
+
-- Recursion to following indexes for multiple dimension case
if Present (Next_Index (Index))
@@ -626,7 +716,7 @@ package body Exp_Aggr is
return False;
end if;
- -- Checks 4 (array must not be multi-dimensional Fortran case)
+ -- Checks 4 (array must not be multidimensional Fortran case)
if Convention (Typ) = Convention_Fortran
and then Number_Dimensions (Typ) > 1
@@ -678,7 +768,7 @@ package body Exp_Aggr is
-- The code that we generate from a one dimensional aggregate is
- -- 1. If the sub-aggregate contains discrete choices we
+ -- 1. If the subaggregate contains discrete choices we
-- (a) Sort the discrete choices
@@ -739,35 +829,42 @@ package body Exp_Aggr is
function Index_Base_Name return Node_Id;
-- Returns a new reference to the index type name
- function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id;
- -- Ind must be a side-effect free expression. If the input aggregate
- -- N to Build_Loop contains no sub-aggregates, then this function
- -- returns the assignment statement:
+ function Gen_Assign
+ (Ind : Node_Id;
+ Expr : Node_Id;
+ In_Loop : Boolean := False) return List_Id;
+ -- Ind must be a side-effect-free expression. If the input aggregate N
+ -- to Build_Loop contains no subaggregates, then this function returns
+ -- the assignment statement:
--
-- Into (Indexes, Ind) := Expr;
--
- -- Otherwise we call Build_Code recursively
+ -- Otherwise we call Build_Code recursively. Flag In_Loop should be set
+ -- when the assignment appears within a generated loop.
--
-- Ada 2005 (AI-287): In case of default initialized component, Expr
-- is empty and we generate a call to the corresponding IP subprogram.
function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id;
- -- Nodes L and H must be side-effect free expressions.
- -- If the input aggregate N to Build_Loop contains no sub-aggregates,
- -- This routine returns the for loop statement
+ -- Nodes L and H must be side-effect-free expressions. If the input
+ -- aggregate N to Build_Loop contains no subaggregates, this routine
+ -- returns the for loop statement:
--
-- for J in Index_Base'(L) .. Index_Base'(H) loop
-- Into (Indexes, J) := Expr;
-- end loop;
--
- -- Otherwise we call Build_Code recursively.
- -- As an optimization if the loop covers 3 or less scalar elements we
- -- generate a sequence of assignments.
+ -- Otherwise we call Build_Code recursively. As an optimization if the
+ -- loop covers 3 or fewer scalar elements we generate a sequence of
+ -- assignments.
+ -- If the component association that generates the loop comes from an
+ -- Iterated_Component_Association, the loop parameter has the name of
+ -- the corresponding parameter in the original construct.
function Gen_While (L, H : Node_Id; Expr : Node_Id) return List_Id;
- -- Nodes L and H must be side-effect free expressions.
- -- If the input aggregate N to Build_Loop contains no sub-aggregates,
- -- This routine returns the while loop statement
+ -- Nodes L and H must be side-effect-free expressions. If the input
+ -- aggregate N to Build_Loop contains no subaggregates, this routine
+ -- returns the while loop statement:
--
-- J : Index_Base := L;
-- while J < H loop
@@ -961,19 +1058,36 @@ package body Exp_Aggr is
-- Gen_Assign --
----------------
- function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id is
- L : constant List_Id := New_List;
- A : Node_Id;
-
- New_Indexes : List_Id;
- Indexed_Comp : Node_Id;
- Expr_Q : Node_Id;
- Comp_Type : Entity_Id := Empty;
-
+ function Gen_Assign
+ (Ind : Node_Id;
+ Expr : Node_Id;
+ In_Loop : Boolean := False) return List_Id
+ is
function Add_Loop_Actions (Lis : List_Id) return List_Id;
- -- Collect insert_actions generated in the construction of a
- -- loop, and prepend them to the sequence of assignments to
- -- complete the eventual body of the loop.
+ -- Collect insert_actions generated in the construction of a loop,
+ -- and prepend them to the sequence of assignments to complete the
+ -- eventual body of the loop.
+
+ procedure Initialize_Array_Component
+ (Arr_Comp : Node_Id;
+ Comp_Typ : Node_Id;
+ Init_Expr : Node_Id;
+ Stmts : List_Id);
+ -- Perform the initialization of array component Arr_Comp with
+ -- expected type Comp_Typ. Init_Expr denotes the initialization
+ -- expression of the array component. All generated code is added
+ -- to list Stmts.
+
+ procedure Initialize_Ctrl_Array_Component
+ (Arr_Comp : Node_Id;
+ Comp_Typ : Entity_Id;
+ Init_Expr : Node_Id;
+ Stmts : List_Id);
+ -- Perform the initialization of array component Arr_Comp when its
+ -- expected type Comp_Typ needs finalization actions. Init_Expr is
+ -- the initialization expression of the array component. All hook-
+ -- related declarations are inserted prior to aggregate N. Remaining
+ -- code is added to list Stmts.
----------------------
-- Add_Loop_Actions --
@@ -1002,6 +1116,298 @@ package body Exp_Aggr is
end if;
end Add_Loop_Actions;
+ --------------------------------
+ -- Initialize_Array_Component --
+ --------------------------------
+
+ procedure Initialize_Array_Component
+ (Arr_Comp : Node_Id;
+ Comp_Typ : Node_Id;
+ Init_Expr : Node_Id;
+ Stmts : List_Id)
+ is
+ Exceptions_OK : constant Boolean :=
+ not Restriction_Active
+ (No_Exception_Propagation);
+
+ Finalization_OK : constant Boolean :=
+ Present (Comp_Typ)
+ and then Needs_Finalization (Comp_Typ);
+
+ Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ);
+ Adj_Call : Node_Id;
+ Blk_Stmts : List_Id;
+ Init_Stmt : Node_Id;
+
+ begin
+ -- Protect the initialization statements from aborts. Generate:
+
+ -- Abort_Defer;
+
+ if Finalization_OK and Abort_Allowed then
+ if Exceptions_OK then
+ Blk_Stmts := New_List;
+ else
+ Blk_Stmts := Stmts;
+ end if;
+
+ Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
+
+ -- Otherwise aborts are not allowed. All generated code is added
+ -- directly to the input list.
+
+ else
+ Blk_Stmts := Stmts;
+ end if;
+
+ -- Initialize the array element. Generate:
+
+ -- Arr_Comp := Init_Expr;
+
+ -- Note that the initialization expression is replicated because
+ -- it has to be reevaluated within a generated loop.
+
+ Init_Stmt :=
+ Make_OK_Assignment_Statement (Loc,
+ Name => New_Copy_Tree (Arr_Comp),
+ Expression => New_Copy_Tree (Init_Expr));
+ Set_No_Ctrl_Actions (Init_Stmt);
+
+ -- If this is an aggregate for an array of arrays, each
+ -- subaggregate will be expanded as well, and even with
+ -- No_Ctrl_Actions the assignments of inner components will
+ -- require attachment in their assignments to temporaries. These
+ -- temporaries must be finalized for each subaggregate. Generate:
+
+ -- begin
+ -- Arr_Comp := Init_Expr;
+ -- end;
+
+ if Finalization_OK and then Is_Array_Type (Comp_Typ) then
+ Init_Stmt :=
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Init_Stmt)));
+ end if;
+
+ Append_To (Blk_Stmts, Init_Stmt);
+
+ -- Adjust the tag due to a possible view conversion. Generate:
+
+ -- Arr_Comp._tag := Full_TypP;
+
+ if Tagged_Type_Expansion
+ and then Present (Comp_Typ)
+ and then Is_Tagged_Type (Comp_Typ)
+ then
+ Append_To (Blk_Stmts,
+ Make_OK_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Arr_Comp),
+ Selector_Name =>
+ New_Occurrence_Of
+ (First_Tag_Component (Full_Typ), Loc)),
+
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Occurrence_Of
+ (Node (First_Elmt (Access_Disp_Table (Full_Typ))),
+ Loc))));
+ end if;
+
+ -- Adjust the array component. Controlled subaggregates are not
+ -- considered because each of their individual elements will
+ -- receive an adjustment of its own. Generate:
+
+ -- [Deep_]Adjust (Arr_Comp);
+
+ if Finalization_OK
+ and then not Is_Limited_Type (Comp_Typ)
+ and then not
+ (Is_Array_Type (Comp_Typ)
+ and then Is_Controlled (Component_Type (Comp_Typ))
+ and then Nkind (Expr) = N_Aggregate)
+ then
+ Adj_Call :=
+ Make_Adjust_Call
+ (Obj_Ref => New_Copy_Tree (Arr_Comp),
+ Typ => Comp_Typ);
+
+ -- Guard against a missing [Deep_]Adjust when the component
+ -- type was not frozen properly.
+
+ if Present (Adj_Call) then
+ Append_To (Blk_Stmts, Adj_Call);
+ end if;
+ end if;
+
+ -- Complete the protection of the initialization statements
+
+ if Finalization_OK and Abort_Allowed then
+
+ -- Wrap the initialization statements in a block to catch a
+ -- potential exception. Generate:
+
+ -- begin
+ -- Abort_Defer;
+ -- Arr_Comp := Init_Expr;
+ -- Arr_Comp._tag := Full_TypP;
+ -- [Deep_]Adjust (Arr_Comp);
+ -- at end
+ -- Abort_Undefer_Direct;
+ -- end;
+
+ if Exceptions_OK then
+ Append_To (Stmts,
+ Build_Abort_Undefer_Block (Loc,
+ Stmts => Blk_Stmts,
+ Context => N));
+
+ -- Otherwise exceptions are not propagated. Generate:
+
+ -- Abort_Defer;
+ -- Arr_Comp := Init_Expr;
+ -- Arr_Comp._tag := Full_TypP;
+ -- [Deep_]Adjust (Arr_Comp);
+ -- Abort_Undefer;
+
+ else
+ Append_To (Blk_Stmts,
+ Build_Runtime_Call (Loc, RE_Abort_Undefer));
+ end if;
+ end if;
+ end Initialize_Array_Component;
+
+ -------------------------------------
+ -- Initialize_Ctrl_Array_Component --
+ -------------------------------------
+
+ procedure Initialize_Ctrl_Array_Component
+ (Arr_Comp : Node_Id;
+ Comp_Typ : Entity_Id;
+ Init_Expr : Node_Id;
+ Stmts : List_Id)
+ is
+ Act_Aggr : Node_Id;
+ Act_Stmts : List_Id;
+ Expr : Node_Id;
+ Fin_Call : Node_Id;
+ Hook_Clear : Node_Id;
+
+ In_Place_Expansion : Boolean;
+ -- Flag set when a nonlimited controlled function call requires
+ -- in-place expansion.
+
+ begin
+ -- Duplicate the initialization expression in case the context is
+ -- a multi choice list or an "others" choice which plugs various
+ -- holes in the aggregate. As a result the expression is no longer
+ -- shared between the various components and is reevaluated for
+ -- each such component.
+
+ Expr := New_Copy_Tree (Init_Expr);
+ Set_Parent (Expr, Parent (Init_Expr));
+
+ -- Perform a preliminary analysis and resolution to determine what
+ -- the initialization expression denotes. An unanalyzed function
+ -- call may appear as an identifier or an indexed component.
+
+ if Nkind_In (Expr, N_Function_Call,
+ N_Identifier,
+ N_Indexed_Component)
+ and then not Analyzed (Expr)
+ then
+ Preanalyze_And_Resolve (Expr, Comp_Typ);
+ end if;
+
+ In_Place_Expansion :=
+ Nkind (Expr) = N_Function_Call
+ and then not Is_Limited_Type (Comp_Typ);
+
+ -- The initialization expression is a controlled function call.
+ -- Perform in-place removal of side effects to avoid creating a
+ -- transient scope, which leads to premature finalization.
+
+ -- This in-place expansion is not performed for limited transient
+ -- objects because the initialization is already done in-place.
+
+ if In_Place_Expansion then
+
+ -- Suppress the removal of side effects by general analysis
+ -- because this behavior is emulated here. This avoids the
+ -- generation of a transient scope, which leads to out-of-order
+ -- adjustment and finalization.
+
+ Set_No_Side_Effect_Removal (Expr);
+
+ -- When the transient component initialization is related to a
+ -- range or an "others", keep all generated statements within
+ -- the enclosing loop. This way the controlled function call
+ -- will be evaluated at each iteration, and its result will be
+ -- finalized at the end of each iteration.
+
+ if In_Loop then
+ Act_Aggr := Empty;
+ Act_Stmts := Stmts;
+
+ -- Otherwise this is a single component initialization. Hook-
+ -- related statements are inserted prior to the aggregate.
+
+ else
+ Act_Aggr := N;
+ Act_Stmts := No_List;
+ end if;
+
+ -- Install all hook-related declarations and prepare the clean
+ -- up statements.
+
+ Process_Transient_Component
+ (Loc => Loc,
+ Comp_Typ => Comp_Typ,
+ Init_Expr => Expr,
+ Fin_Call => Fin_Call,
+ Hook_Clear => Hook_Clear,
+ Aggr => Act_Aggr,
+ Stmts => Act_Stmts);
+ end if;
+
+ -- Use the noncontrolled component initialization circuitry to
+ -- assign the result of the function call to the array element.
+ -- This also performs subaggregate wrapping, tag adjustment, and
+ -- [deep] adjustment of the array element.
+
+ Initialize_Array_Component
+ (Arr_Comp => Arr_Comp,
+ Comp_Typ => Comp_Typ,
+ Init_Expr => Expr,
+ Stmts => Stmts);
+
+ -- At this point the array element is fully initialized. Complete
+ -- the processing of the controlled array component by finalizing
+ -- the transient function result.
+
+ if In_Place_Expansion then
+ Process_Transient_Component_Completion
+ (Loc => Loc,
+ Aggr => N,
+ Fin_Call => Fin_Call,
+ Hook_Clear => Hook_Clear,
+ Stmts => Stmts);
+ end if;
+ end Initialize_Ctrl_Array_Component;
+
+ -- Local variables
+
+ Stmts : constant List_Id := New_List;
+
+ Comp_Typ : Entity_Id := Empty;
+ Expr_Q : Node_Id;
+ Indexed_Comp : Node_Id;
+ Init_Call : Node_Id;
+ New_Indexes : List_Id;
+
-- Start of processing for Gen_Assign
begin
@@ -1047,8 +1453,8 @@ package body Exp_Aggr is
end if;
if Present (Etype (N)) and then Etype (N) /= Any_Composite then
- Comp_Type := Component_Type (Etype (N));
- pragma Assert (Comp_Type = Ctype); -- AI-287
+ Comp_Typ := Component_Type (Etype (N));
+ pragma Assert (Comp_Typ = Ctype); -- AI-287
elsif Present (Next (First (New_Indexes))) then
@@ -1074,7 +1480,7 @@ package body Exp_Aggr is
if Nkind (P) = N_Aggregate
and then Present (Etype (P))
then
- Comp_Type := Component_Type (Etype (P));
+ Comp_Typ := Component_Type (Etype (P));
exit;
else
@@ -1082,7 +1488,7 @@ package body Exp_Aggr is
end if;
end loop;
- pragma Assert (Comp_Type = Ctype); -- AI-287
+ pragma Assert (Comp_Typ = Ctype); -- AI-287
end;
end if;
end if;
@@ -1100,8 +1506,8 @@ package body Exp_Aggr is
-- the analysis of non-array aggregates now in order to get the
-- value of Expansion_Delayed flag for the inner aggregate ???
- if Present (Comp_Type) and then not Is_Array_Type (Comp_Type) then
- Analyze_And_Resolve (Expr_Q, Comp_Type);
+ if Present (Comp_Typ) and then not Is_Array_Type (Comp_Typ) then
+ Analyze_And_Resolve (Expr_Q, Comp_Typ);
end if;
if Is_Delayed_Aggregate (Expr_Q) then
@@ -1112,13 +1518,13 @@ package body Exp_Aggr is
-- component associations that provide different bounds from
-- those of the component type, and sliding must occur. Instead
-- of decomposing the current aggregate assignment, force the
- -- re-analysis of the assignment, so that a temporary will be
+ -- reanalysis of the assignment, so that a temporary will be
-- generated in the usual fashion, and sliding will take place.
if Nkind (Parent (N)) = N_Assignment_Statement
- and then Is_Array_Type (Comp_Type)
+ and then Is_Array_Type (Comp_Typ)
and then Present (Component_Associations (Expr_Q))
- and then Must_Slide (Comp_Type, Etype (Expr_Q))
+ and then Must_Slide (Comp_Typ, Etype (Expr_Q))
then
Set_Expansion_Delayed (Expr_Q, False);
Set_Analyzed (Expr_Q, False);
@@ -1131,6 +1537,59 @@ package body Exp_Aggr is
end if;
end if;
+ if Present (Expr) then
+
+ -- Handle an initialization expression of a controlled type in
+ -- case it denotes a function call. In general such a scenario
+ -- will produce a transient scope, but this will lead to wrong
+ -- order of initialization, adjustment, and finalization in the
+ -- context of aggregates.
+
+ -- Target (1) := Ctrl_Func_Call;
+
+ -- begin -- scope
+ -- Trans_Obj : ... := Ctrl_Func_Call; -- object
+ -- Target (1) := Trans_Obj;
+ -- Finalize (Trans_Obj);
+ -- end;
+ -- Target (1)._tag := ...;
+ -- Adjust (Target (1));
+
+ -- In the example above, the call to Finalize occurs too early
+ -- and as a result it may leave the array component in a bad
+ -- state. Finalization of the transient object should really
+ -- happen after adjustment.
+
+ -- To avoid this scenario, perform in-place side-effect removal
+ -- of the function call. This eliminates the transient property
+ -- of the function result and ensures correct order of actions.
+
+ -- Res : ... := Ctrl_Func_Call;
+ -- Target (1) := Res;
+ -- Target (1)._tag := ...;
+ -- Adjust (Target (1));
+ -- Finalize (Res);
+
+ if Present (Comp_Typ)
+ and then Needs_Finalization (Comp_Typ)
+ and then Nkind (Expr) /= N_Aggregate
+ then
+ Initialize_Ctrl_Array_Component
+ (Arr_Comp => Indexed_Comp,
+ Comp_Typ => Comp_Typ,
+ Init_Expr => Expr,
+ Stmts => Stmts);
+
+ -- Otherwise perform simple component initialization
+
+ else
+ Initialize_Array_Component
+ (Arr_Comp => Indexed_Comp,
+ Comp_Typ => Comp_Typ,
+ Init_Expr => Expr,
+ Stmts => Stmts);
+ end if;
+
-- Ada 2005 (AI-287): In case of default initialized component, call
-- the initialization subprogram associated with the component type.
-- If the component type is an access type, add an explicit null
@@ -1142,11 +1601,11 @@ package body Exp_Aggr is
-- its Initialize procedure explicitly, because there is no explicit
-- object creation that will invoke it otherwise.
- if No (Expr) then
+ else
if Present (Base_Init_Proc (Base_Type (Ctype)))
or else Has_Task (Base_Type (Ctype))
then
- Append_List_To (L,
+ Append_List_To (Stmts,
Build_Initialization_Call (Loc,
Id_Ref => Indexed_Comp,
Typ => Ctype,
@@ -1159,124 +1618,32 @@ package body Exp_Aggr is
if Has_Invariants (Ctype) then
Set_Etype (Indexed_Comp, Ctype);
- Append_To (L, Make_Invariant_Call (Indexed_Comp));
+ Append_To (Stmts, Make_Invariant_Call (Indexed_Comp));
end if;
elsif Is_Access_Type (Ctype) then
- Append_To (L,
+ Append_To (Stmts,
Make_Assignment_Statement (Loc,
- Name => Indexed_Comp,
+ Name => New_Copy_Tree (Indexed_Comp),
Expression => Make_Null (Loc)));
end if;
if Needs_Finalization (Ctype) then
- Append_To (L,
+ Init_Call :=
Make_Init_Call
(Obj_Ref => New_Copy_Tree (Indexed_Comp),
- Typ => Ctype));
- end if;
-
- else
- A :=
- Make_OK_Assignment_Statement (Loc,
- Name => Indexed_Comp,
- Expression => New_Copy_Tree (Expr));
+ Typ => Ctype);
- -- The target of the assignment may not have been initialized,
- -- so it is not possible to call Finalize as expected in normal
- -- controlled assignments. We must also avoid using the primitive
- -- _assign (which depends on a valid target, and may for example
- -- perform discriminant checks on it).
+ -- Guard against a missing [Deep_]Initialize when the component
+ -- type was not properly frozen.
- -- Both Finalize and usage of _assign are disabled by setting
- -- No_Ctrl_Actions on the assignment. The rest of the controlled
- -- actions are done manually with the proper finalization list
- -- coming from the context.
-
- Set_No_Ctrl_Actions (A);
-
- -- If this is an aggregate for an array of arrays, each
- -- sub-aggregate will be expanded as well, and even with
- -- No_Ctrl_Actions the assignments of inner components will
- -- require attachment in their assignments to temporaries. These
- -- temporaries must be finalized for each subaggregate, to prevent
- -- multiple attachments of the same temporary location to same
- -- finalization chain (and consequently circular lists). To ensure
- -- that finalization takes place for each subaggregate we wrap the
- -- assignment in a block.
-
- if Present (Comp_Type)
- and then Needs_Finalization (Comp_Type)
- and then Is_Array_Type (Comp_Type)
- and then Present (Expr)
- then
- A :=
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (A)));
- end if;
-
- Append_To (L, A);
-
- -- Adjust the tag if tagged (because of possible view
- -- conversions), unless compiling for a VM where tags
- -- are implicit.
-
- if Present (Comp_Type)
- and then Is_Tagged_Type (Comp_Type)
- and then Tagged_Type_Expansion
- then
- declare
- Full_Typ : constant Entity_Id := Underlying_Type (Comp_Type);
-
- begin
- A :=
- Make_OK_Assignment_Statement (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Indexed_Comp),
- Selector_Name =>
- New_Occurrence_Of
- (First_Tag_Component (Full_Typ), Loc)),
-
- Expression =>
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Occurrence_Of
- (Node (First_Elmt (Access_Disp_Table (Full_Typ))),
- Loc)));
-
- Append_To (L, A);
- end;
- end if;
-
- -- Adjust and attach the component to the proper final list, which
- -- can be the controller of the outer record object or the final
- -- list associated with the scope.
-
- -- If the component is itself an array of controlled types, whose
- -- value is given by a sub-aggregate, then the attach calls have
- -- been generated when individual subcomponent are assigned, and
- -- must not be done again to prevent malformed finalization chains
- -- (see comments above, concerning the creation of a block to hold
- -- inner finalization actions).
-
- if Present (Comp_Type)
- and then Needs_Finalization (Comp_Type)
- and then not Is_Limited_Type (Comp_Type)
- and then not
- (Is_Array_Type (Comp_Type)
- and then Is_Controlled (Component_Type (Comp_Type))
- and then Nkind (Expr) = N_Aggregate)
- then
- Append_To (L,
- Make_Adjust_Call
- (Obj_Ref => New_Copy_Tree (Indexed_Comp),
- Typ => Comp_Type));
+ if Present (Init_Call) then
+ Append_To (Stmts, Init_Call);
+ end if;
end if;
end if;
- return Add_Loop_Actions (L);
+ return Add_Loop_Actions (Stmts);
end Gen_Assign;
--------------
@@ -1284,6 +1651,9 @@ package body Exp_Aggr is
--------------
function Gen_Loop (L, H : Node_Id; Expr : Node_Id) return List_Id is
+ Is_Iterated_Component : constant Boolean :=
+ Nkind (Parent (Expr)) = N_Iterated_Component_Association;
+
L_J : Node_Id;
L_L : Node_Id;
@@ -1340,9 +1710,10 @@ package body Exp_Aggr is
return S;
- -- If loop bounds are the same then generate an assignment
+ -- If loop bounds are the same then generate an assignment, unless
+ -- the parent construct is an Iterated_Component_Association.
- elsif Equal (L, H) then
+ elsif Equal (L, H) and then not Is_Iterated_Component then
return Gen_Assign (New_Copy_Tree (L), Expr);
-- If H - L <= 2 then generate a sequence of assignments when we are
@@ -1354,8 +1725,8 @@ package body Exp_Aggr is
and then Local_Compile_Time_Known_Value (L)
and then Local_Compile_Time_Known_Value (H)
and then Local_Expr_Value (H) - Local_Expr_Value (L) <= 2
+ and then not Is_Iterated_Component
then
-
Append_List_To (S, Gen_Assign (New_Copy_Tree (L), Expr));
Append_List_To (S, Gen_Assign (Add (1, To => L), Expr));
@@ -1368,7 +1739,14 @@ package body Exp_Aggr is
-- Otherwise construct the loop, starting with the loop index L_J
- L_J := Make_Temporary (Loc, 'J', L);
+ if Is_Iterated_Component then
+ L_J :=
+ Make_Defining_Identifier (Loc,
+ Chars => (Chars (Defining_Identifier (Parent (Expr)))));
+
+ else
+ L_J := Make_Temporary (Loc, 'J', L);
+ end if;
-- Construct "L .. H" in Index_Base. We use a qualified expression
-- for the bound to convert to the index base, but we don't need
@@ -1380,7 +1758,7 @@ package body Exp_Aggr is
L_L :=
Make_Qualified_Expression (Loc,
Subtype_Mark => Index_Base_Name,
- Expression => L);
+ Expression => New_Copy_Tree (L));
end if;
if Etype (H) = Index_Base then
@@ -1389,7 +1767,7 @@ package body Exp_Aggr is
L_H :=
Make_Qualified_Expression (Loc,
Subtype_Mark => Index_Base_Name,
- Expression => H);
+ Expression => New_Copy_Tree (H));
end if;
L_Range :=
@@ -1410,7 +1788,8 @@ package body Exp_Aggr is
-- Construct the statements to execute in the loop body
- L_Body := Gen_Assign (New_Occurrence_Of (L_J, Loc), Expr);
+ L_Body :=
+ Gen_Assign (New_Occurrence_Of (L_J, Loc), Expr, In_Loop => True);
-- Construct the final loop
@@ -1517,8 +1896,9 @@ package body Exp_Aggr is
Expression => W_Index_Succ);
Append_To (W_Body, W_Increment);
+
Append_List_To (W_Body,
- Gen_Assign (New_Occurrence_Of (W_J, Loc), Expr));
+ Gen_Assign (New_Occurrence_Of (W_J, Loc), Expr, In_Loop => True));
-- Construct the final loop
@@ -1594,27 +1974,26 @@ package body Exp_Aggr is
end if;
end Local_Expr_Value;
- -- Build_Array_Aggr_Code Variables
-
- Assoc : Node_Id;
- Choice : Node_Id;
- Expr : Node_Id;
- Typ : Entity_Id;
+ -- Local variables
- Others_Assoc : Node_Id := Empty;
+ New_Code : constant List_Id := New_List;
Aggr_L : constant Node_Id := Low_Bound (Aggregate_Bounds (N));
Aggr_H : constant Node_Id := High_Bound (Aggregate_Bounds (N));
- -- The aggregate bounds of this specific sub-aggregate. Note that if
- -- the code generated by Build_Array_Aggr_Code is executed then these
- -- bounds are OK. Otherwise a Constraint_Error would have been raised.
+ -- The aggregate bounds of this specific subaggregate. Note that if the
+ -- code generated by Build_Array_Aggr_Code is executed then these bounds
+ -- are OK. Otherwise a Constraint_Error would have been raised.
Aggr_Low : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_L);
Aggr_High : constant Node_Id := Duplicate_Subexpr_No_Checks (Aggr_H);
-- After Duplicate_Subexpr these are side-effect free
- Low : Node_Id;
- High : Node_Id;
+ Assoc : Node_Id;
+ Choice : Node_Id;
+ Expr : Node_Id;
+ High : Node_Id;
+ Low : Node_Id;
+ Typ : Entity_Id;
Nb_Choices : Nat := 0;
Table : Case_Table_Type (1 .. Number_Of_Choices (N));
@@ -1623,7 +2002,7 @@ package body Exp_Aggr is
Nb_Elements : Int;
-- Number of elements in the positional aggregate
- New_Code : constant List_Id := New_List;
+ Others_Assoc : Node_Id := Empty;
-- Start of processing for Build_Array_Aggr_Code
@@ -1667,7 +2046,7 @@ package body Exp_Aggr is
Assoc := First (Component_Associations (N));
while Present (Assoc) loop
- Choice := First (Choices (Assoc));
+ Choice := First (Choice_List (Assoc));
while Present (Choice) loop
if Nkind (Choice) = N_Others_Choice then
Set_Loop_Actions (Assoc, New_List);
@@ -1860,6 +2239,11 @@ package body Exp_Aggr is
-- Returns the first discriminant association in the constraint
-- associated with T, if any, otherwise returns Empty.
+ function Get_Explicit_Discriminant_Value (D : Entity_Id) return Node_Id;
+ -- If the ancestor part is an unconstrained type and further ancestors
+ -- do not provide discriminants for it, check aggregate components for
+ -- values of the discriminants.
+
procedure Init_Hidden_Discriminants (Typ : Entity_Id; List : List_Id);
-- If Typ is derived, and constrains discriminants of the parent type,
-- these discriminants are not components of the aggregate, and must be
@@ -1867,15 +2251,53 @@ package body Exp_Aggr is
-- if Typ derives fron an already constrained subtype of a discriminated
-- parent type.
- function Get_Explicit_Discriminant_Value (D : Entity_Id) return Node_Id;
- -- If the ancestor part is an unconstrained type and further ancestors
- -- do not provide discriminants for it, check aggregate components for
- -- values of the discriminants.
+ procedure Init_Stored_Discriminants;
+ -- If the type is derived and has inherited discriminants, generate
+ -- explicit assignments for each, using the store constraint of the
+ -- type. Note that both visible and stored discriminants must be
+ -- initialized in case the derived type has some renamed and some
+ -- constrained discriminants.
+
+ procedure Init_Visible_Discriminants;
+ -- If type has discriminants, retrieve their values from aggregate,
+ -- and generate explicit assignments for each. This does not include
+ -- discriminants inherited from ancestor, which are handled above.
+ -- The type of the aggregate is a subtype created ealier using the
+ -- given values of the discriminant components of the aggregate.
+
+ procedure Initialize_Ctrl_Record_Component
+ (Rec_Comp : Node_Id;
+ Comp_Typ : Entity_Id;
+ Init_Expr : Node_Id;
+ Stmts : List_Id);
+ -- Perform the initialization of controlled record component Rec_Comp.
+ -- Comp_Typ is the component type. Init_Expr is the initialization
+ -- expression for the record component. Hook-related declarations are
+ -- inserted prior to aggregate N using Insert_Action. All remaining
+ -- generated code is added to list Stmts.
+
+ procedure Initialize_Record_Component
+ (Rec_Comp : Node_Id;
+ Comp_Typ : Entity_Id;
+ Init_Expr : Node_Id;
+ Stmts : List_Id);
+ -- Perform the initialization of record component Rec_Comp. Comp_Typ
+ -- is the component type. Init_Expr is the initialization expression
+ -- of the record component. All generated code is added to list Stmts.
function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean;
-- Check whether Bounds is a range node and its lower and higher bounds
-- are integers literals.
+ function Replace_Type (Expr : Node_Id) return Traverse_Result;
+ -- If the aggregate contains a self-reference, traverse each expression
+ -- to replace a possible self-reference with a reference to the proper
+ -- component of the target of the assignment.
+
+ function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result;
+ -- If default expression of a component mentions a discriminant of the
+ -- type, it must be rewritten as the discriminant of the target object.
+
---------------------------------
-- Ancestor_Discriminant_Value --
---------------------------------
@@ -2055,6 +2477,39 @@ package body Exp_Aggr is
return Typ_Lo <= Agg_Lo and then Agg_Hi <= Typ_Hi;
end Compatible_Int_Bounds;
+ -----------------------------------
+ -- Generate_Finalization_Actions --
+ -----------------------------------
+
+ procedure Generate_Finalization_Actions is
+ begin
+ -- Do the work only the first time this is called
+
+ if Finalization_Done then
+ return;
+ end if;
+
+ Finalization_Done := True;
+
+ -- Determine the external finalization list. It is either the
+ -- finalization list of the outer scope or the one coming from an
+ -- outer aggregate. When the target is not a temporary, the proper
+ -- scope is the scope of the target rather than the potentially
+ -- transient current scope.
+
+ if Is_Controlled (Typ) and then Ancestor_Is_Subtype_Mark then
+ Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
+ Set_Assignment_OK (Ref);
+
+ Append_To (L,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Find_Prim_Op (Init_Typ, Name_Initialize), Loc),
+ Parameter_Associations => New_List (New_Copy_Tree (Ref))));
+ end if;
+ end Generate_Finalization_Actions;
+
--------------------------------
-- Get_Constraint_Association --
--------------------------------
@@ -2260,80 +2715,299 @@ package body Exp_Aggr is
end loop;
end Init_Hidden_Discriminants;
- -------------------------
- -- Is_Int_Range_Bounds --
- -------------------------
+ --------------------------------
+ -- Init_Visible_Discriminants --
+ --------------------------------
+
+ procedure Init_Visible_Discriminants is
+ Discriminant : Entity_Id;
+ Discriminant_Value : Node_Id;
- function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean is
begin
- return Nkind (Bounds) = N_Range
- and then Nkind (Low_Bound (Bounds)) = N_Integer_Literal
- and then Nkind (High_Bound (Bounds)) = N_Integer_Literal;
- end Is_Int_Range_Bounds;
+ Discriminant := First_Discriminant (Typ);
+ while Present (Discriminant) loop
+ Comp_Expr :=
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Target),
+ Selector_Name => New_Occurrence_Of (Discriminant, Loc));
- -----------------------------------
- -- Generate_Finalization_Actions --
- -----------------------------------
+ Discriminant_Value :=
+ Get_Discriminant_Value
+ (Discriminant, Typ, Discriminant_Constraint (N_Typ));
+
+ Instr :=
+ Make_OK_Assignment_Statement (Loc,
+ Name => Comp_Expr,
+ Expression => New_Copy_Tree (Discriminant_Value));
+
+ Set_No_Ctrl_Actions (Instr);
+ Append_To (L, Instr);
+
+ Next_Discriminant (Discriminant);
+ end loop;
+ end Init_Visible_Discriminants;
+
+ -------------------------------
+ -- Init_Stored_Discriminants --
+ -------------------------------
+
+ procedure Init_Stored_Discriminants is
+ Discriminant : Entity_Id;
+ Discriminant_Value : Node_Id;
- procedure Generate_Finalization_Actions is
begin
- -- Do the work only the first time this is called
+ Discriminant := First_Stored_Discriminant (Typ);
+ while Present (Discriminant) loop
+ Comp_Expr :=
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Target),
+ Selector_Name => New_Occurrence_Of (Discriminant, Loc));
- if Finalization_Done then
- return;
+ Discriminant_Value :=
+ Get_Discriminant_Value
+ (Discriminant, N_Typ, Discriminant_Constraint (N_Typ));
+
+ Instr :=
+ Make_OK_Assignment_Statement (Loc,
+ Name => Comp_Expr,
+ Expression => New_Copy_Tree (Discriminant_Value));
+
+ Set_No_Ctrl_Actions (Instr);
+ Append_To (L, Instr);
+
+ Next_Stored_Discriminant (Discriminant);
+ end loop;
+ end Init_Stored_Discriminants;
+
+ --------------------------------------
+ -- Initialize_Ctrl_Record_Component --
+ --------------------------------------
+
+ procedure Initialize_Ctrl_Record_Component
+ (Rec_Comp : Node_Id;
+ Comp_Typ : Entity_Id;
+ Init_Expr : Node_Id;
+ Stmts : List_Id)
+ is
+ Fin_Call : Node_Id;
+ Hook_Clear : Node_Id;
+
+ In_Place_Expansion : Boolean;
+ -- Flag set when a nonlimited controlled function call requires
+ -- in-place expansion.
+
+ begin
+ -- Perform a preliminary analysis and resolution to determine what
+ -- the initialization expression denotes. Unanalyzed function calls
+ -- may appear as identifiers or indexed components.
+
+ if Nkind_In (Init_Expr, N_Function_Call,
+ N_Identifier,
+ N_Indexed_Component)
+ and then not Analyzed (Init_Expr)
+ then
+ Preanalyze_And_Resolve (Init_Expr, Comp_Typ);
end if;
- Finalization_Done := True;
+ In_Place_Expansion :=
+ Nkind (Init_Expr) = N_Function_Call
+ and then not Is_Limited_Type (Comp_Typ);
- -- Determine the external finalization list. It is either the
- -- finalization list of the outer-scope or the one coming from an
- -- outer aggregate. When the target is not a temporary, the proper
- -- scope is the scope of the target rather than the potentially
- -- transient current scope.
+ -- The initialization expression is a controlled function call.
+ -- Perform in-place removal of side effects to avoid creating a
+ -- transient scope.
- if Is_Controlled (Typ) and then Ancestor_Is_Subtype_Mark then
- Ref := Convert_To (Init_Typ, New_Copy_Tree (Target));
- Set_Assignment_OK (Ref);
+ -- This in-place expansion is not performed for limited transient
+ -- objects because the initialization is already done in place.
- Append_To (L,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (Find_Prim_Op (Init_Typ, Name_Initialize), Loc),
- Parameter_Associations => New_List (New_Copy_Tree (Ref))));
+ if In_Place_Expansion then
+
+ -- Suppress the removal of side effects by general analysis
+ -- because this behavior is emulated here. This avoids the
+ -- generation of a transient scope, which leads to out-of-order
+ -- adjustment and finalization.
+
+ Set_No_Side_Effect_Removal (Init_Expr);
+
+ -- Install all hook-related declarations and prepare the clean up
+ -- statements.
+
+ Process_Transient_Component
+ (Loc => Loc,
+ Comp_Typ => Comp_Typ,
+ Init_Expr => Init_Expr,
+ Fin_Call => Fin_Call,
+ Hook_Clear => Hook_Clear,
+ Aggr => N);
end if;
- end Generate_Finalization_Actions;
- function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result;
- -- If default expression of a component mentions a discriminant of the
- -- type, it must be rewritten as the discriminant of the target object.
+ -- Use the noncontrolled component initialization circuitry to
+ -- assign the result of the function call to the record component.
+ -- This also performs tag adjustment and [deep] adjustment of the
+ -- record component.
+
+ Initialize_Record_Component
+ (Rec_Comp => Rec_Comp,
+ Comp_Typ => Comp_Typ,
+ Init_Expr => Init_Expr,
+ Stmts => Stmts);
+
+ -- At this point the record component is fully initialized. Complete
+ -- the processing of the controlled record component by finalizing
+ -- the transient function result.
+
+ if In_Place_Expansion then
+ Process_Transient_Component_Completion
+ (Loc => Loc,
+ Aggr => N,
+ Fin_Call => Fin_Call,
+ Hook_Clear => Hook_Clear,
+ Stmts => Stmts);
+ end if;
+ end Initialize_Ctrl_Record_Component;
- function Replace_Type (Expr : Node_Id) return Traverse_Result;
- -- If the aggregate contains a self-reference, traverse each expression
- -- to replace a possible self-reference with a reference to the proper
- -- component of the target of the assignment.
+ ---------------------------------
+ -- Initialize_Record_Component --
+ ---------------------------------
- --------------------------
- -- Rewrite_Discriminant --
- --------------------------
+ procedure Initialize_Record_Component
+ (Rec_Comp : Node_Id;
+ Comp_Typ : Entity_Id;
+ Init_Expr : Node_Id;
+ Stmts : List_Id)
+ is
+ Exceptions_OK : constant Boolean :=
+ not Restriction_Active (No_Exception_Propagation);
+
+ Finalization_OK : constant Boolean := Needs_Finalization (Comp_Typ);
+
+ Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ);
+ Adj_Call : Node_Id;
+ Blk_Stmts : List_Id;
+ Init_Stmt : Node_Id;
- function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result is
begin
- if Is_Entity_Name (Expr)
- and then Present (Entity (Expr))
- and then Ekind (Entity (Expr)) = E_In_Parameter
- and then Present (Discriminal_Link (Entity (Expr)))
- and then Scope (Discriminal_Link (Entity (Expr))) =
- Base_Type (Etype (N))
- then
- Rewrite (Expr,
- Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Lhs),
- Selector_Name => Make_Identifier (Loc, Chars (Expr))));
+ -- Protect the initialization statements from aborts. Generate:
+
+ -- Abort_Defer;
+
+ if Finalization_OK and Abort_Allowed then
+ if Exceptions_OK then
+ Blk_Stmts := New_List;
+ else
+ Blk_Stmts := Stmts;
+ end if;
+
+ Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
+
+ -- Otherwise aborts are not allowed. All generated code is added
+ -- directly to the input list.
+
+ else
+ Blk_Stmts := Stmts;
end if;
- return OK;
- end Rewrite_Discriminant;
+ -- Initialize the record component. Generate:
+
+ -- Rec_Comp := Init_Expr;
+
+ -- Note that the initialization expression is NOT replicated because
+ -- only a single component may be initialized by it.
+
+ Init_Stmt :=
+ Make_OK_Assignment_Statement (Loc,
+ Name => New_Copy_Tree (Rec_Comp),
+ Expression => Init_Expr);
+ Set_No_Ctrl_Actions (Init_Stmt);
+
+ Append_To (Blk_Stmts, Init_Stmt);
+
+ -- Adjust the tag due to a possible view conversion. Generate:
+
+ -- Rec_Comp._tag := Full_TypeP;
+
+ if Tagged_Type_Expansion and then Is_Tagged_Type (Comp_Typ) then
+ Append_To (Blk_Stmts,
+ Make_OK_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Rec_Comp),
+ Selector_Name =>
+ New_Occurrence_Of
+ (First_Tag_Component (Full_Typ), Loc)),
+
+ Expression =>
+ Unchecked_Convert_To (RTE (RE_Tag),
+ New_Occurrence_Of
+ (Node (First_Elmt (Access_Disp_Table (Full_Typ))),
+ Loc))));
+ end if;
+
+ -- Adjust the component. Generate:
+
+ -- [Deep_]Adjust (Rec_Comp);
+
+ if Finalization_OK and then not Is_Limited_Type (Comp_Typ) then
+ Adj_Call :=
+ Make_Adjust_Call
+ (Obj_Ref => New_Copy_Tree (Rec_Comp),
+ Typ => Comp_Typ);
+
+ -- Guard against a missing [Deep_]Adjust when the component type
+ -- was not properly frozen.
+
+ if Present (Adj_Call) then
+ Append_To (Blk_Stmts, Adj_Call);
+ end if;
+ end if;
+
+ -- Complete the protection of the initialization statements
+
+ if Finalization_OK and Abort_Allowed then
+
+ -- Wrap the initialization statements in a block to catch a
+ -- potential exception. Generate:
+
+ -- begin
+ -- Abort_Defer;
+ -- Rec_Comp := Init_Expr;
+ -- Rec_Comp._tag := Full_TypP;
+ -- [Deep_]Adjust (Rec_Comp);
+ -- at end
+ -- Abort_Undefer_Direct;
+ -- end;
+
+ if Exceptions_OK then
+ Append_To (Stmts,
+ Build_Abort_Undefer_Block (Loc,
+ Stmts => Blk_Stmts,
+ Context => N));
+
+ -- Otherwise exceptions are not propagated. Generate:
+
+ -- Abort_Defer;
+ -- Rec_Comp := Init_Expr;
+ -- Rec_Comp._tag := Full_TypP;
+ -- [Deep_]Adjust (Rec_Comp);
+ -- Abort_Undefer;
+
+ else
+ Append_To (Blk_Stmts,
+ Build_Runtime_Call (Loc, RE_Abort_Undefer));
+ end if;
+ end if;
+ end Initialize_Record_Component;
+
+ -------------------------
+ -- Is_Int_Range_Bounds --
+ -------------------------
+
+ function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean is
+ begin
+ return Nkind (Bounds) = N_Range
+ and then Nkind (Low_Bound (Bounds)) = N_Integer_Literal
+ and then Nkind (High_Bound (Bounds)) = N_Integer_Literal;
+ end Is_Int_Range_Bounds;
------------------
-- Replace_Type --
@@ -2378,12 +3052,34 @@ package body Exp_Aggr is
return OK;
end Replace_Type;
- procedure Replace_Self_Reference is
- new Traverse_Proc (Replace_Type);
+ --------------------------
+ -- Rewrite_Discriminant --
+ --------------------------
+
+ function Rewrite_Discriminant (Expr : Node_Id) return Traverse_Result is
+ begin
+ if Is_Entity_Name (Expr)
+ and then Present (Entity (Expr))
+ and then Ekind (Entity (Expr)) = E_In_Parameter
+ and then Present (Discriminal_Link (Entity (Expr)))
+ and then Scope (Discriminal_Link (Entity (Expr))) =
+ Base_Type (Etype (N))
+ then
+ Rewrite (Expr,
+ Make_Selected_Component (Loc,
+ Prefix => New_Copy_Tree (Lhs),
+ Selector_Name => Make_Identifier (Loc, Chars (Expr))));
+ end if;
+
+ return OK;
+ end Rewrite_Discriminant;
procedure Replace_Discriminants is
new Traverse_Proc (Rewrite_Discriminant);
+ procedure Replace_Self_Reference is
+ new Traverse_Proc (Replace_Type);
+
-- Start of processing for Build_Record_Aggr_Code
begin
@@ -2409,6 +3105,7 @@ package body Exp_Aggr is
if Nkind (N) = N_Extension_Aggregate then
declare
Ancestor : constant Node_Id := Ancestor_Part (N);
+ Adj_Call : Node_Id;
Assign : List_Id;
begin
@@ -2621,10 +3318,17 @@ package body Exp_Aggr is
if Needs_Finalization (Etype (Ancestor))
and then not Is_Limited_Type (Etype (Ancestor))
then
- Append_To (Assign,
+ Adj_Call :=
Make_Adjust_Call
(Obj_Ref => New_Copy_Tree (Ref),
- Typ => Etype (Ancestor)));
+ Typ => Etype (Ancestor));
+
+ -- Guard against a missing [Deep_]Adjust when the ancestor
+ -- type was not properly frozen.
+
+ if Present (Adj_Call) then
+ Append_To (Assign, Adj_Call);
+ end if;
end if;
Append_To (L,
@@ -2662,35 +3366,11 @@ package body Exp_Aggr is
-- Generate discriminant init values for the visible discriminants
- declare
- Discriminant : Entity_Id;
- Discriminant_Value : Node_Id;
-
- begin
- Discriminant := First_Stored_Discriminant (Typ);
- while Present (Discriminant) loop
- Comp_Expr :=
- Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Target),
- Selector_Name => New_Occurrence_Of (Discriminant, Loc));
-
- Discriminant_Value :=
- Get_Discriminant_Value
- (Discriminant,
- N_Typ,
- Discriminant_Constraint (N_Typ));
-
- Instr :=
- Make_OK_Assignment_Statement (Loc,
- Name => Comp_Expr,
- Expression => New_Copy_Tree (Discriminant_Value));
-
- Set_No_Ctrl_Actions (Instr);
- Append_To (L, Instr);
+ Init_Visible_Discriminants;
- Next_Stored_Discriminant (Discriminant);
- end loop;
- end;
+ if Is_Derived_Type (N_Typ) then
+ Init_Stored_Discriminants;
+ end if;
end if;
end if;
@@ -2980,7 +3660,7 @@ package body Exp_Aggr is
end if;
end if;
- if Generate_C_Code
+ if Modify_Tree_For_C
and then Nkind (Expr_Q) = N_Aggregate
and then Is_Array_Type (Etype (Expr_Q))
and then Present (First_Index (Etype (Expr_Q)))
@@ -2994,57 +3674,61 @@ package body Exp_Aggr is
Ctype => Component_Type (Expr_Q_Type),
Index => First_Index (Expr_Q_Type),
Into => Comp_Expr,
- Scalar_Comp => Is_Scalar_Type
- (Component_Type (Expr_Q_Type))));
+ Scalar_Comp =>
+ Is_Scalar_Type (Component_Type (Expr_Q_Type))));
end;
else
- Instr :=
- Make_OK_Assignment_Statement (Loc,
- Name => Comp_Expr,
- Expression => Expr_Q);
-
- Set_No_Ctrl_Actions (Instr);
- Append_To (L, Instr);
- end if;
-
- -- Adjust the tag if tagged (because of possible view
- -- conversions), unless compiling for a VM where tags are
- -- implicit.
-
- -- tmp.comp._tag := comp_typ'tag;
-
- if Is_Tagged_Type (Comp_Type)
- and then Tagged_Type_Expansion
- then
- Instr :=
- Make_OK_Assignment_Statement (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Comp_Expr),
- Selector_Name =>
- New_Occurrence_Of
- (First_Tag_Component (Comp_Type), Loc)),
-
- Expression =>
- Unchecked_Convert_To (RTE (RE_Tag),
- New_Occurrence_Of
- (Node (First_Elmt (Access_Disp_Table (Comp_Type))),
- Loc)));
-
- Append_To (L, Instr);
- end if;
+ -- Handle an initialization expression of a controlled type
+ -- in case it denotes a function call. In general such a
+ -- scenario will produce a transient scope, but this will
+ -- lead to wrong order of initialization, adjustment, and
+ -- finalization in the context of aggregates.
+
+ -- Target.Comp := Ctrl_Func_Call;
+
+ -- begin -- scope
+ -- Trans_Obj : ... := Ctrl_Func_Call; -- object
+ -- Target.Comp := Trans_Obj;
+ -- Finalize (Trans_Obj);
+ -- end
+ -- Target.Comp._tag := ...;
+ -- Adjust (Target.Comp);
+
+ -- In the example above, the call to Finalize occurs too
+ -- early and as a result it may leave the record component
+ -- in a bad state. Finalization of the transient object
+ -- should really happen after adjustment.
+
+ -- To avoid this scenario, perform in-place side-effect
+ -- removal of the function call. This eliminates the
+ -- transient property of the function result and ensures
+ -- correct order of actions.
+
+ -- Res : ... := Ctrl_Func_Call;
+ -- Target.Comp := Res;
+ -- Target.Comp._tag := ...;
+ -- Adjust (Target.Comp);
+ -- Finalize (Res);
+
+ if Needs_Finalization (Comp_Type)
+ and then Nkind (Expr_Q) /= N_Aggregate
+ then
+ Initialize_Ctrl_Record_Component
+ (Rec_Comp => Comp_Expr,
+ Comp_Typ => Etype (Selector),
+ Init_Expr => Expr_Q,
+ Stmts => L);
- -- Generate:
- -- Adjust (tmp.comp);
+ -- Otherwise perform single component initialization
- if Needs_Finalization (Comp_Type)
- and then not Is_Limited_Type (Comp_Type)
- then
- Append_To (L,
- Make_Adjust_Call
- (Obj_Ref => New_Copy_Tree (Comp_Expr),
- Typ => Comp_Type));
+ else
+ Initialize_Record_Component
+ (Rec_Comp => Comp_Expr,
+ Comp_Typ => Etype (Selector),
+ Init_Expr => Expr_Q,
+ Stmts => L);
+ end if;
end if;
end if;
@@ -3448,19 +4132,17 @@ package body Exp_Aggr is
-- case the current delayed expansion mechanism doesn't work when
-- the declared object size depend on the initializing expr.
- begin
- Parent_Node := Parent (Parent_Node);
- Parent_Kind := Nkind (Parent_Node);
+ Parent_Node := Parent (Parent_Node);
+ Parent_Kind := Nkind (Parent_Node);
- if Parent_Kind = N_Object_Declaration then
- Unc_Decl :=
- not Is_Entity_Name (Object_Definition (Parent_Node))
- or else Has_Discriminants
- (Entity (Object_Definition (Parent_Node)))
- or else Is_Class_Wide_Type
- (Entity (Object_Definition (Parent_Node)));
- end if;
- end;
+ if Parent_Kind = N_Object_Declaration then
+ Unc_Decl :=
+ not Is_Entity_Name (Object_Definition (Parent_Node))
+ or else Has_Discriminants
+ (Entity (Object_Definition (Parent_Node)))
+ or else Is_Class_Wide_Type
+ (Entity (Object_Definition (Parent_Node)));
+ end if;
end if;
-- Just set the Delay flag in the cases where the transformation will be
@@ -3514,13 +4196,14 @@ package body Exp_Aggr is
-- the target of the assignment must not be declared within a local
-- block, and because cleanup will take place on return from the
-- initialization procedure.
+
-- Should the condition be more restrictive ???
if Requires_Transient_Scope (Typ) and then not Inside_Init_Proc then
Establish_Transient_Scope (N, Sec_Stack => Needs_Finalization (Typ));
end if;
- -- If the aggregate is non-limited, create a temporary. If it is limited
+ -- If the aggregate is nonlimited, create a temporary. If it is limited
-- and context is an assignment, this is a subaggregate for an enclosing
-- aggregate being expanded. It must be built in place, so use target of
-- the current assignment.
@@ -3591,6 +4274,8 @@ package body Exp_Aggr is
-- Check whether all components of the aggregate are compile-time known
-- values, and can be passed as is to the back-end without further
-- expansion.
+ -- An Iterated_component_Association is treated as non-static, but there
+ -- are possibilities for optimization here.
function Flatten
(N : Node_Id;
@@ -3654,6 +4339,7 @@ package body Exp_Aggr is
elsif Nkind (Expression (Expr)) /= N_Aggregate
or else not Compile_Time_Known_Aggregate (Expression (Expr))
or else Expansion_Delayed (Expression (Expr))
+ or else Nkind (Expr) = N_Iterated_Component_Association
then
Static_Components := False;
exit;
@@ -3713,9 +4399,12 @@ package body Exp_Aggr is
if Box_Present (Assoc) then
return False;
+
+ elsif Nkind (Assoc) = N_Iterated_Component_Association then
+ return False;
end if;
- Choice := First (Choices (Assoc));
+ Choice := First (Choice_List (Assoc));
while Present (Choice) loop
if Nkind (Choice) = N_Others_Choice then
@@ -3796,7 +4485,7 @@ package body Exp_Aggr is
end if;
Component_Loop : while Present (Elmt) loop
- Choice := First (Choices (Elmt));
+ Choice := First (Choice_List (Elmt));
Choice_Loop : while Present (Choice) loop
-- If we have an others choice, fill in the missing elements
@@ -4033,7 +4722,7 @@ package body Exp_Aggr is
Analyze_And_Resolve (N, Typ);
end if;
- -- Is Static_Eaboration_Desired has been specified, diagnose aggregates
+ -- If Static_Elaboration_Desired has been specified, diagnose aggregates
-- that will still require initialization code.
if (Ekind (Current_Scope) = E_Package
@@ -4132,8 +4821,8 @@ package body Exp_Aggr is
Others_Present : array (1 .. Aggr_Dimension) of Boolean :=
(others => False);
- -- If Others_Present (J) is True, then there is an others choice
- -- in one of the sub-aggregates of N at dimension J.
+ -- If Others_Present (J) is True, then there is an others choice in one
+ -- of the subaggregates of N at dimension J.
function Aggr_Assignment_OK_For_Backend (N : Node_Id) return Boolean;
-- Returns true if an aggregate assignment can be done by the back end
@@ -4148,15 +4837,15 @@ package body Exp_Aggr is
-- by Index_Bounds.
procedure Check_Same_Aggr_Bounds (Sub_Aggr : Node_Id; Dim : Pos);
- -- Checks that in a multi-dimensional array aggregate all subaggregates
- -- corresponding to the same dimension have the same bounds.
- -- Sub_Aggr is an array sub-aggregate. Dim is the dimension
- -- corresponding to the sub-aggregate.
+ -- Checks that in a multidimensional array aggregate all subaggregates
+ -- corresponding to the same dimension have the same bounds. Sub_Aggr is
+ -- an array subaggregate. Dim is the dimension corresponding to the
+ -- subaggregate.
procedure Compute_Others_Present (Sub_Aggr : Node_Id; Dim : Pos);
- -- Computes the values of array Others_Present. Sub_Aggr is the
- -- array sub-aggregate we start the computation from. Dim is the
- -- dimension corresponding to the sub-aggregate.
+ -- Computes the values of array Others_Present. Sub_Aggr is the array
+ -- subaggregate we start the computation from. Dim is the dimension
+ -- corresponding to the subaggregate.
function In_Place_Assign_OK return Boolean;
-- Simple predicate to determine whether an aggregate assignment can
@@ -4164,15 +4853,15 @@ package body Exp_Aggr is
-- components of the target of the assignment.
procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos);
- -- Checks that if an others choice is present in any sub-aggregate no
+ -- Checks that if an others choice is present in any subaggregate, no
-- aggregate index is outside the bounds of the index constraint.
- -- Sub_Aggr is an array sub-aggregate. Dim is the dimension
- -- corresponding to the sub-aggregate.
+ -- Sub_Aggr is an array subaggregate. Dim is the dimension corresponding
+ -- to the subaggregate.
function Safe_Left_Hand_Side (N : Node_Id) return Boolean;
-- In addition to Maybe_In_Place_OK, in order for an aggregate to be
-- built directly into the target of the assignment it must be free
- -- of side-effects.
+ -- of side effects.
------------------------------------
-- Aggr_Assignment_OK_For_Backend --
@@ -4259,6 +4948,13 @@ package body Exp_Aggr is
end if;
end loop;
+ -- An Iterated_Component_Association involves a loop (in most cases)
+ -- and is never static.
+
+ if Nkind (Parent (Expr)) = N_Iterated_Component_Association then
+ return False;
+ end if;
+
if not Is_Discrete_Type (Ctyp) then
return False;
end if;
@@ -4321,7 +5017,7 @@ package body Exp_Aggr is
Decl : Node_Id;
Typ : constant Entity_Id := Etype (N);
Indexes : constant List_Id := New_List;
- Num : Int;
+ Num : Nat;
Sub_Agg : Node_Id;
begin
@@ -4461,7 +5157,7 @@ package body Exp_Aggr is
procedure Check_Same_Aggr_Bounds (Sub_Aggr : Node_Id; Dim : Pos) is
Sub_Lo : constant Node_Id := Low_Bound (Aggregate_Bounds (Sub_Aggr));
Sub_Hi : constant Node_Id := High_Bound (Aggregate_Bounds (Sub_Aggr));
- -- The bounds of this specific sub-aggregate
+ -- The bounds of this specific subaggregate
Aggr_Lo : constant Node_Id := Aggr_Low (Dim);
Aggr_Hi : constant Node_Id := Aggr_High (Dim);
@@ -4525,7 +5221,7 @@ package body Exp_Aggr is
Reason => CE_Length_Check_Failed));
end if;
- -- Now look inside the sub-aggregate to see if there is more work
+ -- Now look inside the subaggregate to see if there is more work
if Dim < Aggr_Dimension then
@@ -4564,12 +5260,12 @@ package body Exp_Aggr is
if Present (Component_Associations (Sub_Aggr)) then
Assoc := Last (Component_Associations (Sub_Aggr));
- if Nkind (First (Choices (Assoc))) = N_Others_Choice then
+ if Nkind (First (Choice_List (Assoc))) = N_Others_Choice then
Others_Present (Dim) := True;
end if;
end if;
- -- Now look inside the sub-aggregate to see if there is more work
+ -- Now look inside the subaggregate to see if there is more work
if Dim < Aggr_Dimension then
@@ -4609,8 +5305,8 @@ package body Exp_Aggr is
Obj_Hi : Node_Id;
function Safe_Aggregate (Aggr : Node_Id) return Boolean;
- -- Check recursively that each component of a (sub)aggregate does
- -- not depend on the variable being assigned to.
+ -- Check recursively that each component of a (sub)aggregate does not
+ -- depend on the variable being assigned to.
function Safe_Component (Expr : Node_Id) return Boolean;
-- Verify that an expression cannot depend on the variable being
@@ -4819,10 +5515,10 @@ package body Exp_Aggr is
Choices_Lo : Node_Id := Empty;
Choices_Hi : Node_Id := Empty;
- -- The lowest and highest discrete choices for a named sub-aggregate
+ -- The lowest and highest discrete choices for a named subaggregate
Nb_Choices : Int := -1;
- -- The number of discrete non-others choices in this sub-aggregate
+ -- The number of discrete non-others choices in this subaggregate
Nb_Elements : Uint := Uint_0;
-- The number of elements in a positional aggregate
@@ -4835,7 +5531,7 @@ package body Exp_Aggr is
begin
-- Check if we have an others choice. If we do make sure that this
- -- sub-aggregate contains at least one element in addition to the
+ -- subaggregate contains at least one element in addition to the
-- others choice.
if Range_Checks_Suppressed (Ind_Typ) then
@@ -4849,7 +5545,7 @@ package body Exp_Aggr is
elsif Present (Component_Associations (Sub_Aggr)) then
Assoc := Last (Component_Associations (Sub_Aggr));
- if Nkind (First (Choices (Assoc))) /= N_Others_Choice then
+ if Nkind (First (Choice_List (Assoc))) /= N_Others_Choice then
Need_To_Check := False;
else
@@ -4861,7 +5557,7 @@ package body Exp_Aggr is
Nb_Choices := -1;
Assoc := First (Component_Associations (Sub_Aggr));
while Present (Assoc) loop
- Choice := First (Choices (Assoc));
+ Choice := First (Choice_List (Assoc));
while Present (Choice) loop
Nb_Choices := Nb_Choices + 1;
Next (Choice);
@@ -4879,7 +5575,7 @@ package body Exp_Aggr is
Need_To_Check := False;
end if;
- -- If we are dealing with a positional sub-aggregate with an others
+ -- If we are dealing with a positional subaggregate with an others
-- choice then compute the number or positional elements.
if Need_To_Check and then Present (Expressions (Sub_Aggr)) then
@@ -4906,7 +5602,7 @@ package body Exp_Aggr is
begin
Assoc := First (Component_Associations (Sub_Aggr));
while Present (Assoc) loop
- Choice := First (Choices (Assoc));
+ Choice := First (Choice_List (Assoc));
while Present (Choice) loop
if Nkind (Choice) = N_Others_Choice then
exit;
@@ -4932,7 +5628,7 @@ package body Exp_Aggr is
end Compute_Choices_Lo_And_Choices_Hi;
end if;
- -- If no others choice in this sub-aggregate, or the aggregate
+ -- If no others choice in this subaggregate, or the aggregate
-- comprises only an others choice, nothing to do.
if not Need_To_Check then
@@ -4997,7 +5693,7 @@ package body Exp_Aggr is
-- CE_Range_Check_Failed ???
end if;
- -- Now look inside the sub-aggregate to see if there is more work
+ -- Now look inside the subaggregate to see if there is more work
if Dim < Aggr_Dimension then
@@ -5031,7 +5727,7 @@ package body Exp_Aggr is
function Safe_Left_Hand_Side (N : Node_Id) return Boolean is
function Is_Safe_Index (Indx : Node_Id) return Boolean;
-- If the left-hand side includes an indexed component, check that
- -- the indexes are free of side-effect.
+ -- the indexes are free of side effects.
-------------------
-- Is_Safe_Index --
@@ -5157,17 +5853,17 @@ package body Exp_Aggr is
for J in 1 .. Aggr_Dimension loop
-- There is no need to emit a check if an others choice is present
-- for this array aggregate dimension since in this case one of
- -- N's sub-aggregates has taken its bounds from the context and
+ -- N's subaggregates has taken its bounds from the context and
-- these bounds must have been checked already. In addition all
- -- sub-aggregates corresponding to the same dimension must all
- -- have the same bounds (checked in (c) below).
+ -- subaggregates corresponding to the same dimension must all have
+ -- the same bounds (checked in (c) below).
if not Range_Checks_Suppressed (Etype (Index_Constraint))
and then not Others_Present (J)
then
-- We don't use Checks.Apply_Range_Check here because it emits
-- a spurious check. Namely it checks that the range defined by
- -- the aggregate bounds is non empty. But we know this already
+ -- the aggregate bounds is nonempty. But we know this already
-- if we get here.
Check_Bounds (Aggr_Index_Range, Index_Constraint);
@@ -5324,8 +6020,8 @@ package body Exp_Aggr is
-- STEP 3
- -- Delay expansion for nested aggregates: it will be taken care of
- -- when the parent aggregate is expanded.
+ -- Delay expansion for nested aggregates: it will be taken care of when
+ -- the parent aggregate is expanded.
Parent_Node := Parent (N);
Parent_Kind := Nkind (Parent_Node);
@@ -5408,21 +6104,26 @@ package body Exp_Aggr is
-- object. (Note: we don't use a block statement because this would
-- cause generated freeze nodes to be elaborated in the wrong scope).
- -- Should document these individual tests ???
+ -- Do not perform in-place expansion for SPARK 05 because aggregates are
+ -- expected to appear in qualified form. In-place expansion eliminates
+ -- the qualification and eventually violates this SPARK 05 restiction.
+
+ -- Should document the rest of the guards ???
if not Has_Default_Init_Comps (N)
- and then Comes_From_Source (Parent_Node)
- and then Parent_Kind = N_Object_Declaration
- and then not
- Must_Slide (Etype (Defining_Identifier (Parent_Node)), Typ)
- and then N = Expression (Parent_Node)
- and then not Is_Bit_Packed_Array (Typ)
- and then not Has_Controlled_Component (Typ)
+ and then Comes_From_Source (Parent_Node)
+ and then Parent_Kind = N_Object_Declaration
+ and then Present (Expression (Parent_Node))
+ and then not
+ Must_Slide (Etype (Defining_Identifier (Parent_Node)), Typ)
+ and then not Has_Controlled_Component (Typ)
+ and then not Is_Bit_Packed_Array (Typ)
+ and then not Restriction_Check_Required (SPARK_05)
then
In_Place_Assign_OK_For_Declaration := True;
- Tmp := Defining_Identifier (Parent (N));
- Set_No_Initialization (Parent (N));
- Set_Expression (Parent (N), Empty);
+ Tmp := Defining_Identifier (Parent_Node);
+ Set_No_Initialization (Parent_Node);
+ Set_Expression (Parent_Node, Empty);
-- Set kind and type of the entity, for use in the analysis
-- of the subsequent assignments. If the nominal type is not
@@ -5435,10 +6136,10 @@ package body Exp_Aggr is
if not Is_Constrained (Typ) then
Build_Constrained_Type (Positional => False);
- elsif Is_Entity_Name (Object_Definition (Parent (N)))
- and then Is_Constrained (Entity (Object_Definition (Parent (N))))
+ elsif Is_Entity_Name (Object_Definition (Parent_Node))
+ and then Is_Constrained (Entity (Object_Definition (Parent_Node)))
then
- Set_Etype (Tmp, Entity (Object_Definition (Parent (N))));
+ Set_Etype (Tmp, Entity (Object_Definition (Parent_Node)));
else
Set_Size_Known_At_Compile_Time (Typ, False);
@@ -5547,7 +6248,7 @@ package body Exp_Aggr is
if (In_Place_Assign_OK_For_Declaration or else Maybe_In_Place_OK)
and then not AAMP_On_Target
and then not CodePeer_Mode
- and then not Generate_C_Code
+ and then not Modify_Tree_For_C
and then not Possible_Bit_Aligned_Component (Target)
and then not Is_Possibly_Unaligned_Slice (Target)
and then Aggr_Assignment_OK_For_Backend (N)
@@ -5679,7 +6380,7 @@ package body Exp_Aggr is
MX : constant := 80;
begin
- if Nkind (First (Choices (CA))) = N_Others_Choice
+ if Nkind (First (Choice_List (CA))) = N_Others_Choice
and then Nkind (Expression (CA)) = N_Character_Literal
and then No (Expressions (N))
then
@@ -5738,6 +6439,165 @@ package body Exp_Aggr is
return;
end Expand_N_Aggregate;
+ ------------------------------
+ -- Expand_N_Delta_Aggregate --
+ ------------------------------
+
+ procedure Expand_N_Delta_Aggregate (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Typ : constant Entity_Id := Etype (N);
+ Decl : Node_Id;
+
+ begin
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Make_Temporary (Loc, 'T'),
+ Object_Definition => New_Occurrence_Of (Typ, Loc),
+ Expression => New_Copy_Tree (Expression (N)));
+
+ if Is_Array_Type (Etype (N)) then
+ Expand_Delta_Array_Aggregate (N, New_List (Decl));
+ else
+ Expand_Delta_Record_Aggregate (N, New_List (Decl));
+ end if;
+ end Expand_N_Delta_Aggregate;
+
+ ----------------------------------
+ -- Expand_Delta_Array_Aggregate --
+ ----------------------------------
+
+ procedure Expand_Delta_Array_Aggregate (N : Node_Id; Deltas : List_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Temp : constant Entity_Id := Defining_Identifier (First (Deltas));
+ Assoc : Node_Id;
+
+ function Generate_Loop (C : Node_Id) return Node_Id;
+ -- Generate a loop containing individual component assignments for
+ -- choices that are ranges, subtype indications, subtype names, and
+ -- iterated component associations.
+
+ -------------------
+ -- Generate_Loop --
+ -------------------
+
+ function Generate_Loop (C : Node_Id) return Node_Id is
+ Sl : constant Source_Ptr := Sloc (C);
+ Ix : Entity_Id;
+
+ begin
+ if Nkind (Parent (C)) = N_Iterated_Component_Association then
+ Ix :=
+ Make_Defining_Identifier (Loc,
+ Chars => (Chars (Defining_Identifier (Parent (C)))));
+ else
+ Ix := Make_Temporary (Sl, 'I');
+ end if;
+
+ return
+ Make_Loop_Statement (Loc,
+ Iteration_Scheme =>
+ Make_Iteration_Scheme (Sl,
+ Loop_Parameter_Specification =>
+ Make_Loop_Parameter_Specification (Sl,
+ Defining_Identifier => Ix,
+ Discrete_Subtype_Definition => New_Copy_Tree (C))),
+
+ Statements => New_List (
+ Make_Assignment_Statement (Sl,
+ Name =>
+ Make_Indexed_Component (Sl,
+ Prefix => New_Occurrence_Of (Temp, Sl),
+ Expressions => New_List (New_Occurrence_Of (Ix, Sl))),
+ Expression => New_Copy_Tree (Expression (Assoc)))),
+ End_Label => Empty);
+ end Generate_Loop;
+
+ -- Local variables
+
+ Choice : Node_Id;
+
+ -- Start of processing for Expand_Delta_Array_Aggregate
+
+ begin
+ Assoc := First (Component_Associations (N));
+ while Present (Assoc) loop
+ Choice := First (Choice_List (Assoc));
+ if Nkind (Assoc) = N_Iterated_Component_Association then
+ while Present (Choice) loop
+ Append_To (Deltas, Generate_Loop (Choice));
+ Next (Choice);
+ end loop;
+
+ else
+ while Present (Choice) loop
+
+ -- Choice can be given by a range, a subtype indication, a
+ -- subtype name, a scalar value, or an entity.
+
+ if Nkind (Choice) = N_Range
+ or else (Is_Entity_Name (Choice)
+ and then Is_Type (Entity (Choice)))
+ then
+ Append_To (Deltas, Generate_Loop (Choice));
+
+ elsif Nkind (Choice) = N_Subtype_Indication then
+ Append_To (Deltas,
+ Generate_Loop (Range_Expression (Constraint (Choice))));
+
+ else
+ Append_To (Deltas,
+ Make_Assignment_Statement (Sloc (Choice),
+ Name =>
+ Make_Indexed_Component (Sloc (Choice),
+ Prefix => New_Occurrence_Of (Temp, Loc),
+ Expressions => New_List (New_Copy_Tree (Choice))),
+ Expression => New_Copy_Tree (Expression (Assoc))));
+ end if;
+
+ Next (Choice);
+ end loop;
+ end if;
+
+ Next (Assoc);
+ end loop;
+
+ Insert_Actions (N, Deltas);
+ Rewrite (N, New_Occurrence_Of (Temp, Loc));
+ end Expand_Delta_Array_Aggregate;
+
+ -----------------------------------
+ -- Expand_Delta_Record_Aggregate --
+ -----------------------------------
+
+ procedure Expand_Delta_Record_Aggregate (N : Node_Id; Deltas : List_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Temp : constant Entity_Id := Defining_Identifier (First (Deltas));
+ Assoc : Node_Id;
+ Choice : Node_Id;
+
+ begin
+ Assoc := First (Component_Associations (N));
+
+ while Present (Assoc) loop
+ Choice := First (Choice_List (Assoc));
+ while Present (Choice) loop
+ Append_To (Deltas,
+ Make_Assignment_Statement (Sloc (Choice),
+ Name =>
+ Make_Selected_Component (Sloc (Choice),
+ Prefix => New_Occurrence_Of (Temp, Loc),
+ Selector_Name => Make_Identifier (Loc, Chars (Choice))),
+ Expression => New_Copy_Tree (Expression (Assoc))));
+ Next (Choice);
+ end loop;
+
+ Next (Assoc);
+ end loop;
+
+ Insert_Actions (N, Deltas);
+ Rewrite (N, New_Occurrence_Of (Temp, Loc));
+ end Expand_Delta_Record_Aggregate;
+
----------------------------------
-- Expand_N_Extension_Aggregate --
----------------------------------
@@ -5809,6 +6669,9 @@ package body Exp_Aggr is
-- and the aggregate can be constructed statically and handled by
-- the back-end.
+ procedure Build_Back_End_Aggregate;
+ -- Build a proper aggregate to be handled by the back-end
+
function Compile_Time_Known_Composite_Value (N : Node_Id) return Boolean;
-- Returns true if N is an expression of composite type which can be
-- fully evaluated at compile time without raising constraint error.
@@ -5837,6 +6700,10 @@ package body Exp_Aggr is
-- semantics of Ada complicate the analysis and lead to anomalies in
-- the gcc back-end if the aggregate is not expanded into assignments.
+ function Has_Per_Object_Constraint (L : List_Id) return Boolean;
+ -- Return True if any element of L has Has_Per_Object_Constraint set.
+ -- L should be the Choices component of an N_Component_Association.
+
function Has_Visible_Private_Ancestor (Id : E) return Boolean;
-- If any ancestor of the current type is private, the aggregate
-- cannot be built in place. We cannot rely on Has_Private_Ancestor,
@@ -5847,6 +6714,321 @@ package body Exp_Aggr is
-- For nested aggregates return the ultimate enclosing aggregate; for
-- non-nested aggregates return N.
+ ------------------------------
+ -- Build_Back_End_Aggregate --
+ ------------------------------
+
+ procedure Build_Back_End_Aggregate is
+ Comp : Entity_Id;
+ New_Comp : Node_Id;
+ Tag_Value : Node_Id;
+
+ begin
+ if Nkind (N) = N_Aggregate then
+
+ -- If the aggregate is static and can be handled by the back-end,
+ -- nothing left to do.
+
+ if Static_Components then
+ Set_Compile_Time_Known_Aggregate (N);
+ Set_Expansion_Delayed (N, False);
+ end if;
+ end if;
+
+ -- If no discriminants, nothing special to do
+
+ if not Has_Discriminants (Typ) then
+ null;
+
+ -- Case of discriminants present
+
+ elsif Is_Derived_Type (Typ) then
+
+ -- For untagged types, non-stored discriminants are replaced with
+ -- stored discriminants, which are the ones that gigi uses to
+ -- describe the type and its components.
+
+ Generate_Aggregate_For_Derived_Type : declare
+ procedure Prepend_Stored_Values (T : Entity_Id);
+ -- Scan the list of stored discriminants of the type, and add
+ -- their values to the aggregate being built.
+
+ ---------------------------
+ -- Prepend_Stored_Values --
+ ---------------------------
+
+ procedure Prepend_Stored_Values (T : Entity_Id) is
+ Discr : Entity_Id;
+ First_Comp : Node_Id := Empty;
+
+ begin
+ Discr := First_Stored_Discriminant (T);
+ while Present (Discr) loop
+ New_Comp :=
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ New_Occurrence_Of (Discr, Loc)),
+ Expression =>
+ New_Copy_Tree
+ (Get_Discriminant_Value
+ (Discr,
+ Typ,
+ Discriminant_Constraint (Typ))));
+
+ if No (First_Comp) then
+ Prepend_To (Component_Associations (N), New_Comp);
+ else
+ Insert_After (First_Comp, New_Comp);
+ end if;
+
+ First_Comp := New_Comp;
+ Next_Stored_Discriminant (Discr);
+ end loop;
+ end Prepend_Stored_Values;
+
+ -- Local variables
+
+ Constraints : constant List_Id := New_List;
+
+ Discr : Entity_Id;
+ Decl : Node_Id;
+ Num_Disc : Nat := 0;
+ Num_Gird : Nat := 0;
+
+ -- Start of processing for Generate_Aggregate_For_Derived_Type
+
+ begin
+ -- Remove the associations for the discriminant of derived type
+
+ declare
+ First_Comp : Node_Id;
+
+ begin
+ First_Comp := First (Component_Associations (N));
+ while Present (First_Comp) loop
+ Comp := First_Comp;
+ Next (First_Comp);
+
+ if Ekind (Entity (First (Choices (Comp)))) =
+ E_Discriminant
+ then
+ Remove (Comp);
+ Num_Disc := Num_Disc + 1;
+ end if;
+ end loop;
+ end;
+
+ -- Insert stored discriminant associations in the correct
+ -- order. If there are more stored discriminants than new
+ -- discriminants, there is at least one new discriminant that
+ -- constrains more than one of the stored discriminants. In
+ -- this case we need to construct a proper subtype of the
+ -- parent type, in order to supply values to all the
+ -- components. Otherwise there is one-one correspondence
+ -- between the constraints and the stored discriminants.
+
+ Discr := First_Stored_Discriminant (Base_Type (Typ));
+ while Present (Discr) loop
+ Num_Gird := Num_Gird + 1;
+ Next_Stored_Discriminant (Discr);
+ end loop;
+
+ -- Case of more stored discriminants than new discriminants
+
+ if Num_Gird > Num_Disc then
+
+ -- Create a proper subtype of the parent type, which is the
+ -- proper implementation type for the aggregate, and convert
+ -- it to the intended target type.
+
+ Discr := First_Stored_Discriminant (Base_Type (Typ));
+ while Present (Discr) loop
+ New_Comp :=
+ New_Copy_Tree
+ (Get_Discriminant_Value
+ (Discr,
+ Typ,
+ Discriminant_Constraint (Typ)));
+
+ Append (New_Comp, Constraints);
+ Next_Stored_Discriminant (Discr);
+ end loop;
+
+ Decl :=
+ Make_Subtype_Declaration (Loc,
+ Defining_Identifier => Make_Temporary (Loc, 'T'),
+ Subtype_Indication =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Etype (Base_Type (Typ)), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint
+ (Loc, Constraints)));
+
+ Insert_Action (N, Decl);
+ Prepend_Stored_Values (Base_Type (Typ));
+
+ Set_Etype (N, Defining_Identifier (Decl));
+ Set_Analyzed (N);
+
+ Rewrite (N, Unchecked_Convert_To (Typ, N));
+ Analyze (N);
+
+ -- Case where we do not have fewer new discriminants than
+ -- stored discriminants, so in this case we can simply use the
+ -- stored discriminants of the subtype.
+
+ else
+ Prepend_Stored_Values (Typ);
+ end if;
+ end Generate_Aggregate_For_Derived_Type;
+ end if;
+
+ if Is_Tagged_Type (Typ) then
+
+ -- In the tagged case, _parent and _tag component must be created
+
+ -- Reset Null_Present unconditionally. Tagged records always have
+ -- at least one field (the tag or the parent).
+
+ Set_Null_Record_Present (N, False);
+
+ -- When the current aggregate comes from the expansion of an
+ -- extension aggregate, the parent expr is replaced by an
+ -- aggregate formed by selected components of this expr.
+
+ if Present (Parent_Expr) and then Is_Empty_List (Comps) then
+ Comp := First_Component_Or_Discriminant (Typ);
+ while Present (Comp) loop
+
+ -- Skip all expander-generated components
+
+ if not Comes_From_Source (Original_Record_Component (Comp))
+ then
+ null;
+
+ else
+ New_Comp :=
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (Typ,
+ Duplicate_Subexpr (Parent_Expr, True)),
+ Selector_Name => New_Occurrence_Of (Comp, Loc));
+
+ Append_To (Comps,
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ New_Occurrence_Of (Comp, Loc)),
+ Expression => New_Comp));
+
+ Analyze_And_Resolve (New_Comp, Etype (Comp));
+ end if;
+
+ Next_Component_Or_Discriminant (Comp);
+ end loop;
+ end if;
+
+ -- Compute the value for the Tag now, if the type is a root it
+ -- will be included in the aggregate right away, otherwise it will
+ -- be propagated to the parent aggregate.
+
+ if Present (Orig_Tag) then
+ Tag_Value := Orig_Tag;
+
+ elsif not Tagged_Type_Expansion then
+ Tag_Value := Empty;
+
+ else
+ Tag_Value :=
+ New_Occurrence_Of
+ (Node (First_Elmt (Access_Disp_Table (Typ))), Loc);
+ end if;
+
+ -- For a derived type, an aggregate for the parent is formed with
+ -- all the inherited components.
+
+ if Is_Derived_Type (Typ) then
+ declare
+ First_Comp : Node_Id;
+ Parent_Comps : List_Id;
+ Parent_Aggr : Node_Id;
+ Parent_Name : Node_Id;
+
+ begin
+ -- Remove the inherited component association from the
+ -- aggregate and store them in the parent aggregate
+
+ First_Comp := First (Component_Associations (N));
+ Parent_Comps := New_List;
+ while Present (First_Comp)
+ and then
+ Scope (Original_Record_Component
+ (Entity (First (Choices (First_Comp))))) /=
+ Base_Typ
+ loop
+ Comp := First_Comp;
+ Next (First_Comp);
+ Remove (Comp);
+ Append (Comp, Parent_Comps);
+ end loop;
+
+ Parent_Aggr :=
+ Make_Aggregate (Loc,
+ Component_Associations => Parent_Comps);
+ Set_Etype (Parent_Aggr, Etype (Base_Type (Typ)));
+
+ -- Find the _parent component
+
+ Comp := First_Component (Typ);
+ while Chars (Comp) /= Name_uParent loop
+ Comp := Next_Component (Comp);
+ end loop;
+
+ Parent_Name := New_Occurrence_Of (Comp, Loc);
+
+ -- Insert the parent aggregate
+
+ Prepend_To (Component_Associations (N),
+ Make_Component_Association (Loc,
+ Choices => New_List (Parent_Name),
+ Expression => Parent_Aggr));
+
+ -- Expand recursively the parent propagating the right Tag
+
+ Expand_Record_Aggregate
+ (Parent_Aggr, Tag_Value, Parent_Expr);
+
+ -- The ancestor part may be a nested aggregate that has
+ -- delayed expansion: recheck now.
+
+ if Component_Not_OK_For_Backend then
+ Convert_To_Assignments (N, Typ);
+ end if;
+ end;
+
+ -- For a root type, the tag component is added (unless compiling
+ -- for the VMs, where tags are implicit).
+
+ elsif Tagged_Type_Expansion then
+ declare
+ Tag_Name : constant Node_Id :=
+ New_Occurrence_Of
+ (First_Tag_Component (Typ), Loc);
+ Typ_Tag : constant Entity_Id := RTE (RE_Tag);
+ Conv_Node : constant Node_Id :=
+ Unchecked_Convert_To (Typ_Tag, Tag_Value);
+
+ begin
+ Set_Etype (Conv_Node, Typ_Tag);
+ Prepend_To (Component_Associations (N),
+ Make_Component_Association (Loc,
+ Choices => New_List (Tag_Name),
+ Expression => Conv_Node));
+ end;
+ end if;
+ end if;
+ end Build_Back_End_Aggregate;
+
----------------------------------------
-- Compile_Time_Known_Composite_Value --
----------------------------------------
@@ -5941,6 +7123,20 @@ package body Exp_Aggr is
elsif Possible_Bit_Aligned_Component (Expr_Q) then
Static_Components := False;
return True;
+
+ elsif Modify_Tree_For_C
+ and then Nkind (C) = N_Component_Association
+ and then Has_Per_Object_Constraint (Choices (C))
+ then
+ Static_Components := False;
+ return True;
+
+ elsif Modify_Tree_For_C
+ and then Nkind (Expr_Q) = N_Identifier
+ and then Is_Array_Type (Etype (Expr_Q))
+ then
+ Static_Components := False;
+ return True;
end if;
if Is_Elementary_Type (Etype (Expr_Q)) then
@@ -5964,6 +7160,27 @@ package body Exp_Aggr is
return False;
end Component_Not_OK_For_Backend;
+ -------------------------------
+ -- Has_Per_Object_Constraint --
+ -------------------------------
+
+ function Has_Per_Object_Constraint (L : List_Id) return Boolean is
+ N : Node_Id := First (L);
+ begin
+ while Present (N) loop
+ if Is_Entity_Name (N)
+ and then Present (Entity (N))
+ and then Has_Per_Object_Constraint (Entity (N))
+ then
+ return True;
+ end if;
+
+ Next (N);
+ end loop;
+
+ return False;
+ end Has_Per_Object_Constraint;
+
-----------------------------------
-- Has_Visible_Private_Ancestor --
-----------------------------------
@@ -5996,8 +7213,8 @@ package body Exp_Aggr is
begin
Aggr := N;
while Present (Parent (Aggr))
- and then Nkind_In (Parent (Aggr), N_Component_Association,
- N_Aggregate)
+ and then Nkind_In (Parent (Aggr), N_Aggregate,
+ N_Component_Association)
loop
Aggr := Parent (Aggr);
end loop;
@@ -6008,9 +7225,6 @@ package body Exp_Aggr is
-- Local variables
Top_Level_Aggr : constant Node_Id := Top_Level_Aggregate (N);
- Tag_Value : Node_Id;
- Comp : Entity_Id;
- New_Comp : Node_Id;
-- Start of processing for Expand_Record_Aggregate
@@ -6040,8 +7254,8 @@ package body Exp_Aggr is
-- aggregates for C++ imported types must be expanded.
if Ada_Version >= Ada_2005 and then Is_Limited_View (Typ) then
- if not Nkind_In (Parent (N), N_Object_Declaration,
- N_Component_Association)
+ if not Nkind_In (Parent (N), N_Component_Association,
+ N_Object_Declaration)
then
Convert_To_Assignments (N, Typ);
@@ -6056,9 +7270,11 @@ package body Exp_Aggr is
then
Convert_To_Assignments (N, Typ);
+ -- In all other cases, build a proper aggregate to be handled by
+ -- the back-end
+
else
- Set_Compile_Time_Known_Aggregate (N);
- Set_Expansion_Delayed (N, False);
+ Build_Back_End_Aggregate;
end if;
-- Gigi doesn't properly handle temporaries of variable size so we
@@ -6135,300 +7351,8 @@ package body Exp_Aggr is
-- In all other cases, build a proper aggregate to be handled by gigi
else
- if Nkind (N) = N_Aggregate then
-
- -- If the aggregate is static and can be handled by the back-end,
- -- nothing left to do.
-
- if Static_Components then
- Set_Compile_Time_Known_Aggregate (N);
- Set_Expansion_Delayed (N, False);
- end if;
- end if;
-
- -- If no discriminants, nothing special to do
-
- if not Has_Discriminants (Typ) then
- null;
-
- -- Case of discriminants present
-
- elsif Is_Derived_Type (Typ) then
-
- -- For untagged types, non-stored discriminants are replaced
- -- with stored discriminants, which are the ones that gigi uses
- -- to describe the type and its components.
-
- Generate_Aggregate_For_Derived_Type : declare
- Constraints : constant List_Id := New_List;
- First_Comp : Node_Id;
- Discriminant : Entity_Id;
- Decl : Node_Id;
- Num_Disc : Int := 0;
- Num_Gird : Int := 0;
-
- procedure Prepend_Stored_Values (T : Entity_Id);
- -- Scan the list of stored discriminants of the type, and add
- -- their values to the aggregate being built.
-
- ---------------------------
- -- Prepend_Stored_Values --
- ---------------------------
-
- procedure Prepend_Stored_Values (T : Entity_Id) is
- begin
- Discriminant := First_Stored_Discriminant (T);
- while Present (Discriminant) loop
- New_Comp :=
- Make_Component_Association (Loc,
- Choices =>
- New_List (New_Occurrence_Of (Discriminant, Loc)),
-
- Expression =>
- New_Copy_Tree
- (Get_Discriminant_Value
- (Discriminant,
- Typ,
- Discriminant_Constraint (Typ))));
-
- if No (First_Comp) then
- Prepend_To (Component_Associations (N), New_Comp);
- else
- Insert_After (First_Comp, New_Comp);
- end if;
-
- First_Comp := New_Comp;
- Next_Stored_Discriminant (Discriminant);
- end loop;
- end Prepend_Stored_Values;
-
- -- Start of processing for Generate_Aggregate_For_Derived_Type
-
- begin
- -- Remove the associations for the discriminant of derived type
-
- First_Comp := First (Component_Associations (N));
- while Present (First_Comp) loop
- Comp := First_Comp;
- Next (First_Comp);
-
- if Ekind (Entity (First (Choices (Comp)))) = E_Discriminant
- then
- Remove (Comp);
- Num_Disc := Num_Disc + 1;
- end if;
- end loop;
-
- -- Insert stored discriminant associations in the correct
- -- order. If there are more stored discriminants than new
- -- discriminants, there is at least one new discriminant that
- -- constrains more than one of the stored discriminants. In
- -- this case we need to construct a proper subtype of the
- -- parent type, in order to supply values to all the
- -- components. Otherwise there is one-one correspondence
- -- between the constraints and the stored discriminants.
-
- First_Comp := Empty;
-
- Discriminant := First_Stored_Discriminant (Base_Type (Typ));
- while Present (Discriminant) loop
- Num_Gird := Num_Gird + 1;
- Next_Stored_Discriminant (Discriminant);
- end loop;
-
- -- Case of more stored discriminants than new discriminants
-
- if Num_Gird > Num_Disc then
-
- -- Create a proper subtype of the parent type, which is the
- -- proper implementation type for the aggregate, and convert
- -- it to the intended target type.
-
- Discriminant := First_Stored_Discriminant (Base_Type (Typ));
- while Present (Discriminant) loop
- New_Comp :=
- New_Copy_Tree
- (Get_Discriminant_Value
- (Discriminant,
- Typ,
- Discriminant_Constraint (Typ)));
- Append (New_Comp, Constraints);
- Next_Stored_Discriminant (Discriminant);
- end loop;
-
- Decl :=
- Make_Subtype_Declaration (Loc,
- Defining_Identifier => Make_Temporary (Loc, 'T'),
- Subtype_Indication =>
- Make_Subtype_Indication (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (Etype (Base_Type (Typ)), Loc),
- Constraint =>
- Make_Index_Or_Discriminant_Constraint
- (Loc, Constraints)));
-
- Insert_Action (N, Decl);
- Prepend_Stored_Values (Base_Type (Typ));
-
- Set_Etype (N, Defining_Identifier (Decl));
- Set_Analyzed (N);
-
- Rewrite (N, Unchecked_Convert_To (Typ, N));
- Analyze (N);
-
- -- Case where we do not have fewer new discriminants than
- -- stored discriminants, so in this case we can simply use the
- -- stored discriminants of the subtype.
-
- else
- Prepend_Stored_Values (Typ);
- end if;
- end Generate_Aggregate_For_Derived_Type;
- end if;
-
- if Is_Tagged_Type (Typ) then
-
- -- In the tagged case, _parent and _tag component must be created
-
- -- Reset Null_Present unconditionally. Tagged records always have
- -- at least one field (the tag or the parent).
-
- Set_Null_Record_Present (N, False);
-
- -- When the current aggregate comes from the expansion of an
- -- extension aggregate, the parent expr is replaced by an
- -- aggregate formed by selected components of this expr.
-
- if Present (Parent_Expr) and then Is_Empty_List (Comps) then
- Comp := First_Component_Or_Discriminant (Typ);
- while Present (Comp) loop
-
- -- Skip all expander-generated components
-
- if not Comes_From_Source (Original_Record_Component (Comp))
- then
- null;
-
- else
- New_Comp :=
- Make_Selected_Component (Loc,
- Prefix =>
- Unchecked_Convert_To (Typ,
- Duplicate_Subexpr (Parent_Expr, True)),
- Selector_Name => New_Occurrence_Of (Comp, Loc));
-
- Append_To (Comps,
- Make_Component_Association (Loc,
- Choices =>
- New_List (New_Occurrence_Of (Comp, Loc)),
- Expression => New_Comp));
-
- Analyze_And_Resolve (New_Comp, Etype (Comp));
- end if;
-
- Next_Component_Or_Discriminant (Comp);
- end loop;
- end if;
-
- -- Compute the value for the Tag now, if the type is a root it
- -- will be included in the aggregate right away, otherwise it will
- -- be propagated to the parent aggregate.
-
- if Present (Orig_Tag) then
- Tag_Value := Orig_Tag;
- elsif not Tagged_Type_Expansion then
- Tag_Value := Empty;
- else
- Tag_Value :=
- New_Occurrence_Of
- (Node (First_Elmt (Access_Disp_Table (Typ))), Loc);
- end if;
-
- -- For a derived type, an aggregate for the parent is formed with
- -- all the inherited components.
-
- if Is_Derived_Type (Typ) then
-
- declare
- First_Comp : Node_Id;
- Parent_Comps : List_Id;
- Parent_Aggr : Node_Id;
- Parent_Name : Node_Id;
-
- begin
- -- Remove the inherited component association from the
- -- aggregate and store them in the parent aggregate
-
- First_Comp := First (Component_Associations (N));
- Parent_Comps := New_List;
- while Present (First_Comp)
- and then
- Scope (Original_Record_Component
- (Entity (First (Choices (First_Comp))))) /=
- Base_Typ
- loop
- Comp := First_Comp;
- Next (First_Comp);
- Remove (Comp);
- Append (Comp, Parent_Comps);
- end loop;
-
- Parent_Aggr :=
- Make_Aggregate (Loc,
- Component_Associations => Parent_Comps);
- Set_Etype (Parent_Aggr, Etype (Base_Type (Typ)));
-
- -- Find the _parent component
-
- Comp := First_Component (Typ);
- while Chars (Comp) /= Name_uParent loop
- Comp := Next_Component (Comp);
- end loop;
-
- Parent_Name := New_Occurrence_Of (Comp, Loc);
-
- -- Insert the parent aggregate
-
- Prepend_To (Component_Associations (N),
- Make_Component_Association (Loc,
- Choices => New_List (Parent_Name),
- Expression => Parent_Aggr));
-
- -- Expand recursively the parent propagating the right Tag
-
- Expand_Record_Aggregate
- (Parent_Aggr, Tag_Value, Parent_Expr);
-
- -- The ancestor part may be a nested aggregate that has
- -- delayed expansion: recheck now.
-
- if Component_Not_OK_For_Backend then
- Convert_To_Assignments (N, Typ);
- end if;
- end;
-
- -- For a root type, the tag component is added (unless compiling
- -- for the VMs, where tags are implicit).
-
- elsif Tagged_Type_Expansion then
- declare
- Tag_Name : constant Node_Id :=
- New_Occurrence_Of (First_Tag_Component (Typ), Loc);
- Typ_Tag : constant Entity_Id := RTE (RE_Tag);
- Conv_Node : constant Node_Id :=
- Unchecked_Convert_To (Typ_Tag, Tag_Value);
-
- begin
- Set_Etype (Conv_Node, Typ_Tag);
- Prepend_To (Component_Associations (N),
- Make_Component_Association (Loc,
- Choices => New_List (Tag_Name),
- Expression => Conv_Node));
- end;
- end if;
- end if;
+ Build_Back_End_Aggregate;
end if;
-
end Expand_Record_Aggregate;
----------------------------
@@ -6640,7 +7564,7 @@ package body Exp_Aggr is
Assoc := First (Component_Associations (N));
while Present (Assoc) loop
- Choice := First (Choices (Assoc));
+ Choice := First (Choice_List (Assoc));
while Present (Choice) loop
if Nkind (Choice) /= N_Others_Choice then
Nb_Choices := Nb_Choices + 1;
@@ -7007,176 +7931,294 @@ package body Exp_Aggr is
end if;
end Must_Slide;
- ----------------------------------
- -- Two_Dim_Packed_Array_Handled --
- ----------------------------------
+ ---------------------------------
+ -- Process_Transient_Component --
+ ---------------------------------
- function Two_Dim_Packed_Array_Handled (N : Node_Id) return Boolean is
- Loc : constant Source_Ptr := Sloc (N);
- Typ : constant Entity_Id := Etype (N);
- Ctyp : constant Entity_Id := Component_Type (Typ);
- Comp_Size : constant Int := UI_To_Int (Component_Size (Typ));
- Packed_Array : constant Entity_Id :=
- Packed_Array_Impl_Type (Base_Type (Typ));
+ procedure Process_Transient_Component
+ (Loc : Source_Ptr;
+ Comp_Typ : Entity_Id;
+ Init_Expr : Node_Id;
+ Fin_Call : out Node_Id;
+ Hook_Clear : out Node_Id;
+ Aggr : Node_Id := Empty;
+ Stmts : List_Id := No_List)
+ is
+ procedure Add_Item (Item : Node_Id);
+ -- Insert arbitrary node Item into the tree depending on the values of
+ -- Aggr and Stmts.
- One_Comp : Node_Id;
- -- Expression in original aggregate
+ --------------
+ -- Add_Item --
+ --------------
- One_Dim : Node_Id;
- -- One-dimensional subaggregate
+ procedure Add_Item (Item : Node_Id) is
+ begin
+ if Present (Aggr) then
+ Insert_Action (Aggr, Item);
+ else
+ pragma Assert (Present (Stmts));
+ Append_To (Stmts, Item);
+ end if;
+ end Add_Item;
+
+ -- Local variables
+
+ Hook_Assign : Node_Id;
+ Hook_Decl : Node_Id;
+ Ptr_Decl : Node_Id;
+ Res_Decl : Node_Id;
+ Res_Id : Entity_Id;
+ Res_Typ : Entity_Id;
+
+ -- Start of processing for Process_Transient_Component
begin
+ -- Add the access type, which provides a reference to the function
+ -- result. Generate:
- -- For now, only deal with cases where an integral number of elements
- -- fit in a single byte. This includes the most common boolean case.
+ -- type Res_Typ is access all Comp_Typ;
- if not (Comp_Size = 1 or else
- Comp_Size = 2 or else
- Comp_Size = 4)
- then
- return False;
- end if;
+ Res_Typ := Make_Temporary (Loc, 'A');
+ Set_Ekind (Res_Typ, E_General_Access_Type);
+ Set_Directly_Designated_Type (Res_Typ, Comp_Typ);
- Convert_To_Positional
- (N, Max_Others_Replicate => 64, Handle_Bit_Packed => True);
+ Add_Item
+ (Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Res_Typ,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Subtype_Indication => New_Occurrence_Of (Comp_Typ, Loc))));
- -- Verify that all components are static
+ -- Add the temporary which captures the result of the function call.
+ -- Generate:
- if Nkind (N) = N_Aggregate
- and then Compile_Time_Known_Aggregate (N)
- then
- null;
+ -- Res : constant Res_Typ := Init_Expr'Reference;
- -- The aggregate may have been re-analyzed and converted already
+ -- Note that this temporary is effectively a transient object because
+ -- its lifetime is bounded by the current array or record component.
- elsif Nkind (N) /= N_Aggregate then
- return True;
+ Res_Id := Make_Temporary (Loc, 'R');
+ Set_Ekind (Res_Id, E_Constant);
+ Set_Etype (Res_Id, Res_Typ);
- -- If component associations remain, the aggregate is not static
+ -- Mark the transient object as successfully processed to avoid double
+ -- finalization.
- elsif Present (Component_Associations (N)) then
- return False;
+ Set_Is_Finalized_Transient (Res_Id);
- else
- One_Dim := First (Expressions (N));
- while Present (One_Dim) loop
- if Present (Component_Associations (One_Dim)) then
- return False;
- end if;
+ -- Signal the general finalization machinery that this transient object
+ -- should not be considered for finalization actions because its cleanup
+ -- will be performed by Process_Transient_Component_Completion.
- One_Comp := First (Expressions (One_Dim));
- while Present (One_Comp) loop
- if not Is_OK_Static_Expression (One_Comp) then
- return False;
- end if;
+ Set_Is_Ignored_Transient (Res_Id);
- Next (One_Comp);
- end loop;
+ Res_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Res_Id,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Res_Typ, Loc),
+ Expression =>
+ Make_Reference (Loc, New_Copy_Tree (Init_Expr)));
- Next (One_Dim);
- end loop;
- end if;
+ Add_Item (Res_Decl);
- -- Two-dimensional aggregate is now fully positional so pack one
- -- dimension to create a static one-dimensional array, and rewrite
- -- as an unchecked conversion to the original type.
+ -- Construct all pieces necessary to hook and finalize the transient
+ -- result.
- declare
- Byte_Size : constant Int := UI_To_Int (Component_Size (Packed_Array));
- -- The packed array type is a byte array
+ Build_Transient_Object_Statements
+ (Obj_Decl => Res_Decl,
+ Fin_Call => Fin_Call,
+ Hook_Assign => Hook_Assign,
+ Hook_Clear => Hook_Clear,
+ Hook_Decl => Hook_Decl,
+ Ptr_Decl => Ptr_Decl);
- Packed_Num : Int;
- -- Number of components accumulated in current byte
+ -- Add the access type which provides a reference to the transient
+ -- result. Generate:
- Comps : List_Id;
- -- Assembled list of packed values for equivalent aggregate
+ -- type Ptr_Typ is access all Comp_Typ;
- Comp_Val : Uint;
- -- integer value of component
+ Add_Item (Ptr_Decl);
- Incr : Int;
- -- Step size for packing
+ -- Add the temporary which acts as a hook to the transient result.
+ -- Generate:
- Init_Shift : Int;
- -- Endian-dependent start position for packing
+ -- Hook : Ptr_Typ := null;
- Shift : Int;
- -- Current insertion position
+ Add_Item (Hook_Decl);
- Val : Int;
- -- Component of packed array being assembled.
+ -- Attach the transient result to the hook. Generate:
- begin
- Comps := New_List;
- Val := 0;
- Packed_Num := 0;
+ -- Hook := Ptr_Typ (Res);
- -- Account for endianness. See corresponding comment in
- -- Packed_Array_Aggregate_Handled concerning the following.
+ Add_Item (Hook_Assign);
- if Bytes_Big_Endian
- xor Debug_Flag_8
- xor Reverse_Storage_Order (Base_Type (Typ))
- then
- Init_Shift := Byte_Size - Comp_Size;
- Incr := -Comp_Size;
- else
- Init_Shift := 0;
- Incr := +Comp_Size;
- end if;
+ -- The original initialization expression now references the value of
+ -- the temporary function result. Generate:
- -- Iterate over each subaggregate
+ -- Res.all
- Shift := Init_Shift;
- One_Dim := First (Expressions (N));
- while Present (One_Dim) loop
- One_Comp := First (Expressions (One_Dim));
- while Present (One_Comp) loop
- if Packed_Num = Byte_Size / Comp_Size then
+ Rewrite (Init_Expr,
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Res_Id, Loc)));
+ end Process_Transient_Component;
- -- Byte is complete, add to list of expressions
+ --------------------------------------------
+ -- Process_Transient_Component_Completion --
+ --------------------------------------------
- Append (Make_Integer_Literal (Sloc (One_Dim), Val), Comps);
- Val := 0;
- Shift := Init_Shift;
- Packed_Num := 0;
+ procedure Process_Transient_Component_Completion
+ (Loc : Source_Ptr;
+ Aggr : Node_Id;
+ Fin_Call : Node_Id;
+ Hook_Clear : Node_Id;
+ Stmts : List_Id)
+ is
+ Exceptions_OK : constant Boolean :=
+ not Restriction_Active (No_Exception_Propagation);
- else
- Comp_Val := Expr_Rep_Value (One_Comp);
+ begin
+ pragma Assert (Present (Hook_Clear));
- -- Adjust for bias, and strip proper number of bits
+ -- Generate the following code if exception propagation is allowed:
- if Has_Biased_Representation (Ctyp) then
- Comp_Val := Comp_Val - Expr_Value (Type_Low_Bound (Ctyp));
- end if;
+ -- declare
+ -- Abort : constant Boolean := Triggered_By_Abort;
+ -- <or>
+ -- Abort : constant Boolean := False; -- no abort
- Comp_Val := Comp_Val mod Uint_2 ** Comp_Size;
- Val := UI_To_Int (Val + Comp_Val * Uint_2 ** Shift);
- Shift := Shift + Incr;
- One_Comp := Next (One_Comp);
- Packed_Num := Packed_Num + 1;
- end if;
- end loop;
+ -- E : Exception_Occurrence;
+ -- Raised : Boolean := False;
- One_Dim := Next (One_Dim);
- end loop;
+ -- begin
+ -- [Abort_Defer;]
- if Packed_Num > 0 then
+ -- begin
+ -- Hook := null;
+ -- [Deep_]Finalize (Res.all);
- -- Add final incomplete byte if present
+ -- exception
+ -- when others =>
+ -- if not Raised then
+ -- Raised := True;
+ -- Save_Occurrence (E,
+ -- Get_Curent_Excep.all.all);
+ -- end if;
+ -- end;
- Append (Make_Integer_Literal (Sloc (One_Dim), Val), Comps);
- end if;
+ -- [Abort_Undefer;]
- Rewrite (N,
- Unchecked_Convert_To (Typ,
- Make_Qualified_Expression (Loc,
- Subtype_Mark => New_Occurrence_Of (Packed_Array, Loc),
- Expression => Make_Aggregate (Loc, Expressions => Comps))));
- Analyze_And_Resolve (N);
- return True;
- end;
- end Two_Dim_Packed_Array_Handled;
+ -- if Raised and then not Abort then
+ -- Raise_From_Controlled_Operation (E);
+ -- end if;
+ -- end;
+
+ if Exceptions_OK then
+ Abort_And_Exception : declare
+ Blk_Decls : constant List_Id := New_List;
+ Blk_Stmts : constant List_Id := New_List;
+ Fin_Stmts : constant List_Id := New_List;
+
+ Fin_Data : Finalization_Exception_Data;
+
+ begin
+ -- Create the declarations of the two flags and the exception
+ -- occurrence.
+
+ Build_Object_Declarations (Fin_Data, Blk_Decls, Loc);
+
+ -- Generate:
+ -- Abort_Defer;
+
+ if Abort_Allowed then
+ Append_To (Blk_Stmts,
+ Build_Runtime_Call (Loc, RE_Abort_Defer));
+ end if;
+
+ -- Wrap the hook clear and the finalization call in order to trap
+ -- a potential exception.
+
+ Append_To (Fin_Stmts, Hook_Clear);
+
+ if Present (Fin_Call) then
+ Append_To (Fin_Stmts, Fin_Call);
+ end if;
+
+ Append_To (Blk_Stmts,
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Fin_Stmts,
+ Exception_Handlers => New_List (
+ Build_Exception_Handler (Fin_Data)))));
+
+ -- Generate:
+ -- Abort_Undefer;
+
+ if Abort_Allowed then
+ Append_To (Blk_Stmts,
+ Build_Runtime_Call (Loc, RE_Abort_Undefer));
+ end if;
+
+ -- Reraise the potential exception with a proper "upgrade" to
+ -- Program_Error if needed.
+
+ Append_To (Blk_Stmts, Build_Raise_Statement (Fin_Data));
+
+ -- Wrap everything in a block
+
+ Append_To (Stmts,
+ Make_Block_Statement (Loc,
+ Declarations => Blk_Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Blk_Stmts)));
+ end Abort_And_Exception;
+
+ -- Generate the following code if exception propagation is not allowed
+ -- and aborts are allowed:
+
+ -- begin
+ -- Abort_Defer;
+ -- Hook := null;
+ -- [Deep_]Finalize (Res.all);
+ -- at end
+ -- Abort_Undefer_Direct;
+ -- end;
+
+ elsif Abort_Allowed then
+ Abort_Only : declare
+ Blk_Stmts : constant List_Id := New_List;
+
+ begin
+ Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
+ Append_To (Blk_Stmts, Hook_Clear);
+
+ if Present (Fin_Call) then
+ Append_To (Blk_Stmts, Fin_Call);
+ end if;
+
+ Append_To (Stmts,
+ Build_Abort_Undefer_Block (Loc,
+ Stmts => Blk_Stmts,
+ Context => Aggr));
+ end Abort_Only;
+
+ -- Otherwise generate:
+
+ -- Hook := null;
+ -- [Deep_]Finalize (Res.all);
+
+ else
+ Append_To (Stmts, Hook_Clear);
+
+ if Present (Fin_Call) then
+ Append_To (Stmts, Fin_Call);
+ end if;
+ end if;
+ end Process_Transient_Component_Completion;
---------------------
-- Sort_Case_Table --
@@ -7265,7 +8307,7 @@ package body Exp_Aggr is
elsif Present (Next (Expr)) then
return False;
- elsif Present (Next (First (Choices (Expr)))) then
+ elsif Present (Next (First (Choice_List (Expr)))) then
return False;
else
@@ -7324,4 +8366,175 @@ package body Exp_Aggr is
end if;
end Static_Array_Aggregate;
+ ----------------------------------
+ -- Two_Dim_Packed_Array_Handled --
+ ----------------------------------
+
+ function Two_Dim_Packed_Array_Handled (N : Node_Id) return Boolean is
+ Loc : constant Source_Ptr := Sloc (N);
+ Typ : constant Entity_Id := Etype (N);
+ Ctyp : constant Entity_Id := Component_Type (Typ);
+ Comp_Size : constant Int := UI_To_Int (Component_Size (Typ));
+ Packed_Array : constant Entity_Id :=
+ Packed_Array_Impl_Type (Base_Type (Typ));
+
+ One_Comp : Node_Id;
+ -- Expression in original aggregate
+
+ One_Dim : Node_Id;
+ -- One-dimensional subaggregate
+
+ begin
+
+ -- For now, only deal with cases where an integral number of elements
+ -- fit in a single byte. This includes the most common boolean case.
+
+ if not (Comp_Size = 1 or else
+ Comp_Size = 2 or else
+ Comp_Size = 4)
+ then
+ return False;
+ end if;
+
+ Convert_To_Positional
+ (N, Max_Others_Replicate => 64, Handle_Bit_Packed => True);
+
+ -- Verify that all components are static
+
+ if Nkind (N) = N_Aggregate
+ and then Compile_Time_Known_Aggregate (N)
+ then
+ null;
+
+ -- The aggregate may have been reanalyzed and converted already
+
+ elsif Nkind (N) /= N_Aggregate then
+ return True;
+
+ -- If component associations remain, the aggregate is not static
+
+ elsif Present (Component_Associations (N)) then
+ return False;
+
+ else
+ One_Dim := First (Expressions (N));
+ while Present (One_Dim) loop
+ if Present (Component_Associations (One_Dim)) then
+ return False;
+ end if;
+
+ One_Comp := First (Expressions (One_Dim));
+ while Present (One_Comp) loop
+ if not Is_OK_Static_Expression (One_Comp) then
+ return False;
+ end if;
+
+ Next (One_Comp);
+ end loop;
+
+ Next (One_Dim);
+ end loop;
+ end if;
+
+ -- Two-dimensional aggregate is now fully positional so pack one
+ -- dimension to create a static one-dimensional array, and rewrite
+ -- as an unchecked conversion to the original type.
+
+ declare
+ Byte_Size : constant Int := UI_To_Int (Component_Size (Packed_Array));
+ -- The packed array type is a byte array
+
+ Packed_Num : Nat;
+ -- Number of components accumulated in current byte
+
+ Comps : List_Id;
+ -- Assembled list of packed values for equivalent aggregate
+
+ Comp_Val : Uint;
+ -- Integer value of component
+
+ Incr : Int;
+ -- Step size for packing
+
+ Init_Shift : Int;
+ -- Endian-dependent start position for packing
+
+ Shift : Int;
+ -- Current insertion position
+
+ Val : Int;
+ -- Component of packed array being assembled
+
+ begin
+ Comps := New_List;
+ Val := 0;
+ Packed_Num := 0;
+
+ -- Account for endianness. See corresponding comment in
+ -- Packed_Array_Aggregate_Handled concerning the following.
+
+ if Bytes_Big_Endian
+ xor Debug_Flag_8
+ xor Reverse_Storage_Order (Base_Type (Typ))
+ then
+ Init_Shift := Byte_Size - Comp_Size;
+ Incr := -Comp_Size;
+ else
+ Init_Shift := 0;
+ Incr := +Comp_Size;
+ end if;
+
+ -- Iterate over each subaggregate
+
+ Shift := Init_Shift;
+ One_Dim := First (Expressions (N));
+ while Present (One_Dim) loop
+ One_Comp := First (Expressions (One_Dim));
+ while Present (One_Comp) loop
+ if Packed_Num = Byte_Size / Comp_Size then
+
+ -- Byte is complete, add to list of expressions
+
+ Append (Make_Integer_Literal (Sloc (One_Dim), Val), Comps);
+ Val := 0;
+ Shift := Init_Shift;
+ Packed_Num := 0;
+
+ else
+ Comp_Val := Expr_Rep_Value (One_Comp);
+
+ -- Adjust for bias, and strip proper number of bits
+
+ if Has_Biased_Representation (Ctyp) then
+ Comp_Val := Comp_Val - Expr_Value (Type_Low_Bound (Ctyp));
+ end if;
+
+ Comp_Val := Comp_Val mod Uint_2 ** Comp_Size;
+ Val := UI_To_Int (Val + Comp_Val * Uint_2 ** Shift);
+ Shift := Shift + Incr;
+ One_Comp := Next (One_Comp);
+ Packed_Num := Packed_Num + 1;
+ end if;
+ end loop;
+
+ One_Dim := Next (One_Dim);
+ end loop;
+
+ if Packed_Num > 0 then
+
+ -- Add final incomplete byte if present
+
+ Append (Make_Integer_Literal (Sloc (One_Dim), Val), Comps);
+ end if;
+
+ Rewrite (N,
+ Unchecked_Convert_To (Typ,
+ Make_Qualified_Expression (Loc,
+ Subtype_Mark => New_Occurrence_Of (Packed_Array, Loc),
+ Expression => Make_Aggregate (Loc, Expressions => Comps))));
+ Analyze_And_Resolve (N);
+ return True;
+ end;
+ end Two_Dim_Packed_Array_Handled;
+
end Exp_Aggr;
diff --git a/gcc/ada/exp_aggr.ads b/gcc/ada/exp_aggr.ads
index 5d14f1d5fe..b9441fde4c 100644
--- a/gcc/ada/exp_aggr.ads
+++ b/gcc/ada/exp_aggr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -28,6 +28,7 @@ with Types; use Types;
package Exp_Aggr is
procedure Expand_N_Aggregate (N : Node_Id);
+ procedure Expand_N_Delta_Aggregate (N : Node_Id);
procedure Expand_N_Extension_Aggregate (N : Node_Id);
function Is_Delayed_Aggregate (N : Node_Id) return Boolean;
@@ -62,4 +63,5 @@ package Exp_Aggr is
-- are compile-time known constants, rewrite N as a purely positional
-- aggregate, to be use to initialize variables and components of the type
-- without generating elaboration code.
+
end Exp_Aggr;
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index abf7f1bfbc..2655b80e4b 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -583,13 +583,15 @@ package body Exp_Attr is
end if;
end Make_VS_If;
- -- Local Declarations
+ -- Local variables
Def : constant Node_Id := Parent (R_Type);
Comps : constant Node_Id := Component_List (Type_Definition (Def));
Stmts : constant List_Id := New_List;
Pspecs : constant List_Id := New_List;
+ -- Start of processing for Build_Record_VS_Func
+
begin
Append_To (Pspecs,
Make_Parameter_Specification (Loc,
@@ -1017,13 +1019,11 @@ package body Exp_Attr is
-- Local variables
- Exprs : constant List_Id := Expressions (N);
Pref : constant Node_Id := Prefix (N);
- Typ : constant Entity_Id := Etype (Pref);
+ Base_Typ : constant Entity_Id := Base_Type (Etype (Pref));
+ Exprs : constant List_Id := Expressions (N);
+ Aux_Decl : Node_Id;
Blk : Node_Id;
- CW_Decl : Node_Id;
- CW_Temp : Entity_Id;
- CW_Typ : Entity_Id;
Decls : List_Id;
Installed : Boolean;
Loc : Source_Ptr;
@@ -1046,10 +1046,10 @@ package body Exp_Attr is
Loop_Id := Entity (First (Exprs));
Loop_Stmt := Label_Construct (Parent (Loop_Id));
- -- Climb the parent chain to find the nearest enclosing loop. Skip all
- -- internally generated loops for quantified expressions and for
- -- element iterators over multidimensional arrays: pragma applies to
- -- source loop.
+ -- Climb the parent chain to find the nearest enclosing loop. Skip
+ -- all internally generated loops for quantified expressions and for
+ -- element iterators over multidimensional arrays because the pragma
+ -- applies to source loop.
else
Loop_Stmt := N;
@@ -1348,49 +1348,68 @@ package body Exp_Attr is
-- Preserve the tag of the prefix by offering a specific view of the
-- class-wide version of the prefix.
- if Is_Tagged_Type (Typ) then
+ if Is_Tagged_Type (Base_Typ) then
+ Tagged_Case : declare
+ CW_Temp : Entity_Id;
+ CW_Typ : Entity_Id;
- -- Generate:
- -- CW_Temp : constant Typ'Class := Typ'Class (Pref);
+ begin
+ -- Generate:
+ -- CW_Temp : constant Base_Typ'Class := Base_Typ'Class (Pref);
- CW_Temp := Make_Temporary (Loc, 'T');
- CW_Typ := Class_Wide_Type (Typ);
+ CW_Temp := Make_Temporary (Loc, 'T');
+ CW_Typ := Class_Wide_Type (Base_Typ);
- CW_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => CW_Temp,
- Constant_Present => True,
- Object_Definition => New_Occurrence_Of (CW_Typ, Loc),
- Expression =>
- Convert_To (CW_Typ, Relocate_Node (Pref)));
- Append_To (Decls, CW_Decl);
+ Aux_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => CW_Temp,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (CW_Typ, Loc),
+ Expression =>
+ Convert_To (CW_Typ, Relocate_Node (Pref)));
+ Append_To (Decls, Aux_Decl);
- -- Generate:
- -- Temp : Typ renames Typ (CW_Temp);
+ -- Generate:
+ -- Temp : Base_Typ renames Base_Typ (CW_Temp);
- Temp_Decl :=
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Temp_Id,
- Subtype_Mark => New_Occurrence_Of (Typ, Loc),
- Name =>
- Convert_To (Typ, New_Occurrence_Of (CW_Temp, Loc)));
- Append_To (Decls, Temp_Decl);
+ Temp_Decl :=
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Temp_Id,
+ Subtype_Mark => New_Occurrence_Of (Base_Typ, Loc),
+ Name =>
+ Convert_To (Base_Typ, New_Occurrence_Of (CW_Temp, Loc)));
+ Append_To (Decls, Temp_Decl);
+ end Tagged_Case;
- -- Non-tagged case
+ -- Untagged case
else
- CW_Decl := Empty;
+ Untagged_Case : declare
+ Temp_Expr : Node_Id;
- -- Generate:
- -- Temp : constant Typ := Pref;
+ begin
+ Aux_Decl := Empty;
- Temp_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp_Id,
- Constant_Present => True,
- Object_Definition => New_Occurrence_Of (Typ, Loc),
- Expression => Relocate_Node (Pref));
- Append_To (Decls, Temp_Decl);
+ -- Generate a nominal type for the constant when the prefix is of
+ -- a constrained type. This is achieved by setting the Etype of
+ -- the relocated prefix to its base type. Since the prefix is now
+ -- the initialization expression of the constant, its freezing
+ -- will produce a proper nominal type.
+
+ Temp_Expr := Relocate_Node (Pref);
+ Set_Etype (Temp_Expr, Base_Typ);
+
+ -- Generate:
+ -- Temp : constant Base_Typ := Pref;
+
+ Temp_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp_Id,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Base_Typ, Loc),
+ Expression => Temp_Expr);
+ Append_To (Decls, Temp_Decl);
+ end Untagged_Case;
end if;
-- Step 4: Analyze all bits
@@ -1416,8 +1435,8 @@ package body Exp_Attr is
-- the declaration of the constant.
else
- if Present (CW_Decl) then
- Analyze (CW_Decl);
+ if Present (Aux_Decl) then
+ Analyze (Aux_Decl);
end if;
Analyze (Temp_Decl);
@@ -1566,9 +1585,10 @@ package body Exp_Attr is
procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id) is
Item : constant Node_Id := Next (First (Exprs));
+ Item_Typ : constant Entity_Id := Etype (Item);
Formal : constant Entity_Id := Next_Formal (First_Formal (Pname));
Formal_Typ : constant Entity_Id := Etype (Formal);
- Is_Written : constant Boolean := (Ekind (Formal) /= E_In_Parameter);
+ Is_Written : constant Boolean := Ekind (Formal) /= E_In_Parameter;
begin
-- The expansion depends on Item, the second actual, which is
@@ -1581,7 +1601,7 @@ package body Exp_Attr is
if Nkind (Item) = N_Indexed_Component
and then Is_Packed (Base_Type (Etype (Prefix (Item))))
- and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ)
+ and then Base_Type (Item_Typ) /= Base_Type (Formal_Typ)
and then Is_Written
then
declare
@@ -1593,23 +1613,22 @@ package body Exp_Attr is
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
- Object_Definition =>
- New_Occurrence_Of (Formal_Typ, Loc));
+ Object_Definition => New_Occurrence_Of (Formal_Typ, Loc));
Set_Etype (Temp, Formal_Typ);
Assn :=
Make_Assignment_Statement (Loc,
- Name => New_Copy_Tree (Item),
+ Name => New_Copy_Tree (Item),
Expression =>
Unchecked_Convert_To
- (Etype (Item), New_Occurrence_Of (Temp, Loc)));
+ (Item_Typ, New_Occurrence_Of (Temp, Loc)));
Rewrite (Item, New_Occurrence_Of (Temp, Loc));
Insert_Actions (N,
New_List (
Decl,
Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (Pname, Loc),
+ Name => New_Occurrence_Of (Pname, Loc),
Parameter_Associations => Exprs),
Assn));
@@ -1624,17 +1643,25 @@ package body Exp_Attr is
-- operation is not inherited), we are all set, and can use the
-- argument unchanged.
- -- For all other cases we do an unchecked conversion of the second
- -- parameter to the type of the formal of the procedure we are
- -- calling. This deals with the private type cases, and with going
- -- to the root type as required in elementary type case.
-
if not Is_Class_Wide_Type (Entity (Pref))
and then not Is_Class_Wide_Type (Etype (Item))
- and then Base_Type (Etype (Item)) /= Base_Type (Formal_Typ)
+ and then Base_Type (Item_Typ) /= Base_Type (Formal_Typ)
then
- Rewrite (Item,
- Unchecked_Convert_To (Formal_Typ, Relocate_Node (Item)));
+ -- Perform a view conversion when either the argument or the
+ -- formal parameter are of a private type.
+
+ if Is_Private_Type (Formal_Typ)
+ or else Is_Private_Type (Item_Typ)
+ then
+ Rewrite (Item,
+ Unchecked_Convert_To (Formal_Typ, Relocate_Node (Item)));
+
+ -- Otherwise perform a regular type conversion to ensure that all
+ -- relevant checks are installed.
+
+ else
+ Rewrite (Item, Convert_To (Formal_Typ, Relocate_Node (Item)));
+ end if;
-- For untagged derived types set Assignment_OK, to prevent
-- copies from being created when the unchecked conversion
@@ -1663,7 +1690,7 @@ package body Exp_Attr is
Rewrite (N,
Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (Pname, Loc),
+ Name => New_Occurrence_Of (Pname, Loc),
Parameter_Associations => Exprs));
Analyze (N);
@@ -1742,12 +1769,13 @@ package body Exp_Attr is
-- Attributes related to Ada 2012 iterators
- when Attribute_Constant_Indexing |
- Attribute_Default_Iterator |
- Attribute_Implicit_Dereference |
- Attribute_Iterable |
- Attribute_Iterator_Element |
- Attribute_Variable_Indexing =>
+ when Attribute_Constant_Indexing
+ | Attribute_Default_Iterator
+ | Attribute_Implicit_Dereference
+ | Attribute_Iterable
+ | Attribute_Iterator_Element
+ | Attribute_Variable_Indexing
+ =>
null;
-- Internal attributes used to deal with Ada 2012 delayed aspects. These
@@ -1760,10 +1788,10 @@ package body Exp_Attr is
-- Access --
------------
- when Attribute_Access |
- Attribute_Unchecked_Access |
- Attribute_Unrestricted_Access =>
-
+ when Attribute_Access
+ | Attribute_Unchecked_Access
+ | Attribute_Unrestricted_Access
+ =>
Access_Cases : declare
Ref_Object : constant Node_Id := Get_Referenced_Object (Pref);
Btyp_DDT : Entity_Id;
@@ -2330,99 +2358,103 @@ package body Exp_Attr is
-- A special exception occurs for Standard, where the string returned
-- is a copy of the library string in gnatvsn.ads.
- when Attribute_Body_Version | Attribute_Version => Version : declare
- E : constant Entity_Id := Make_Temporary (Loc, 'V');
- Pent : Entity_Id;
- S : String_Id;
+ when Attribute_Body_Version
+ | Attribute_Version
+ =>
+ Version : declare
+ E : constant Entity_Id := Make_Temporary (Loc, 'V');
+ Pent : Entity_Id;
+ S : String_Id;
- begin
- -- If not library unit, get to containing library unit
-
- Pent := Entity (Pref);
- while Pent /= Standard_Standard
- and then Scope (Pent) /= Standard_Standard
- and then not Is_Child_Unit (Pent)
- loop
- Pent := Scope (Pent);
- end loop;
+ begin
+ -- If not library unit, get to containing library unit
+
+ Pent := Entity (Pref);
+ while Pent /= Standard_Standard
+ and then Scope (Pent) /= Standard_Standard
+ and then not Is_Child_Unit (Pent)
+ loop
+ Pent := Scope (Pent);
+ end loop;
- -- Special case Standard and Standard.ASCII
+ -- Special case Standard and Standard.ASCII
- if Pent = Standard_Standard or else Pent = Standard_ASCII then
- Rewrite (N,
- Make_String_Literal (Loc,
- Strval => Verbose_Library_Version));
+ if Pent = Standard_Standard or else Pent = Standard_ASCII then
+ Rewrite (N,
+ Make_String_Literal (Loc,
+ Strval => Verbose_Library_Version));
- -- All other cases
+ -- All other cases
- else
- -- Build required string constant
+ else
+ -- Build required string constant
- Get_Name_String (Get_Unit_Name (Pent));
+ Get_Name_String (Get_Unit_Name (Pent));
- Start_String;
- for J in 1 .. Name_Len - 2 loop
- if Name_Buffer (J) = '.' then
- Store_String_Chars ("__");
- else
- Store_String_Char (Get_Char_Code (Name_Buffer (J)));
- end if;
- end loop;
+ Start_String;
+ for J in 1 .. Name_Len - 2 loop
+ if Name_Buffer (J) = '.' then
+ Store_String_Chars ("__");
+ else
+ Store_String_Char (Get_Char_Code (Name_Buffer (J)));
+ end if;
+ end loop;
- -- Case of subprogram acting as its own spec, always use body
+ -- Case of subprogram acting as its own spec, always use body
- if Nkind (Declaration_Node (Pent)) in N_Subprogram_Specification
- and then Nkind (Parent (Declaration_Node (Pent))) =
- N_Subprogram_Body
- and then Acts_As_Spec (Parent (Declaration_Node (Pent)))
- then
- Store_String_Chars ("B");
+ if Nkind (Declaration_Node (Pent)) in N_Subprogram_Specification
+ and then Nkind (Parent (Declaration_Node (Pent))) =
+ N_Subprogram_Body
+ and then Acts_As_Spec (Parent (Declaration_Node (Pent)))
+ then
+ Store_String_Chars ("B");
- -- Case of no body present, always use spec
+ -- Case of no body present, always use spec
- elsif not Unit_Requires_Body (Pent) then
- Store_String_Chars ("S");
+ elsif not Unit_Requires_Body (Pent) then
+ Store_String_Chars ("S");
- -- Otherwise use B for Body_Version, S for spec
+ -- Otherwise use B for Body_Version, S for spec
- elsif Id = Attribute_Body_Version then
- Store_String_Chars ("B");
- else
- Store_String_Chars ("S");
- end if;
+ elsif Id = Attribute_Body_Version then
+ Store_String_Chars ("B");
+ else
+ Store_String_Chars ("S");
+ end if;
- S := End_String;
- Lib.Version_Referenced (S);
+ S := End_String;
+ Lib.Version_Referenced (S);
- -- Insert the object declaration
+ -- Insert the object declaration
- Insert_Actions (N, New_List (
- Make_Object_Declaration (Loc,
- Defining_Identifier => E,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Unsigned), Loc))));
+ Insert_Actions (N, New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => E,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Unsigned), Loc))));
- -- Set entity as imported with correct external name
+ -- Set entity as imported with correct external name
- Set_Is_Imported (E);
- Set_Interface_Name (E, Make_String_Literal (Loc, S));
+ Set_Is_Imported (E);
+ Set_Interface_Name (E, Make_String_Literal (Loc, S));
- -- Set entity as internal to ensure proper Sprint output of its
- -- implicit importation.
+ -- Set entity as internal to ensure proper Sprint output of its
+ -- implicit importation.
- Set_Is_Internal (E);
+ Set_Is_Internal (E);
- -- And now rewrite original reference
+ -- And now rewrite original reference
- Rewrite (N,
- Make_Function_Call (Loc,
- Name => New_Occurrence_Of (RTE (RE_Get_Version_String), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (E, Loc))));
- end if;
+ Rewrite (N,
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Get_Version_String), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (E, Loc))));
+ end if;
- Analyze_And_Resolve (N, RTE (RE_Version_String));
- end Version;
+ Analyze_And_Resolve (N, RTE (RE_Version_String));
+ end Version;
-------------
-- Ceiling --
@@ -2440,8 +2472,7 @@ package body Exp_Attr is
-- Transforms 'Callable attribute into a call to the Callable function
- when Attribute_Callable => Callable :
- begin
+ when Attribute_Callable =>
-- We have an object of a task interface class-wide type as a prefix
-- to Callable. Generate:
-- callable (Task_Id (Pref._disp_get_task_id));
@@ -2453,15 +2484,15 @@ package body Exp_Attr is
then
Rewrite (N,
Make_Function_Call (Loc,
- Name =>
+ Name =>
New_Occurrence_Of (RTE (RE_Callable), Loc),
Parameter_Associations => New_List (
Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark =>
New_Occurrence_Of (RTE (RO_ST_Task_Id), Loc),
- Expression =>
+ Expression =>
Make_Selected_Component (Loc,
- Prefix =>
+ Prefix =>
New_Copy_Tree (Pref),
Selector_Name =>
Make_Identifier (Loc, Name_uDisp_Get_Task_Id))))));
@@ -2472,7 +2503,6 @@ package body Exp_Attr is
end if;
Analyze_And_Resolve (N, Standard_Boolean);
- end Callable;
------------
-- Caller --
@@ -2670,45 +2700,56 @@ package body Exp_Attr is
end if;
end if;
- -- If the prefix is not a variable or is aliased, then
- -- definitely true; if it's a formal parameter without an
- -- associated extra formal, then treat it as constrained.
+ else
+ -- For access type, apply access check as needed
+
+ if Is_Access_Type (Ptyp) then
+ Apply_Access_Check (N);
+ end if;
+
+ -- If the prefix is not a variable or is aliased, then
+ -- definitely true; if it's a formal parameter without an
+ -- associated extra formal, then treat it as constrained.
- -- Ada 2005 (AI-363): An aliased prefix must be known to be
- -- constrained in order to set the attribute to True.
+ -- Ada 2005 (AI-363): An aliased prefix must be known to be
+ -- constrained in order to set the attribute to True.
- elsif not Is_Variable (Pref)
- or else Present (Formal_Ent)
- or else (Ada_Version < Ada_2005
- and then Is_Aliased_View (Pref))
- or else (Ada_Version >= Ada_2005
- and then Is_Constrained_Aliased_View (Pref))
- then
- Res := True;
+ if not Is_Variable (Pref)
+ or else Present (Formal_Ent)
+ or else (Ada_Version < Ada_2005
+ and then Is_Aliased_View (Pref))
+ or else (Ada_Version >= Ada_2005
+ and then Is_Constrained_Aliased_View (Pref))
+ then
+ Res := True;
- -- Variable case, look at type to see if it is constrained.
- -- Note that the one case where this is not accurate (the
- -- procedure formal case), has been handled above.
+ -- Variable case, look at type to see if it is constrained.
+ -- Note that the one case where this is not accurate (the
+ -- procedure formal case), has been handled above.
- -- We use the Underlying_Type here (and below) in case the
- -- type is private without discriminants, but the full type
- -- has discriminants. This case is illegal, but we generate it
- -- internally for passing to the Extra_Constrained parameter.
+ -- We use the Underlying_Type here (and below) in case the
+ -- type is private without discriminants, but the full type
+ -- has discriminants. This case is illegal, but we generate
+ -- it internally for passing to the Extra_Constrained
+ -- parameter.
- else
- -- In Ada 2012, test for case of a limited tagged type, in
- -- which case the attribute is always required to return
- -- True. The underlying type is tested, to make sure we also
- -- return True for cases where there is an unconstrained
- -- object with an untagged limited partial view which has
- -- defaulted discriminants (such objects always produce a
- -- False in earlier versions of Ada). (Ada 2012: AI05-0214)
-
- Res := Is_Constrained (Underlying_Type (Etype (Ent)))
- or else
- (Ada_Version >= Ada_2012
- and then Is_Tagged_Type (Underlying_Type (Ptyp))
- and then Is_Limited_Type (Ptyp));
+ else
+ -- In Ada 2012, test for case of a limited tagged type,
+ -- in which case the attribute is always required to
+ -- return True. The underlying type is tested, to make
+ -- sure we also return True for cases where there is an
+ -- unconstrained object with an untagged limited partial
+ -- view which has defaulted discriminants (such objects
+ -- always produce a False in earlier versions of
+ -- Ada). (Ada 2012: AI05-0214)
+
+ Res :=
+ Is_Constrained (Underlying_Type (Etype (Ent)))
+ or else
+ (Ada_Version >= Ada_2012
+ and then Is_Tagged_Type (Underlying_Type (Ptyp))
+ and then Is_Limited_Type (Ptyp));
+ end if;
end if;
Rewrite (N, New_Occurrence_Of (Boolean_Literals (Res), Loc));
@@ -2797,7 +2838,7 @@ package body Exp_Attr is
Call :=
Make_Function_Call (Loc,
- Name => Name,
+ Name => Name,
Parameter_Associations => New_List (
New_Occurrence_Of
(Find_Protection_Object (Current_Scope), Loc),
@@ -2810,7 +2851,7 @@ package body Exp_Attr is
Call :=
Make_Function_Call (Loc,
- Name => Name,
+ Name => Name,
Parameter_Associations => New_List (
New_Occurrence_Of
(Find_Protection_Object (Current_Scope), Loc)));
@@ -2883,9 +2924,9 @@ package body Exp_Attr is
-- and then the Elab_Body/Spec attribute is replaced by a reference
-- to this defining identifier.
- when Attribute_Elab_Body |
- Attribute_Elab_Spec =>
-
+ when Attribute_Elab_Body
+ | Attribute_Elab_Spec
+ =>
-- Leave attribute unexpanded in CodePeer mode: the gnat2scil
-- back-end knows how to handle these attributes directly.
@@ -3005,50 +3046,57 @@ package body Exp_Attr is
-- Enum_Rep --
--------------
- when Attribute_Enum_Rep => Enum_Rep :
- begin
- -- X'Enum_Rep (Y) expands to
-
- -- target-type (Y)
+ when Attribute_Enum_Rep => Enum_Rep : declare
+ Expr : Node_Id;
- -- This is simply a direct conversion from the enumeration type to
- -- the target integer type, which is treated by the back end as a
- -- normal integer conversion, treating the enumeration type as an
- -- integer, which is exactly what we want. We set Conversion_OK to
- -- make sure that the analyzer does not complain about what otherwise
- -- might be an illegal conversion.
+ begin
+ -- Get the expression, which is X for Enum_Type'Enum_Rep (X) or
+ -- X'Enum_Rep.
if Is_Non_Empty_List (Exprs) then
- Rewrite (N,
- OK_Convert_To (Typ, Relocate_Node (First (Exprs))));
+ Expr := First (Exprs);
+ else
+ Expr := Pref;
+ end if;
- -- X'Enum_Rep where X is an enumeration literal is replaced by
- -- the literal value.
+ -- If the expression is an enumeration literal, it is replaced by the
+ -- literal value.
- elsif Ekind (Entity (Pref)) = E_Enumeration_Literal then
+ if Nkind (Expr) in N_Has_Entity
+ and then Ekind (Entity (Expr)) = E_Enumeration_Literal
+ then
Rewrite (N,
- Make_Integer_Literal (Loc, Enumeration_Rep (Entity (Pref))));
+ Make_Integer_Literal (Loc, Enumeration_Rep (Entity (Expr))));
-- If this is a renaming of a literal, recover the representation
- -- of the original. If it renames an expression there is nothing
- -- to fold.
-
- elsif Ekind (Entity (Pref)) = E_Constant
- and then Present (Renamed_Object (Entity (Pref)))
- and then Is_Entity_Name (Renamed_Object (Entity (Pref)))
- and then Ekind (Entity (Renamed_Object (Entity (Pref)))) =
+ -- of the original. If it renames an expression there is nothing to
+ -- fold.
+
+ elsif Nkind (Expr) in N_Has_Entity
+ and then Ekind (Entity (Expr)) = E_Constant
+ and then Present (Renamed_Object (Entity (Expr)))
+ and then Is_Entity_Name (Renamed_Object (Entity (Expr)))
+ and then Ekind (Entity (Renamed_Object (Entity (Expr)))) =
E_Enumeration_Literal
then
Rewrite (N,
Make_Integer_Literal (Loc,
- Enumeration_Rep (Entity (Renamed_Object (Entity (Pref))))));
+ Enumeration_Rep (Entity (Renamed_Object (Entity (Expr))))));
+
+ -- If not constant-folded above, Enum_Type'Enum_Rep (X) or
+ -- X'Enum_Rep expands to
- -- X'Enum_Rep where X is an object does a direct unchecked conversion
- -- of the object value, as described for the type case above.
+ -- target-type (X)
+
+ -- This is simply a direct conversion from the enumeration type to
+ -- the target integer type, which is treated by the back end as a
+ -- normal integer conversion, treating the enumeration type as an
+ -- integer, which is exactly what we want. We set Conversion_OK to
+ -- make sure that the analyzer does not complain about what otherwise
+ -- might be an illegal conversion.
else
- Rewrite (N,
- OK_Convert_To (Typ, Relocate_Node (Pref)));
+ Rewrite (N, OK_Convert_To (Typ, Relocate_Node (Expr)));
end if;
Set_Etype (N, Typ);
@@ -3106,18 +3154,132 @@ package body Exp_Attr is
-- transforme X'External_Tag into Ada.Tags.External_Tag (X'tag)
- when Attribute_External_Tag => External_Tag :
- begin
+ when Attribute_External_Tag =>
Rewrite (N,
Make_Function_Call (Loc,
- Name => New_Occurrence_Of (RTE (RE_External_Tag), Loc),
+ Name =>
+ New_Occurrence_Of (RTE (RE_External_Tag), Loc),
Parameter_Associations => New_List (
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Tag,
- Prefix => Prefix (N)))));
+ Prefix => Prefix (N)))));
Analyze_And_Resolve (N, Standard_String);
- end External_Tag;
+
+ -----------------------
+ -- Finalization_Size --
+ -----------------------
+
+ when Attribute_Finalization_Size => Finalization_Size : declare
+ function Calculate_Header_Size return Node_Id;
+ -- Generate a runtime call to calculate the size of the hidden header
+ -- along with any added padding which would precede a heap-allocated
+ -- object of the prefix type.
+
+ ---------------------------
+ -- Calculate_Header_Size --
+ ---------------------------
+
+ function Calculate_Header_Size return Node_Id is
+ begin
+ -- Generate:
+ -- Universal_Integer
+ -- (Header_Size_With_Padding (Pref'Alignment))
+
+ return
+ Convert_To (Universal_Integer,
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Header_Size_With_Padding), Loc),
+
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Copy_Tree (Pref),
+ Attribute_Name => Name_Alignment))));
+ end Calculate_Header_Size;
+
+ -- Local variables
+
+ Size : Entity_Id;
+
+ -- Start of Finalization_Size
+
+ begin
+ -- An object of a class-wide type first requires a runtime check to
+ -- determine whether it is actually controlled or not. Depending on
+ -- the outcome of this check, the Finalization_Size of the object
+ -- may be zero or some positive value.
+ --
+ -- In this scenario, Pref'Finalization_Size is expanded into
+ --
+ -- Size : Integer := 0;
+ --
+ -- if Needs_Finalization (Pref'Tag) then
+ -- Size :=
+ -- Universal_Integer
+ -- (Header_Size_With_Padding (Pref'Alignment));
+ -- end if;
+ --
+ -- and the attribute reference is replaced with a reference to Size.
+
+ if Is_Class_Wide_Type (Ptyp) then
+ Size := Make_Temporary (Loc, 'S');
+
+ Insert_Actions (N, New_List (
+
+ -- Generate:
+ -- Size : Integer := 0;
+
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Size,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Integer, Loc),
+ Expression => Make_Integer_Literal (Loc, 0)),
+
+ -- Generate:
+ -- if Needs_Finalization (Pref'Tag) then
+ -- Size :=
+ -- Universal_Integer
+ -- (Header_Size_With_Padding (Pref'Alignment));
+ -- end if;
+
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Needs_Finalization), Loc),
+
+ Parameter_Associations => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Copy_Tree (Pref),
+ Attribute_Name => Name_Tag))),
+
+ Then_Statements => New_List (
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Size, Loc),
+ Expression => Calculate_Header_Size)))));
+
+ Rewrite (N, New_Occurrence_Of (Size, Loc));
+
+ -- The prefix is known to be controlled at compile time. Calculate
+ -- Finalization_Size by calling function Header_Size_With_Padding.
+
+ elsif Needs_Finalization (Ptyp) then
+ Rewrite (N, Calculate_Header_Size);
+
+ -- The prefix is not an object with controlled parts, so its
+ -- Finalization_Size is zero.
+
+ else
+ Rewrite (N, Make_Integer_Literal (Loc, 0));
+ end if;
+
+ -- Due to cases where the entity type of the attribute is already
+ -- resolved the rewritten N must get re-resolved to its appropriate
+ -- type.
+
+ Analyze_And_Resolve (N, Typ);
+ end Finalization_Size;
-----------
-- First --
@@ -3217,8 +3379,7 @@ package body Exp_Attr is
-- that the back end always treats fixed-point as equivalent to the
-- corresponding integer type anyway.
- when Attribute_Fixed_Value => Fixed_Value :
- begin
+ when Attribute_Fixed_Value =>
Rewrite (N,
Make_Type_Conversion (Loc,
Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
@@ -3226,12 +3387,12 @@ package body Exp_Attr is
Set_Etype (N, Entity (Pref));
Set_Analyzed (N);
- -- Note: it might appear that a properly analyzed unchecked conversion
- -- would be just fine here, but that's not the case, since the full
- -- range checks performed by the following call are critical.
+ -- Note: it might appear that a properly analyzed unchecked
+ -- conversion would be just fine here, but that's not the case,
+ -- since the full range checks performed by the following call
+ -- are critical.
Apply_Type_Conversion_Checks (N);
- end Fixed_Value;
-----------
-- Floor --
@@ -3259,25 +3420,25 @@ package body Exp_Attr is
-- Note that we know that the type is a non-static subtype, or Fore
-- would have itself been computed dynamically in Eval_Attribute.
- when Attribute_Fore => Fore : begin
+ when Attribute_Fore =>
Rewrite (N,
Convert_To (Typ,
Make_Function_Call (Loc,
- Name => New_Occurrence_Of (RTE (RE_Fore), Loc),
+ Name =>
+ New_Occurrence_Of (RTE (RE_Fore), Loc),
Parameter_Associations => New_List (
Convert_To (Universal_Real,
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
Attribute_Name => Name_First)),
Convert_To (Universal_Real,
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
Attribute_Name => Name_Last))))));
Analyze_And_Resolve (N, Typ);
- end Fore;
--------------
-- Fraction --
@@ -3296,6 +3457,7 @@ package body Exp_Attr is
when Attribute_From_Any => From_Any : declare
P_Type : constant Entity_Id := Etype (Pref);
Decls : constant List_Id := New_List;
+
begin
Rewrite (N,
Build_From_Any_Call (P_Type,
@@ -3310,17 +3472,19 @@ package body Exp_Attr is
----------------------
when Attribute_Has_Same_Storage => Has_Same_Storage : declare
- Loc : constant Source_Ptr := Sloc (N);
+ Loc : constant Source_Ptr := Sloc (N);
- X : constant Node_Id := Prefix (N);
- Y : constant Node_Id := First (Expressions (N));
- -- The arguments
+ X : constant Node_Id := Prefix (N);
+ Y : constant Node_Id := First (Expressions (N));
+ -- The arguments
- X_Addr, Y_Addr : Node_Id;
- -- Rhe expressions for their addresses
+ X_Addr : Node_Id;
+ Y_Addr : Node_Id;
+ -- Rhe expressions for their addresses
- X_Size, Y_Size : Node_Id;
- -- Rhe expressions for their sizes
+ X_Size : Node_Id;
+ Y_Size : Node_Id;
+ -- Rhe expressions for their sizes
begin
-- The attribute is expanded as:
@@ -3333,40 +3497,40 @@ package body Exp_Attr is
X_Addr :=
Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Address,
- Prefix => New_Copy_Tree (X));
+ Attribute_Name => Name_Address,
+ Prefix => New_Copy_Tree (X));
Y_Addr :=
Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Address,
- Prefix => New_Copy_Tree (Y));
+ Attribute_Name => Name_Address,
+ Prefix => New_Copy_Tree (Y));
X_Size :=
Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Size,
- Prefix => New_Copy_Tree (X));
+ Attribute_Name => Name_Size,
+ Prefix => New_Copy_Tree (X));
Y_Size :=
Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Size,
- Prefix => New_Copy_Tree (Y));
+ Attribute_Name => Name_Size,
+ Prefix => New_Copy_Tree (Y));
if Etype (X) = Etype (Y) then
Rewrite (N,
- (Make_Op_Eq (Loc,
- Left_Opnd => X_Addr,
- Right_Opnd => Y_Addr)));
+ Make_Op_Eq (Loc,
+ Left_Opnd => X_Addr,
+ Right_Opnd => Y_Addr));
else
Rewrite (N,
- Make_Op_And (Loc,
- Left_Opnd =>
- Make_Op_Eq (Loc,
- Left_Opnd => X_Addr,
- Right_Opnd => Y_Addr),
- Right_Opnd =>
- Make_Op_Eq (Loc,
- Left_Opnd => X_Size,
- Right_Opnd => Y_Size)));
+ Make_Op_And (Loc,
+ Left_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => X_Addr,
+ Right_Opnd => Y_Addr),
+ Right_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => X_Size,
+ Right_Opnd => Y_Size)));
end if;
Analyze_And_Resolve (N, Standard_Boolean);
@@ -3443,8 +3607,7 @@ package body Exp_Attr is
-- X'Img is expanded to typ'Image (X), where typ is the type of X
- when Attribute_Img => Img :
- begin
+ when Attribute_Img =>
Rewrite (N,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Ptyp, Loc),
@@ -3452,7 +3615,6 @@ package body Exp_Attr is
Expressions => New_List (Relocate_Node (Pref))));
Analyze_And_Resolve (N, Standard_String);
- end Img;
-----------
-- Input --
@@ -3582,18 +3744,26 @@ package body Exp_Attr is
-- A special case arises if we have a defined _Read routine,
-- since in this case we are required to call this routine.
- if Present (TSS (Base_Type (U_Type), TSS_Stream_Read)) then
- Build_Record_Or_Elementary_Input_Function
- (Loc, U_Type, Decl, Fname);
- Insert_Action (N, Decl);
+ declare
+ Typ : Entity_Id := P_Type;
+ begin
+ if Present (Full_View (Typ)) then
+ Typ := Full_View (Typ);
+ end if;
+
+ if Present (TSS (Base_Type (Typ), TSS_Stream_Read)) then
+ Build_Record_Or_Elementary_Input_Function
+ (Loc, Typ, Decl, Fname, Use_Underlying => False);
+ Insert_Action (N, Decl);
- -- For normal cases, we call the I_xxx routine directly
+ -- For normal cases, we call the I_xxx routine directly
- else
- Rewrite (N, Build_Elementary_Input_Call (N));
- Analyze_And_Resolve (N, P_Type);
- return;
- end if;
+ else
+ Rewrite (N, Build_Elementary_Input_Call (N));
+ Analyze_And_Resolve (N, P_Type);
+ return;
+ end if;
+ end;
-- Array type case
@@ -3764,8 +3934,7 @@ package body Exp_Attr is
-- that the back end always treats fixed-point as equivalent to the
-- corresponding integer type anyway.
- when Attribute_Integer_Value => Integer_Value :
- begin
+ when Attribute_Integer_Value =>
Rewrite (N,
Make_Type_Conversion (Loc,
Subtype_Mark => New_Occurrence_Of (Entity (Pref), Loc),
@@ -3773,12 +3942,11 @@ package body Exp_Attr is
Set_Etype (N, Entity (Pref));
Set_Analyzed (N);
- -- Note: it might appear that a properly analyzed unchecked conversion
- -- would be just fine here, but that's not the case, since the full
- -- range checks performed by the following call are critical.
+ -- Note: it might appear that a properly analyzed unchecked
+ -- conversion would be just fine here, but that's not the case, since
+ -- the full range check performed by the following call is critical.
Apply_Type_Conversion_Checks (N);
- end Integer_Value;
-------------------
-- Invalid_Value --
@@ -4107,34 +4275,31 @@ package body Exp_Attr is
-- (Integer'Integer_Value (typ'First),
-- Integer'Integer_Value (typ'Last)));
- when Attribute_Mantissa => Mantissa : begin
+ when Attribute_Mantissa =>
Rewrite (N,
Convert_To (Typ,
Make_Function_Call (Loc,
- Name => New_Occurrence_Of (RTE (RE_Mantissa_Value), Loc),
+ Name =>
+ New_Occurrence_Of (RTE (RE_Mantissa_Value), Loc),
Parameter_Associations => New_List (
-
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Standard_Integer, Loc),
+ Prefix => New_Occurrence_Of (Standard_Integer, Loc),
Attribute_Name => Name_Integer_Value,
- Expressions => New_List (
-
+ Expressions => New_List (
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
Attribute_Name => Name_First))),
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Standard_Integer, Loc),
+ Prefix => New_Occurrence_Of (Standard_Integer, Loc),
Attribute_Name => Name_Integer_Value,
- Expressions => New_List (
-
+ Expressions => New_List (
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
Attribute_Name => Name_Last)))))));
Analyze_And_Resolve (N, Typ);
- end Mantissa;
---------
-- Max --
@@ -4231,7 +4396,7 @@ package body Exp_Attr is
when Attribute_Mechanism_Code =>
- -- We must replace the prefix i the renamed case
+ -- We must replace the prefix in the renamed case
if Is_Entity_Name (Pref)
and then Present (Alias (Entity (Pref)))
@@ -4355,10 +4520,24 @@ package body Exp_Attr is
Typ : constant Entity_Id := Etype (N);
CW_Temp : Entity_Id;
CW_Typ : Entity_Id;
+ Ins_Nod : Node_Id;
Subp : Node_Id;
Temp : Entity_Id;
begin
+ -- Generating C code we don't need to expand this attribute when
+ -- we are analyzing the internally built nested postconditions
+ -- procedure since it will be expanded inline (and later it will
+ -- be removed by Expand_N_Subprogram_Body). It this expansion is
+ -- performed in such case then the compiler generates unreferenced
+ -- extra temporaries.
+
+ if Modify_Tree_For_C
+ and then Chars (Current_Scope) = Name_uPostconditions
+ then
+ return;
+ end if;
+
-- Climb the parent chain looking for subprogram _Postconditions
Subp := N;
@@ -4379,9 +4558,12 @@ package body Exp_Attr is
end loop;
-- 'Old can only appear in a postcondition, the generated body of
- -- _Postconditions must be in the tree.
+ -- _Postconditions must be in the tree (or inlined if we are
+ -- generating C code).
- pragma Assert (Present (Subp));
+ pragma Assert
+ (Present (Subp)
+ or else (Modify_Tree_For_C and then In_Inlined_Body));
Temp := Make_Temporary (Loc, 'T', Pref);
@@ -4395,7 +4577,35 @@ package body Exp_Attr is
-- resides as this ensures that the object will be analyzed in the
-- proper context.
- Push_Scope (Scope (Defining_Entity (Subp)));
+ if Present (Subp) then
+ Push_Scope (Scope (Defining_Entity (Subp)));
+
+ -- No need to push the scope when generating C code since the
+ -- _Postcondition procedure has been inlined.
+
+ else pragma Assert (Modify_Tree_For_C);
+ pragma Assert (In_Inlined_Body);
+ null;
+ end if;
+
+ -- Locate the insertion place of the internal temporary that saves
+ -- the 'Old value.
+
+ if Present (Subp) then
+ Ins_Nod := Subp;
+
+ -- Generating C, the postcondition procedure has been inlined and the
+ -- temporary is added before the first declaration of the enclosing
+ -- subprogram.
+
+ else pragma Assert (Modify_Tree_For_C);
+ Ins_Nod := N;
+ while Nkind (Ins_Nod) /= N_Subprogram_Body loop
+ Ins_Nod := Parent (Ins_Nod);
+ end loop;
+
+ Ins_Nod := First (Declarations (Ins_Nod));
+ end if;
-- Preserve the tag of the prefix by offering a specific view of the
-- class-wide version of the prefix.
@@ -4408,7 +4618,7 @@ package body Exp_Attr is
CW_Temp := Make_Temporary (Loc, 'T');
CW_Typ := Class_Wide_Type (Typ);
- Insert_Before_And_Analyze (Subp,
+ Insert_Before_And_Analyze (Ins_Nod,
Make_Object_Declaration (Loc,
Defining_Identifier => CW_Temp,
Constant_Present => True,
@@ -4419,7 +4629,7 @@ package body Exp_Attr is
-- Generate:
-- Temp : Typ renames Typ (CW_Temp);
- Insert_Before_And_Analyze (Subp,
+ Insert_Before_And_Analyze (Ins_Nod,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Temp,
Subtype_Mark => New_Occurrence_Of (Typ, Loc),
@@ -4432,7 +4642,7 @@ package body Exp_Attr is
-- Generate:
-- Temp : constant Typ := Pref;
- Insert_Before_And_Analyze (Subp,
+ Insert_Before_And_Analyze (Ins_Nod,
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Constant_Present => True,
@@ -4440,7 +4650,9 @@ package body Exp_Attr is
Expression => Relocate_Node (Pref)));
end if;
- Pop_Scope;
+ if Present (Subp) then
+ Pop_Scope;
+ end if;
-- Ensure that the prefix of attribute 'Old is valid. The check must
-- be inserted after the expansion of the attribute has taken place
@@ -4635,18 +4847,26 @@ package body Exp_Attr is
-- A special case arises if we have a defined _Write routine,
-- since in this case we are required to call this routine.
- if Present (TSS (Base_Type (U_Type), TSS_Stream_Write)) then
- Build_Record_Or_Elementary_Output_Procedure
- (Loc, U_Type, Decl, Pname);
- Insert_Action (N, Decl);
+ declare
+ Typ : Entity_Id := P_Type;
+ begin
+ if Present (Full_View (Typ)) then
+ Typ := Full_View (Typ);
+ end if;
- -- For normal cases, we call the W_xxx routine directly
+ if Present (TSS (Base_Type (Typ), TSS_Stream_Write)) then
+ Build_Record_Or_Elementary_Output_Procedure
+ (Loc, Typ, Decl, Pname);
+ Insert_Action (N, Decl);
- else
- Rewrite (N, Build_Elementary_Write_Call (N));
- Analyze (N);
- return;
- end if;
+ -- For normal cases, we call the W_xxx routine directly
+
+ else
+ Rewrite (N, Build_Elementary_Write_Call (N));
+ Analyze (N);
+ return;
+ end if;
+ end;
-- Array type case
@@ -4791,8 +5011,7 @@ package body Exp_Attr is
-- For integer types, Pos is equivalent to a simple integer
-- conversion and we rewrite it as such
- when Attribute_Pos => Pos :
- declare
+ when Attribute_Pos => Pos : declare
Etyp : Entity_Id := Base_Type (Entity (Pref));
begin
@@ -4844,8 +5063,7 @@ package body Exp_Attr is
-- the computation up to the back end, since we don't know what layout
-- will be chosen.
- when Attribute_Position => Position_Attr :
- declare
+ when Attribute_Position => Position_Attr : declare
CE : constant Entity_Id := Entity (Selector_Name (Pref));
begin
@@ -4888,8 +5106,7 @@ package body Exp_Attr is
-- 2. For floating-point, generate call to attribute function.
-- 3. For other cases, deal with constraint checking.
- when Attribute_Pred => Pred :
- declare
+ when Attribute_Pred => Pred : declare
Etyp : constant Entity_Id := Base_Type (Ptyp);
begin
@@ -4996,117 +5213,107 @@ package body Exp_Attr is
-- about complications that would other arise from X'Priority'Access,
-- which is illegal, because of the lack of aliasing.
- when Attribute_Priority =>
- declare
- Call : Node_Id;
- Conctyp : Entity_Id;
- Object_Parm : Node_Id;
- Subprg : Entity_Id;
- RT_Subprg_Name : Node_Id;
-
- begin
- -- Look for the enclosing concurrent type
+ when Attribute_Priority => Priority : declare
+ Call : Node_Id;
+ Conctyp : Entity_Id;
+ New_Itype : Entity_Id;
+ Object_Parm : Node_Id;
+ Subprg : Entity_Id;
+ RT_Subprg_Name : Node_Id;
- Conctyp := Current_Scope;
- while not Is_Concurrent_Type (Conctyp) loop
- Conctyp := Scope (Conctyp);
- end loop;
+ begin
+ -- Look for the enclosing concurrent type
- pragma Assert (Is_Protected_Type (Conctyp));
+ Conctyp := Current_Scope;
+ while not Is_Concurrent_Type (Conctyp) loop
+ Conctyp := Scope (Conctyp);
+ end loop;
- -- Generate the actual of the call
+ pragma Assert (Is_Protected_Type (Conctyp));
- Subprg := Current_Scope;
- while not Present (Protected_Body_Subprogram (Subprg)) loop
- Subprg := Scope (Subprg);
- end loop;
+ -- Generate the actual of the call
- -- Use of 'Priority inside protected entries and barriers (in
- -- both cases the type of the first formal of their expanded
- -- subprogram is Address)
+ Subprg := Current_Scope;
+ while not Present (Protected_Body_Subprogram (Subprg)) loop
+ Subprg := Scope (Subprg);
+ end loop;
- if Etype (First_Entity (Protected_Body_Subprogram (Subprg))) =
- RTE (RE_Address)
- then
- declare
- New_Itype : Entity_Id;
+ -- Use of 'Priority inside protected entries and barriers (in both
+ -- cases the type of the first formal of their expanded subprogram
+ -- is Address)
- begin
- -- In the expansion of protected entries the type of the
- -- first formal of the Protected_Body_Subprogram is an
- -- Address. In order to reference the _object component
- -- we generate:
+ if Etype (First_Entity (Protected_Body_Subprogram (Subprg))) =
+ RTE (RE_Address)
+ then
+ -- In the expansion of protected entries the type of the first
+ -- formal of the Protected_Body_Subprogram is an Address. In order
+ -- to reference the _object component we generate:
- -- type T is access p__ptTV;
- -- freeze T []
+ -- type T is access p__ptTV;
+ -- freeze T []
- New_Itype := Create_Itype (E_Access_Type, N);
- Set_Etype (New_Itype, New_Itype);
- Set_Directly_Designated_Type (New_Itype,
- Corresponding_Record_Type (Conctyp));
- Freeze_Itype (New_Itype, N);
+ New_Itype := Create_Itype (E_Access_Type, N);
+ Set_Etype (New_Itype, New_Itype);
+ Set_Directly_Designated_Type (New_Itype,
+ Corresponding_Record_Type (Conctyp));
+ Freeze_Itype (New_Itype, N);
- -- Generate:
- -- T!(O)._object'unchecked_access
+ -- Generate:
+ -- T!(O)._object'unchecked_access
- Object_Parm :=
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix =>
- Unchecked_Convert_To (New_Itype,
- New_Occurrence_Of
- (First_Entity
- (Protected_Body_Subprogram (Subprg)),
- Loc)),
- Selector_Name =>
- Make_Identifier (Loc, Name_uObject)),
- Attribute_Name => Name_Unchecked_Access);
- end;
+ Object_Parm :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (New_Itype,
+ New_Occurrence_Of
+ (First_Entity (Protected_Body_Subprogram (Subprg)),
+ Loc)),
+ Selector_Name => Make_Identifier (Loc, Name_uObject)),
+ Attribute_Name => Name_Unchecked_Access);
- -- Use of 'Priority inside a protected subprogram
+ -- Use of 'Priority inside a protected subprogram
- else
- Object_Parm :=
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of
- (First_Entity
- (Protected_Body_Subprogram (Subprg)),
- Loc),
- Selector_Name => Make_Identifier (Loc, Name_uObject)),
- Attribute_Name => Name_Unchecked_Access);
- end if;
+ else
+ Object_Parm :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of
+ (First_Entity (Protected_Body_Subprogram (Subprg)),
+ Loc),
+ Selector_Name => Make_Identifier (Loc, Name_uObject)),
+ Attribute_Name => Name_Unchecked_Access);
+ end if;
- -- Select the appropriate run-time subprogram
+ -- Select the appropriate run-time subprogram
- if Number_Entries (Conctyp) = 0 then
- RT_Subprg_Name :=
- New_Occurrence_Of (RTE (RE_Get_Ceiling), Loc);
- else
- RT_Subprg_Name :=
- New_Occurrence_Of (RTE (RO_PE_Get_Ceiling), Loc);
- end if;
+ if Number_Entries (Conctyp) = 0 then
+ RT_Subprg_Name := New_Occurrence_Of (RTE (RE_Get_Ceiling), Loc);
+ else
+ RT_Subprg_Name := New_Occurrence_Of (RTE (RO_PE_Get_Ceiling), Loc);
+ end if;
- Call :=
- Make_Function_Call (Loc,
- Name => RT_Subprg_Name,
- Parameter_Associations => New_List (Object_Parm));
+ Call :=
+ Make_Function_Call (Loc,
+ Name => RT_Subprg_Name,
+ Parameter_Associations => New_List (Object_Parm));
- Rewrite (N, Call);
+ Rewrite (N, Call);
- -- Avoid the generation of extra checks on the pointer to the
- -- protected object.
+ -- Avoid the generation of extra checks on the pointer to the
+ -- protected object.
- Analyze_And_Resolve (N, Typ, Suppress => Access_Check);
- end;
+ Analyze_And_Resolve (N, Typ, Suppress => Access_Check);
+ end Priority;
------------------
-- Range_Length --
------------------
- when Attribute_Range_Length => Range_Length : begin
+ when Attribute_Range_Length =>
-- The only special processing required is for the case where
-- Range_Length is applied to an enumeration type with holes.
@@ -5126,25 +5333,27 @@ package body Exp_Attr is
then
Rewrite (N,
Make_Op_Add (Loc,
- Left_Opnd =>
+ Left_Opnd =>
Make_Op_Subtract (Loc,
- Left_Opnd =>
+ Left_Opnd =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Pos,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
- Expressions => New_List (
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
+ Expressions => New_List (
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Last,
- Prefix => New_Occurrence_Of (Ptyp, Loc)))),
+ Prefix =>
+ New_Occurrence_Of (Ptyp, Loc)))),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Pos,
- Prefix => New_Occurrence_Of (Ptyp, Loc),
- Expressions => New_List (
+ Prefix => New_Occurrence_Of (Ptyp, Loc),
+ Expressions => New_List (
Make_Attribute_Reference (Loc,
Attribute_Name => Name_First,
- Prefix => New_Occurrence_Of (Ptyp, Loc))))),
+ Prefix =>
+ New_Occurrence_Of (Ptyp, Loc))))),
Right_Opnd => Make_Integer_Literal (Loc, 1)));
@@ -5157,7 +5366,6 @@ package body Exp_Attr is
else
Apply_Universal_Integer_Attribute_Checks (N);
end if;
- end Range_Length;
----------
-- Read --
@@ -5448,241 +5656,247 @@ package body Exp_Attr is
-- Size --
----------
- when Attribute_Size |
- Attribute_Object_Size |
- Attribute_Value_Size |
- Attribute_VADS_Size => Size :
-
- declare
- Siz : Uint;
- New_Node : Node_Id;
-
- begin
- -- Processing for VADS_Size case. Note that this processing removes
- -- all traces of VADS_Size from the tree, and completes all required
- -- processing for VADS_Size by translating the attribute reference
- -- to an appropriate Size or Object_Size reference.
+ when Attribute_Object_Size
+ | Attribute_Size
+ | Attribute_Value_Size
+ | Attribute_VADS_Size
+ =>
+ Size : declare
+ Siz : Uint;
+ New_Node : Node_Id;
- if Id = Attribute_VADS_Size
- or else (Use_VADS_Size and then Id = Attribute_Size)
- then
- -- If the size is specified, then we simply use the specified
- -- size. This applies to both types and objects. The size of an
- -- object can be specified in the following ways:
-
- -- An explicit size object is given for an object
- -- A component size is specified for an indexed component
- -- A component clause is specified for a selected component
- -- The object is a component of a packed composite object
-
- -- If the size is specified, then VADS_Size of an object
-
- if (Is_Entity_Name (Pref)
- and then Present (Size_Clause (Entity (Pref))))
- or else
- (Nkind (Pref) = N_Component_Clause
- and then (Present (Component_Clause
- (Entity (Selector_Name (Pref))))
- or else Is_Packed (Etype (Prefix (Pref)))))
- or else
- (Nkind (Pref) = N_Indexed_Component
- and then (Component_Size (Etype (Prefix (Pref))) /= 0
- or else Is_Packed (Etype (Prefix (Pref)))))
+ begin
+ -- Processing for VADS_Size case. Note that this processing
+ -- removes all traces of VADS_Size from the tree, and completes
+ -- all required processing for VADS_Size by translating the
+ -- attribute reference to an appropriate Size or Object_Size
+ -- reference.
+
+ if Id = Attribute_VADS_Size
+ or else (Use_VADS_Size and then Id = Attribute_Size)
then
- Set_Attribute_Name (N, Name_Size);
+ -- If the size is specified, then we simply use the specified
+ -- size. This applies to both types and objects. The size of an
+ -- object can be specified in the following ways:
+
+ -- An explicit size object is given for an object
+ -- A component size is specified for an indexed component
+ -- A component clause is specified for a selected component
+ -- The object is a component of a packed composite object
+
+ -- If the size is specified, then VADS_Size of an object
+
+ if (Is_Entity_Name (Pref)
+ and then Present (Size_Clause (Entity (Pref))))
+ or else
+ (Nkind (Pref) = N_Component_Clause
+ and then (Present (Component_Clause
+ (Entity (Selector_Name (Pref))))
+ or else Is_Packed (Etype (Prefix (Pref)))))
+ or else
+ (Nkind (Pref) = N_Indexed_Component
+ and then (Component_Size (Etype (Prefix (Pref))) /= 0
+ or else Is_Packed (Etype (Prefix (Pref)))))
+ then
+ Set_Attribute_Name (N, Name_Size);
- -- Otherwise if we have an object rather than a type, then the
- -- VADS_Size attribute applies to the type of the object, rather
- -- than the object itself. This is one of the respects in which
- -- VADS_Size differs from Size.
+ -- Otherwise if we have an object rather than a type, then
+ -- the VADS_Size attribute applies to the type of the object,
+ -- rather than the object itself. This is one of the respects
+ -- in which VADS_Size differs from Size.
- else
- if (not Is_Entity_Name (Pref)
- or else not Is_Type (Entity (Pref)))
- and then (Is_Scalar_Type (Ptyp) or else Is_Constrained (Ptyp))
- then
- Rewrite (Pref, New_Occurrence_Of (Ptyp, Loc));
- end if;
+ else
+ if (not Is_Entity_Name (Pref)
+ or else not Is_Type (Entity (Pref)))
+ and then (Is_Scalar_Type (Ptyp)
+ or else Is_Constrained (Ptyp))
+ then
+ Rewrite (Pref, New_Occurrence_Of (Ptyp, Loc));
+ end if;
- -- For a scalar type for which no size was explicitly given,
- -- VADS_Size means Object_Size. This is the other respect in
- -- which VADS_Size differs from Size.
+ -- For a scalar type for which no size was explicitly given,
+ -- VADS_Size means Object_Size. This is the other respect in
+ -- which VADS_Size differs from Size.
- if Is_Scalar_Type (Ptyp) and then No (Size_Clause (Ptyp)) then
- Set_Attribute_Name (N, Name_Object_Size);
+ if Is_Scalar_Type (Ptyp)
+ and then No (Size_Clause (Ptyp))
+ then
+ Set_Attribute_Name (N, Name_Object_Size);
- -- In all other cases, Size and VADS_Size are the sane
+ -- In all other cases, Size and VADS_Size are the sane
- else
- Set_Attribute_Name (N, Name_Size);
+ else
+ Set_Attribute_Name (N, Name_Size);
+ end if;
end if;
end if;
- end if;
- -- If the prefix is X'Class, we transform it into a direct reference
- -- to the class-wide type, because the back end must not see a 'Class
- -- reference.
+ -- If the prefix is X'Class, transform it into a direct reference
+ -- to the class-wide type, because the back end must not see a
+ -- 'Class reference.
- if Is_Entity_Name (Pref)
- and then Is_Class_Wide_Type (Entity (Pref))
- then
- Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
- return;
+ if Is_Entity_Name (Pref)
+ and then Is_Class_Wide_Type (Entity (Pref))
+ then
+ Rewrite (Prefix (N), New_Occurrence_Of (Entity (Pref), Loc));
+ return;
- -- For X'Size applied to an object of a class-wide type, transform
- -- X'Size into a call to the primitive operation _Size applied to X.
+ -- For X'Size applied to an object of a class-wide type, transform
+ -- X'Size into a call to the primitive operation _Size applied to
+ -- X.
- elsif Is_Class_Wide_Type (Ptyp) then
+ elsif Is_Class_Wide_Type (Ptyp) then
- -- No need to do anything else compiling under restriction
- -- No_Dispatching_Calls. During the semantic analysis we
- -- already noted this restriction violation.
+ -- No need to do anything else compiling under restriction
+ -- No_Dispatching_Calls. During the semantic analysis we
+ -- already noted this restriction violation.
- if Restriction_Active (No_Dispatching_Calls) then
- return;
- end if;
+ if Restriction_Active (No_Dispatching_Calls) then
+ return;
+ end if;
- New_Node :=
- Make_Function_Call (Loc,
- Name => New_Occurrence_Of
- (Find_Prim_Op (Ptyp, Name_uSize), Loc),
- Parameter_Associations => New_List (Pref));
+ New_Node :=
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (Find_Prim_Op (Ptyp, Name_uSize), Loc),
+ Parameter_Associations => New_List (Pref));
- if Typ /= Standard_Long_Long_Integer then
+ if Typ /= Standard_Long_Long_Integer then
- -- The context is a specific integer type with which the
- -- original attribute was compatible. The function has a
- -- specific type as well, so to preserve the compatibility
- -- we must convert explicitly.
+ -- The context is a specific integer type with which the
+ -- original attribute was compatible. The function has a
+ -- specific type as well, so to preserve the compatibility
+ -- we must convert explicitly.
- New_Node := Convert_To (Typ, New_Node);
- end if;
+ New_Node := Convert_To (Typ, New_Node);
+ end if;
- Rewrite (N, New_Node);
- Analyze_And_Resolve (N, Typ);
- return;
+ Rewrite (N, New_Node);
+ Analyze_And_Resolve (N, Typ);
+ return;
- -- Case of known RM_Size of a type
+ -- Case of known RM_Size of a type
- elsif (Id = Attribute_Size or else Id = Attribute_Value_Size)
- and then Is_Entity_Name (Pref)
- and then Is_Type (Entity (Pref))
- and then Known_Static_RM_Size (Entity (Pref))
- then
- Siz := RM_Size (Entity (Pref));
+ elsif (Id = Attribute_Size or else Id = Attribute_Value_Size)
+ and then Is_Entity_Name (Pref)
+ and then Is_Type (Entity (Pref))
+ and then Known_Static_RM_Size (Entity (Pref))
+ then
+ Siz := RM_Size (Entity (Pref));
- -- Case of known Esize of a type
+ -- Case of known Esize of a type
- elsif Id = Attribute_Object_Size
- and then Is_Entity_Name (Pref)
- and then Is_Type (Entity (Pref))
- and then Known_Static_Esize (Entity (Pref))
- then
- Siz := Esize (Entity (Pref));
+ elsif Id = Attribute_Object_Size
+ and then Is_Entity_Name (Pref)
+ and then Is_Type (Entity (Pref))
+ and then Known_Static_Esize (Entity (Pref))
+ then
+ Siz := Esize (Entity (Pref));
- -- Case of known size of object
+ -- Case of known size of object
- elsif Id = Attribute_Size
- and then Is_Entity_Name (Pref)
- and then Is_Object (Entity (Pref))
- and then Known_Esize (Entity (Pref))
- and then Known_Static_Esize (Entity (Pref))
- then
- Siz := Esize (Entity (Pref));
+ elsif Id = Attribute_Size
+ and then Is_Entity_Name (Pref)
+ and then Is_Object (Entity (Pref))
+ and then Known_Esize (Entity (Pref))
+ and then Known_Static_Esize (Entity (Pref))
+ then
+ Siz := Esize (Entity (Pref));
- -- For an array component, we can do Size in the front end
- -- if the component_size of the array is set.
+ -- For an array component, we can do Size in the front end if the
+ -- component_size of the array is set.
- elsif Nkind (Pref) = N_Indexed_Component then
- Siz := Component_Size (Etype (Prefix (Pref)));
+ elsif Nkind (Pref) = N_Indexed_Component then
+ Siz := Component_Size (Etype (Prefix (Pref)));
- -- For a record component, we can do Size in the front end if there
- -- is a component clause, or if the record is packed and the
- -- component's size is known at compile time.
+ -- For a record component, we can do Size in the front end if
+ -- there is a component clause, or if the record is packed and the
+ -- component's size is known at compile time.
- elsif Nkind (Pref) = N_Selected_Component then
- declare
- Rec : constant Entity_Id := Etype (Prefix (Pref));
- Comp : constant Entity_Id := Entity (Selector_Name (Pref));
+ elsif Nkind (Pref) = N_Selected_Component then
+ declare
+ Rec : constant Entity_Id := Etype (Prefix (Pref));
+ Comp : constant Entity_Id := Entity (Selector_Name (Pref));
- begin
- if Present (Component_Clause (Comp)) then
- Siz := Esize (Comp);
+ begin
+ if Present (Component_Clause (Comp)) then
+ Siz := Esize (Comp);
- elsif Is_Packed (Rec) then
- Siz := RM_Size (Ptyp);
+ elsif Is_Packed (Rec) then
+ Siz := RM_Size (Ptyp);
- else
- Apply_Universal_Integer_Attribute_Checks (N);
- return;
- end if;
- end;
+ else
+ Apply_Universal_Integer_Attribute_Checks (N);
+ return;
+ end if;
+ end;
- -- All other cases are handled by the back end
+ -- All other cases are handled by the back end
- else
- Apply_Universal_Integer_Attribute_Checks (N);
+ else
+ Apply_Universal_Integer_Attribute_Checks (N);
- -- If Size is applied to a formal parameter that is of a packed
- -- array subtype, then apply Size to the actual subtype.
+ -- If Size is applied to a formal parameter that is of a packed
+ -- array subtype, then apply Size to the actual subtype.
- if Is_Entity_Name (Pref)
- and then Is_Formal (Entity (Pref))
- and then Is_Array_Type (Ptyp)
- and then Is_Packed (Ptyp)
- then
- Rewrite (N,
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Get_Actual_Subtype (Pref), Loc),
- Attribute_Name => Name_Size));
- Analyze_And_Resolve (N, Typ);
- end if;
+ if Is_Entity_Name (Pref)
+ and then Is_Formal (Entity (Pref))
+ and then Is_Array_Type (Ptyp)
+ and then Is_Packed (Ptyp)
+ then
+ Rewrite (N,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Get_Actual_Subtype (Pref), Loc),
+ Attribute_Name => Name_Size));
+ Analyze_And_Resolve (N, Typ);
+ end if;
- -- If Size applies to a dereference of an access to unconstrained
- -- packed array, the back end needs to see its unconstrained
- -- nominal type, but also a hint to the actual constrained type.
+ -- If Size applies to a dereference of an access to
+ -- unconstrained packed array, the back end needs to see its
+ -- unconstrained nominal type, but also a hint to the actual
+ -- constrained type.
- if Nkind (Pref) = N_Explicit_Dereference
- and then Is_Array_Type (Ptyp)
- and then not Is_Constrained (Ptyp)
- and then Is_Packed (Ptyp)
- then
- Set_Actual_Designated_Subtype (Pref,
- Get_Actual_Subtype (Pref));
- end if;
+ if Nkind (Pref) = N_Explicit_Dereference
+ and then Is_Array_Type (Ptyp)
+ and then not Is_Constrained (Ptyp)
+ and then Is_Packed (Ptyp)
+ then
+ Set_Actual_Designated_Subtype (Pref,
+ Get_Actual_Subtype (Pref));
+ end if;
- return;
- end if;
+ return;
+ end if;
- -- Common processing for record and array component case
+ -- Common processing for record and array component case
- if Siz /= No_Uint and then Siz /= 0 then
- declare
- CS : constant Boolean := Comes_From_Source (N);
+ if Siz /= No_Uint and then Siz /= 0 then
+ declare
+ CS : constant Boolean := Comes_From_Source (N);
- begin
- Rewrite (N, Make_Integer_Literal (Loc, Siz));
+ begin
+ Rewrite (N, Make_Integer_Literal (Loc, Siz));
- -- This integer literal is not a static expression. We do not
- -- call Analyze_And_Resolve here, because this would activate
- -- the circuit for deciding that a static value was out of
- -- range, and we don't want that.
+ -- This integer literal is not a static expression. We do
+ -- not call Analyze_And_Resolve here, because this would
+ -- activate the circuit for deciding that a static value
+ -- was out of range, and we don't want that.
- -- So just manually set the type, mark the expression as non-
- -- static, and then ensure that the result is checked properly
- -- if the attribute comes from source (if it was internally
- -- generated, we never need a constraint check).
+ -- So just manually set the type, mark the expression as
+ -- non-static, and then ensure that the result is checked
+ -- properly if the attribute comes from source (if it was
+ -- internally generated, we never need a constraint check).
- Set_Etype (N, Typ);
- Set_Is_Static_Expression (N, False);
+ Set_Etype (N, Typ);
+ Set_Is_Static_Expression (N, False);
- if CS then
- Apply_Constraint_Check (N, Typ);
- end if;
- end;
- end if;
- end Size;
+ if CS then
+ Apply_Constraint_Check (N, Typ);
+ end if;
+ end;
+ end if;
+ end Size;
------------------
-- Storage_Pool --
@@ -5892,7 +6106,6 @@ package body Exp_Attr is
Etyp : constant Entity_Id := Base_Type (Ptyp);
begin
-
-- For enumeration types with non-standard representations, we
-- expand typ'Succ (x) into
@@ -6062,8 +6275,8 @@ package body Exp_Attr is
-- Transforms 'Terminated attribute into a call to Terminated function
- when Attribute_Terminated => Terminated :
- begin
+ when Attribute_Terminated => Terminated : begin
+
-- The prefix of Terminated is of a task interface class-wide type.
-- Generate:
-- terminated (Task_Id (Pref._disp_get_task_id));
@@ -6107,7 +6320,9 @@ package body Exp_Attr is
-- Transforms System'To_Address (X) and System.Address'Ref (X) into
-- unchecked conversion from (integral) type of X to type address.
- when Attribute_To_Address | Attribute_Ref =>
+ when Attribute_Ref
+ | Attribute_To_Address
+ =>
Rewrite (N,
Unchecked_Convert_To (RTE (RE_Address),
Relocate_Node (First (Exprs))));
@@ -6352,96 +6567,93 @@ package body Exp_Attr is
-- Start of processing for Float_Valid
begin
- case Float_Rep (Btyp) is
-
- -- The AAMP back end handles Valid for floating-point types
-
- when AAMP =>
- Analyze_And_Resolve (Pref, Ptyp);
- Set_Etype (N, Standard_Boolean);
- Set_Analyzed (N);
-
- when IEEE_Binary =>
- Find_Fat_Info (Ptyp, Ftp, Pkg);
-
- -- If the prefix is a reverse SSO component, or is
- -- possibly unaligned, first create a temporary copy
- -- that is in native SSO, and properly aligned. Make it
- -- Volatile to prevent folding in the back-end. Note
- -- that we use an intermediate constrained string type
- -- to initialize the temporary, as the value at hand
- -- might be invalid, and in that case it cannot be copied
- -- using a floating point register.
-
- if In_Reverse_Storage_Order_Object (Pref)
- or else
- Is_Possibly_Unaligned_Object (Pref)
- then
- declare
- Temp : constant Entity_Id :=
- Make_Temporary (Loc, 'F');
-
- Fat_S : constant Entity_Id :=
- Get_Fat_Entity (Name_S);
- -- Constrained string subtype of appropriate size
-
- Fat_P : constant Entity_Id :=
- Get_Fat_Entity (Name_P);
- -- Access to Fat_S
+ -- The C and AAMP back-ends handle Valid for fpt types
- Decl : constant Node_Id :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp,
- Aliased_Present => True,
- Object_Definition =>
- New_Occurrence_Of (Ptyp, Loc));
+ if Modify_Tree_For_C or else Float_Rep (Btyp) = AAMP then
+ Analyze_And_Resolve (Pref, Ptyp);
+ Set_Etype (N, Standard_Boolean);
+ Set_Analyzed (N);
- begin
- Set_Aspect_Specifications (Decl, New_List (
- Make_Aspect_Specification (Loc,
- Identifier =>
- Make_Identifier (Loc, Name_Volatile))));
-
- Insert_Actions (N,
- New_List (
- Decl,
-
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Explicit_Dereference (Loc,
- Prefix =>
- Unchecked_Convert_To (Fat_P,
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Temp, Loc),
- Attribute_Name =>
- Name_Unrestricted_Access))),
- Expression =>
- Unchecked_Convert_To (Fat_S,
- Relocate_Node (Pref)))),
-
- Suppress => All_Checks);
-
- Rewrite (Pref, New_Occurrence_Of (Temp, Loc));
- end;
- end if;
+ else
+ Find_Fat_Info (Ptyp, Ftp, Pkg);
+
+ -- If the prefix is a reverse SSO component, or is possibly
+ -- unaligned, first create a temporary copy that is in
+ -- native SSO, and properly aligned. Make it Volatile to
+ -- prevent folding in the back-end. Note that we use an
+ -- intermediate constrained string type to initialize the
+ -- temporary, as the value at hand might be invalid, and in
+ -- that case it cannot be copied using a floating point
+ -- register.
+
+ if In_Reverse_Storage_Order_Object (Pref)
+ or else Is_Possibly_Unaligned_Object (Pref)
+ then
+ declare
+ Temp : constant Entity_Id :=
+ Make_Temporary (Loc, 'F');
+
+ Fat_S : constant Entity_Id :=
+ Get_Fat_Entity (Name_S);
+ -- Constrained string subtype of appropriate size
+
+ Fat_P : constant Entity_Id :=
+ Get_Fat_Entity (Name_P);
+ -- Access to Fat_S
+
+ Decl : constant Node_Id :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Aliased_Present => True,
+ Object_Definition =>
+ New_Occurrence_Of (Ptyp, Loc));
+
+ begin
+ Set_Aspect_Specifications (Decl, New_List (
+ Make_Aspect_Specification (Loc,
+ Identifier =>
+ Make_Identifier (Loc, Name_Volatile))));
+
+ Insert_Actions (N,
+ New_List (
+ Decl,
+
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ Unchecked_Convert_To (Fat_P,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Temp, Loc),
+ Attribute_Name =>
+ Name_Unrestricted_Access))),
+ Expression =>
+ Unchecked_Convert_To (Fat_S,
+ Relocate_Node (Pref)))),
+
+ Suppress => All_Checks);
+
+ Rewrite (Pref, New_Occurrence_Of (Temp, Loc));
+ end;
+ end if;
- -- We now have an object of the proper endianness and
- -- alignment, and can construct a Valid attribute.
+ -- We now have an object of the proper endianness and
+ -- alignment, and can construct a Valid attribute.
- -- We make sure the prefix of this valid attribute is
- -- marked as not coming from source, to avoid losing
- -- warnings from 'Valid looking like a possible update.
+ -- We make sure the prefix of this valid attribute is
+ -- marked as not coming from source, to avoid losing
+ -- warnings from 'Valid looking like a possible update.
- Set_Comes_From_Source (Pref, False);
+ Set_Comes_From_Source (Pref, False);
- Expand_Fpt_Attribute
- (N, Pkg, Name_Valid,
- New_List (
- Make_Attribute_Reference (Loc,
- Prefix => Unchecked_Convert_To (Ftp, Pref),
- Attribute_Name => Name_Unrestricted_Access)));
- end case;
+ Expand_Fpt_Attribute
+ (N, Pkg, Name_Valid,
+ New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => Unchecked_Convert_To (Ftp, Pref),
+ Attribute_Name => Name_Unrestricted_Access)));
+ end if;
-- One more task, we still need a range check. Required
-- only if we have a constraint, since the Valid routine
@@ -6797,8 +7009,7 @@ package body Exp_Attr is
-- is in use such as Shift-JIS, then characters that cannot be
-- represented using this encoding will not appear in any case.
- when Attribute_Wide_Value => Wide_Value :
- begin
+ when Attribute_Wide_Value =>
Rewrite (N,
Make_Attribute_Reference (Loc,
Prefix => Pref,
@@ -6815,7 +7026,6 @@ package body Exp_Attr is
Intval => Int (Wide_Character_Encoding_Method)))))));
Analyze_And_Resolve (N, Typ);
- end Wide_Value;
---------------------
-- Wide_Wide_Value --
@@ -6835,8 +7045,7 @@ package body Exp_Attr is
-- It's not quite right where typ = Wide_Wide_Character, because the
-- encoding method may not cover the whole character type ???
- when Attribute_Wide_Wide_Value => Wide_Wide_Value :
- begin
+ when Attribute_Wide_Wide_Value =>
Rewrite (N,
Make_Attribute_Reference (Loc,
Prefix => Pref,
@@ -6844,7 +7053,7 @@ package body Exp_Attr is
Expressions => New_List (
Make_Function_Call (Loc,
- Name =>
+ Name =>
New_Occurrence_Of
(RTE (RE_Wide_Wide_String_To_String), Loc),
@@ -6854,7 +7063,6 @@ package body Exp_Attr is
Intval => Int (Wide_Character_Encoding_Method)))))));
Analyze_And_Resolve (N, Typ);
- end Wide_Wide_Value;
---------------------
-- Wide_Wide_Width --
@@ -7037,92 +7245,96 @@ package body Exp_Attr is
-- The back end also handles the non-class-wide cases of Size
- when Attribute_Bit_Order |
- Attribute_Code_Address |
- Attribute_Definite |
- Attribute_Deref |
- Attribute_Null_Parameter |
- Attribute_Passed_By_Reference |
- Attribute_Pool_Address |
- Attribute_Scalar_Storage_Order =>
+ when Attribute_Bit_Order
+ | Attribute_Code_Address
+ | Attribute_Definite
+ | Attribute_Deref
+ | Attribute_Null_Parameter
+ | Attribute_Passed_By_Reference
+ | Attribute_Pool_Address
+ | Attribute_Scalar_Storage_Order
+ =>
null;
-- The following attributes are also handled by the back end, but return
-- a universal integer result, so may need a conversion for checking
-- that the result is in range.
- when Attribute_Aft |
- Attribute_Max_Alignment_For_Allocation =>
+ when Attribute_Aft
+ | Attribute_Max_Alignment_For_Allocation
+ =>
Apply_Universal_Integer_Attribute_Checks (N);
-- The following attributes should not appear at this stage, since they
-- have already been handled by the analyzer (and properly rewritten
-- with corresponding values or entities to represent the right values)
- when Attribute_Abort_Signal |
- Attribute_Address_Size |
- Attribute_Atomic_Always_Lock_Free |
- Attribute_Base |
- Attribute_Class |
- Attribute_Compiler_Version |
- Attribute_Default_Bit_Order |
- Attribute_Default_Scalar_Storage_Order |
- Attribute_Delta |
- Attribute_Denorm |
- Attribute_Digits |
- Attribute_Emax |
- Attribute_Enabled |
- Attribute_Epsilon |
- Attribute_Fast_Math |
- Attribute_First_Valid |
- Attribute_Has_Access_Values |
- Attribute_Has_Discriminants |
- Attribute_Has_Tagged_Values |
- Attribute_Large |
- Attribute_Last_Valid |
- Attribute_Library_Level |
- Attribute_Lock_Free |
- Attribute_Machine_Emax |
- Attribute_Machine_Emin |
- Attribute_Machine_Mantissa |
- Attribute_Machine_Overflows |
- Attribute_Machine_Radix |
- Attribute_Machine_Rounds |
- Attribute_Maximum_Alignment |
- Attribute_Model_Emin |
- Attribute_Model_Epsilon |
- Attribute_Model_Mantissa |
- Attribute_Model_Small |
- Attribute_Modulus |
- Attribute_Partition_ID |
- Attribute_Range |
- Attribute_Restriction_Set |
- Attribute_Safe_Emax |
- Attribute_Safe_First |
- Attribute_Safe_Large |
- Attribute_Safe_Last |
- Attribute_Safe_Small |
- Attribute_Scale |
- Attribute_Signed_Zeros |
- Attribute_Small |
- Attribute_Storage_Unit |
- Attribute_Stub_Type |
- Attribute_System_Allocator_Alignment |
- Attribute_Target_Name |
- Attribute_Type_Class |
- Attribute_Type_Key |
- Attribute_Unconstrained_Array |
- Attribute_Universal_Literal_String |
- Attribute_Wchar_T_Size |
- Attribute_Word_Size =>
+ when Attribute_Abort_Signal
+ | Attribute_Address_Size
+ | Attribute_Atomic_Always_Lock_Free
+ | Attribute_Base
+ | Attribute_Class
+ | Attribute_Compiler_Version
+ | Attribute_Default_Bit_Order
+ | Attribute_Default_Scalar_Storage_Order
+ | Attribute_Delta
+ | Attribute_Denorm
+ | Attribute_Digits
+ | Attribute_Emax
+ | Attribute_Enabled
+ | Attribute_Epsilon
+ | Attribute_Fast_Math
+ | Attribute_First_Valid
+ | Attribute_Has_Access_Values
+ | Attribute_Has_Discriminants
+ | Attribute_Has_Tagged_Values
+ | Attribute_Large
+ | Attribute_Last_Valid
+ | Attribute_Library_Level
+ | Attribute_Lock_Free
+ | Attribute_Machine_Emax
+ | Attribute_Machine_Emin
+ | Attribute_Machine_Mantissa
+ | Attribute_Machine_Overflows
+ | Attribute_Machine_Radix
+ | Attribute_Machine_Rounds
+ | Attribute_Maximum_Alignment
+ | Attribute_Model_Emin
+ | Attribute_Model_Epsilon
+ | Attribute_Model_Mantissa
+ | Attribute_Model_Small
+ | Attribute_Modulus
+ | Attribute_Partition_ID
+ | Attribute_Range
+ | Attribute_Restriction_Set
+ | Attribute_Safe_Emax
+ | Attribute_Safe_First
+ | Attribute_Safe_Large
+ | Attribute_Safe_Last
+ | Attribute_Safe_Small
+ | Attribute_Scale
+ | Attribute_Signed_Zeros
+ | Attribute_Small
+ | Attribute_Storage_Unit
+ | Attribute_Stub_Type
+ | Attribute_System_Allocator_Alignment
+ | Attribute_Target_Name
+ | Attribute_Type_Class
+ | Attribute_Type_Key
+ | Attribute_Unconstrained_Array
+ | Attribute_Universal_Literal_String
+ | Attribute_Wchar_T_Size
+ | Attribute_Word_Size
+ =>
raise Program_Error;
-- The Asm_Input and Asm_Output attributes are not expanded at this
-- stage, but will be eliminated in the expansion of the Asm call, see
-- Exp_Intr for details. So the back end will never see these either.
- when Attribute_Asm_Input |
- Attribute_Asm_Output =>
+ when Attribute_Asm_Input
+ | Attribute_Asm_Output
+ =>
null;
end case;
@@ -7505,9 +7717,6 @@ package body Exp_Attr is
-- that appear in GNAT's library, but will generate calls via rtsfind
-- to library routines for user code.
- -- This is disabled for AAMP, to avoid creating dependences on files not
- -- supported in the AAMP library (such as s-fileio.adb).
-
-- Note: In the case of using a configurable run time, it is very likely
-- that stream routines for string types are not present (they require
-- file system support). In this case, the specific stream routines for
@@ -7515,10 +7724,7 @@ package body Exp_Attr is
-- instead. That is why we include the test Is_Available when dealing
-- with these cases.
- if not AAMP_On_Target
- and then
- not Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
- then
+ if not Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit)) then
-- Storage_Array as defined in package System.Storage_Elements
if Is_RTE (Base_Typ, RE_Storage_Array) then
@@ -7991,16 +8197,18 @@ package body Exp_Attr is
function Is_GCC_Target return Boolean is
begin
- return not CodePeer_Mode and then not AAMP_On_Target;
+ return not CodePeer_Mode
+ and then not AAMP_On_Target
+ and then not Modify_Tree_For_C;
end Is_GCC_Target;
- -- Start of processing for Exp_Attr
+ -- Start of processing for Is_Inline_Floating_Point_Attribute
begin
- -- Machine and Model can be expanded by the GCC backend only
+ -- Machine and Model can be expanded by the GCC and AAMP back ends only
if Id = Attribute_Machine or else Id = Attribute_Model then
- return Is_GCC_Target;
+ return Is_GCC_Target or else AAMP_On_Target;
-- Remaining cases handled by all back ends are Rounding and Truncation
-- when appearing as the operand of a conversion to some integer type.
diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb
index 89dd350ffb..8711c89d0e 100644
--- a/gcc/ada/exp_ch11.adb
+++ b/gcc/ada/exp_ch11.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -440,7 +440,6 @@ package body Exp_Ch11 is
-- expansion as described above.
procedure Expand_Local_Exception_Handlers is
-
procedure Add_Exception_Label (H : Node_Id);
-- H is an exception handler. First check for an Exception_Label
-- already allocated for H. If none, allocate one, set the field in
@@ -1172,11 +1171,8 @@ package body Exp_Ch11 is
-- end if;
procedure Expand_N_Exception_Declaration (N : Node_Id) is
- Id : constant Entity_Id := Defining_Identifier (N);
- Loc : constant Source_Ptr := Sloc (N);
- Ex_Id : Entity_Id;
- Flag_Id : Entity_Id;
- L : List_Id;
+ Id : constant Entity_Id := Defining_Identifier (N);
+ Loc : constant Source_Ptr := Sloc (N);
procedure Force_Static_Allocation_Of_Referenced_Objects
(Aggregate : Node_Id);
@@ -1206,6 +1202,9 @@ package body Exp_Ch11 is
-- references to other local (non-hoisted) objects (e.g., in the initial
-- value expression).
+ function Null_String return String_Id;
+ -- Build a null-terminated empty string
+
---------------------------------------------------
-- Force_Static_Allocation_Of_Referenced_Objects --
---------------------------------------------------
@@ -1249,12 +1248,30 @@ package body Exp_Ch11 is
Fixup_Tree (Aggregate);
end Force_Static_Allocation_Of_Referenced_Objects;
+ -----------------
+ -- Null_String --
+ -----------------
+
+ function Null_String return String_Id is
+ begin
+ Start_String;
+ Store_String_Char (Get_Char_Code (ASCII.NUL));
+ return End_String;
+ end Null_String;
+
+ -- Local variables
+
+ Ex_Id : Entity_Id;
+ Ex_Val : String_Id;
+ Flag_Id : Entity_Id;
+ L : List_Id;
+
-- Start of processing for Expand_N_Exception_Declaration
begin
-- Nothing to do when generating C code
- if Generate_C_Code then
+ if Modify_Tree_For_C then
return;
end if;
@@ -1263,14 +1280,25 @@ package body Exp_Ch11 is
Ex_Id :=
Make_Defining_Identifier (Loc, New_External_Name (Chars (Id), 'E'));
+ -- Do not generate an external name if the exception declaration is
+ -- subject to pragma Discard_Names. Use a null-terminated empty name
+ -- to ensure that Ada.Exceptions.Exception_Name functions properly.
+
+ if Global_Discard_Names or else Discard_Names (Ex_Id) then
+ Ex_Val := Null_String;
+
+ -- Otherwise generate the fully qualified name of the exception
+
+ else
+ Ex_Val := Fully_Qualified_Name_String (Id);
+ end if;
+
Insert_Action (N,
Make_Object_Declaration (Loc,
Defining_Identifier => Ex_Id,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (Standard_String, Loc),
- Expression =>
- Make_String_Literal (Loc,
- Strval => Fully_Qualified_Name_String (Id))));
+ Expression => Make_String_Literal (Loc, Ex_Val)));
Set_Is_Statically_Allocated (Ex_Id);
@@ -1565,13 +1593,15 @@ package body Exp_Ch11 is
if Prefix_Exception_Messages
and then Nkind (Expression (N)) = N_String_Literal
then
- Name_Len := 0;
- Add_Source_Info (Loc, Name_Enclosing_Entity);
- Add_Str_To_Name_Buffer (": ");
- Add_String_To_Name_Buffer (Strval (Expression (N)));
- Rewrite (Expression (N),
- Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len)));
- Analyze_And_Resolve (Expression (N), Standard_String);
+ declare
+ Buf : Bounded_String;
+ begin
+ Add_Source_Info (Buf, Loc, Name_Enclosing_Entity);
+ Append (Buf, ": ");
+ Append (Buf, Strval (Expression (N)));
+ Rewrite (Expression (N), Make_String_Literal (Loc, +Buf));
+ Analyze_And_Resolve (Expression (N), Standard_String);
+ end;
end if;
-- Avoid passing exception-name'identity in runtimes in which this
@@ -1658,10 +1688,10 @@ package body Exp_Ch11 is
if Present (Name (N)) then
declare
Id : Entity_Id := Entity (Name (N));
+ Buf : Bounded_String;
begin
- Name_Len := 0;
- Build_Location_String (Loc);
+ Build_Location_String (Buf, Loc);
-- If the exception is a renaming, use the exception that it
-- renames (which might be a predefined exception, e.g.).
@@ -1679,19 +1709,17 @@ package body Exp_Ch11 is
-- Suppress_Exception_Locations is set for this unit.
if Opt.Exception_Locations_Suppressed then
- Name_Len := 1;
- else
- Name_Len := Name_Len + 1;
+ Buf.Length := 0;
end if;
- Name_Buffer (Name_Len) := ASCII.NUL;
+ Append (Buf, ASCII.NUL);
end if;
if Opt.Exception_Locations_Suppressed then
- Name_Len := 0;
+ Buf.Length := 0;
end if;
- Str := String_From_Name_Buffer;
+ Str := String_From_Name_Buffer (Buf);
-- Convert raise to call to the Raise_Exception routine
diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb
index 11e75f37b8..0e0bbca440 100644
--- a/gcc/ada/exp_ch13.adb
+++ b/gcc/ada/exp_ch13.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -32,7 +32,6 @@ with Exp_Imgv; use Exp_Imgv;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
-with Ghost; use Ghost;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
@@ -114,7 +113,7 @@ package body Exp_Ch13 is
and then Present (Expression (Decl))
and then Nkind (Expression (Decl)) /= N_Null
and then
- not Comes_From_Source (Original_Node (Expression (Decl)))
+ not Comes_From_Source (Original_Node (Expression (Decl)))
then
if Present (Base_Init_Proc (Typ))
and then
@@ -123,8 +122,8 @@ package body Exp_Ch13 is
null;
elsif Init_Or_Norm_Scalars
- and then
- (Is_Scalar_Type (Typ) or else Is_String_Type (Typ))
+ and then (Is_Scalar_Type (Typ)
+ or else Is_String_Type (Typ))
then
null;
@@ -136,9 +135,16 @@ package body Exp_Ch13 is
-- has a delayed freeze, but the address expression itself
-- must be elaborated at the point it appears. If the object
-- is controlled, additional checks apply elsewhere.
+ -- If the attribute comes from an aspect specification it
+ -- is being elaborated at the freeze point and side effects
+ -- need not be removed (and shouldn't, if the expression
+ -- depends on other entities that have delayed freeze).
+ -- This is another consequence of the delayed analysis of
+ -- aspects, and a real semantic difference.
elsif Nkind (Decl) = N_Object_Declaration
and then not Needs_Constant_Address (Decl, Typ)
+ and then not From_Aspect_Specification (N)
then
Remove_Side_Effects (Exp);
end if;
@@ -154,8 +160,7 @@ package body Exp_Ch13 is
-- integer literal (this simplifies things in Gigi).
if Nkind (Exp) /= N_Integer_Literal then
- Rewrite
- (Exp, Make_Integer_Literal (Loc, Expr_Value (Exp)));
+ Rewrite (Exp, Make_Integer_Literal (Loc, Expr_Value (Exp)));
end if;
-- A complex case arises if the alignment clause applies to an
@@ -169,9 +174,10 @@ package body Exp_Ch13 is
and then not Is_Entity_Name (Renamed_Object (Ent))
then
declare
- Loc : constant Source_Ptr := Sloc (N);
- Decl : constant Node_Id := Parent (Ent);
- Temp : constant Entity_Id := Make_Temporary (Loc, 'T');
+ Decl : constant Node_Id := Parent (Ent);
+ Loc : constant Source_Ptr := Sloc (N);
+ Temp : constant Entity_Id := Make_Temporary (Loc, 'T');
+
New_Decl : Node_Id;
begin
@@ -220,7 +226,7 @@ package body Exp_Ch13 is
begin
Assign :=
Make_Assignment_Statement (Loc,
- Name =>
+ Name =>
New_Occurrence_Of (Storage_Size_Variable (Ent), Loc),
Expression =>
Convert_To (RTE (RE_Size_Type), Expression (N)));
@@ -260,9 +266,9 @@ package body Exp_Ch13 is
Insert_Action (N,
Make_Object_Declaration (Loc,
Defining_Identifier => V,
- Object_Definition =>
+ Object_Definition =>
New_Occurrence_Of (RTE (RE_Storage_Offset), Loc),
- Expression =>
+ Expression =>
Convert_To (RTE (RE_Storage_Offset), Expression (N))));
Set_Storage_Size_Variable (Ent, Entity_Id (V));
@@ -273,7 +279,6 @@ package body Exp_Ch13 is
when others =>
null;
-
end case;
end Expand_N_Attribute_Definition_Clause;
@@ -338,10 +343,8 @@ package body Exp_Ch13 is
Insert_Action (N,
Make_Object_Declaration (Loc,
Defining_Identifier => Temp_Id,
- Object_Definition =>
- New_Occurrence_Of (Expr_Typ, Loc),
- Expression =>
- Relocate_Node (Expr)));
+ Object_Definition => New_Occurrence_Of (Expr_Typ, Loc),
+ Expression => Relocate_Node (Expr)));
New_Expr := New_Occurrence_Of (Temp_Id, Loc);
Set_Etype (New_Expr, Expr_Typ);
@@ -364,8 +367,6 @@ package body Exp_Ch13 is
procedure Expand_N_Freeze_Entity (N : Node_Id) is
E : constant Entity_Id := Entity (N);
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
-
Decl : Node_Id;
Delete : Boolean := False;
E_Scope : Entity_Id;
@@ -373,10 +374,6 @@ package body Exp_Ch13 is
In_Outer_Scope : Boolean;
begin
- -- Ensure that all freezing activities are properly flagged as Ghost
-
- Set_Ghost_Mode_From_Entity (E);
-
-- If there are delayed aspect specifications, we insert them just
-- before the freeze node. They are already analyzed so we don't need
-- to reanalyze them (they were analyzed before the type was frozen),
@@ -444,14 +441,12 @@ package body Exp_Ch13 is
-- statement, insert them back into the tree now.
Explode_Initialization_Compound_Statement (E);
- Ghost_Mode := Save_Ghost_Mode;
return;
-- Only other items requiring any front end action are types and
-- subprograms.
elsif not Is_Type (E) and then not Is_Subprogram (E) then
- Ghost_Mode := Save_Ghost_Mode;
return;
end if;
@@ -463,7 +458,6 @@ package body Exp_Ch13 is
if No (E_Scope) then
Check_Error_Detected;
- Ghost_Mode := Save_Ghost_Mode;
return;
end if;
@@ -681,7 +675,6 @@ package body Exp_Ch13 is
-- whether we are inside a (possibly nested) call to this procedure.
Inside_Freezing_Actions := Inside_Freezing_Actions - 1;
- Ghost_Mode := Save_Ghost_Mode;
end Expand_N_Freeze_Entity;
-------------------------------------------
diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb
index 88dc82440a..65b2212ac4 100644
--- a/gcc/ada/exp_ch2.adb
+++ b/gcc/ada/exp_ch2.adb
@@ -413,7 +413,7 @@ package body Exp_Ch2 is
and then (Is_Atomic (E) or else Is_Atomic (Etype (E)))
then
declare
- Set : Boolean;
+ Set : Boolean;
begin
-- If variable is atomic, but type is not, setting depends on
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index af245ec637..788cf7f0da 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -34,7 +34,6 @@ with Exp_Ch4; use Exp_Ch4;
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch9; use Exp_Ch9;
-with Exp_Ch11; use Exp_Ch11;
with Exp_Dbug; use Exp_Dbug;
with Exp_Disp; use Exp_Disp;
with Exp_Dist; use Exp_Dist;
@@ -44,7 +43,6 @@ with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Ghost; use Ghost;
-with Inline; use Inline;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
@@ -59,7 +57,6 @@ with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch6; use Sem_Ch6;
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;
@@ -92,22 +89,6 @@ package body Exp_Ch3 is
-- used for attachment of any actions required in its construction.
-- It also supplies the source location used for the procedure.
- function Build_Array_Invariant_Proc
- (A_Type : Entity_Id;
- Nod : Node_Id) return Node_Id;
- -- If the component of type of array type has invariants, build procedure
- -- that checks invariant on all components of the array. Ada 2012 specifies
- -- that an invariant on some type T must be applied to in-out parameters
- -- and return values that include a part of type T. If the array type has
- -- an otherwise specified invariant, the component check procedure is
- -- called from within the user-specified invariant. Otherwise this becomes
- -- the invariant procedure for the array type.
-
- function Build_Record_Invariant_Proc
- (R_Type : Entity_Id;
- Nod : Node_Id) return Node_Id;
- -- Ditto for record types.
-
function Build_Discriminant_Formals
(Rec_Id : Entity_Id;
Use_Dl : Boolean) return List_Id;
@@ -200,14 +181,6 @@ package body Exp_Ch3 is
-- Treat user-defined stream operations as renaming_as_body if the
-- subprogram they rename is not frozen when the type is frozen.
- procedure Insert_Component_Invariant_Checks
- (N : Node_Id;
- Typ : Entity_Id;
- Proc : Node_Id);
- -- If a composite type has invariants and also has components with defined
- -- invariants. the component invariant procedure is inserted into the user-
- -- defined invariant procedure and added to the checks to be performed.
-
procedure Initialization_Warning (E : Entity_Id);
-- If static elaboration of the package is requested, indicate
-- when a type does meet the conditions for static initialization. If
@@ -226,6 +199,9 @@ package body Exp_Ch3 is
--
-- The caller must append additional entries for discriminants if required.
+ function Inline_Init_Proc (Typ : Entity_Id) return Boolean;
+ -- Returns true if the initialization procedure of Typ should be inlined
+
function In_Runtime (E : Entity_Id) return Boolean;
-- Check if E is defined in the RTL (in a child of Ada or System). Used
-- to avoid to bring in the overhead of _Input, _Output for tagged types.
@@ -756,14 +732,10 @@ package body Exp_Ch3 is
Set_Debug_Info_Off (Proc_Id);
end if;
- -- Set inlined unless tasks are around, in which case we do not
- -- want to inline, because nested stuff may cause difficulties in
- -- inter-unit inlining, and furthermore there is in any case no
- -- point in inlining such complex init procs.
+ -- Set Inlined on Init_Proc if it is set on the Init_Proc of the
+ -- component type itself (see also Build_Record_Init_Proc).
- if not Has_Task (Proc_Id) then
- Set_Is_Inlined (Proc_Id);
- end if;
+ Set_Is_Inlined (Proc_Id, Inline_Init_Proc (Comp_Type));
-- Associate Init_Proc with type, and determine if the procedure
-- is null (happens because of the Initialize_Scalars pragma case,
@@ -796,138 +768,6 @@ package body Exp_Ch3 is
end Build_Array_Init_Proc;
--------------------------------
- -- Build_Array_Invariant_Proc --
- --------------------------------
-
- function Build_Array_Invariant_Proc
- (A_Type : Entity_Id;
- Nod : Node_Id) return Node_Id
- is
- Loc : constant Source_Ptr := Sloc (Nod);
-
- Object_Name : constant Name_Id := New_Internal_Name ('I');
- -- Name for argument of invariant procedure
-
- Object_Entity : constant Node_Id :=
- Make_Defining_Identifier (Loc, Object_Name);
- -- The procedure declaration entity for the argument
-
- Body_Stmts : List_Id;
- Index_List : List_Id;
- Proc_Id : Entity_Id;
- Proc_Body : Node_Id;
-
- function Build_Component_Invariant_Call return Node_Id;
- -- Create one statement to verify invariant on one array component,
- -- designated by a full set of indexes.
-
- function Check_One_Dimension (N : Int) return List_Id;
- -- Create loop to check on one dimension of the array. The single
- -- statement in the loop body checks the inner dimensions if any, or
- -- else a single component. This procedure is called recursively, with
- -- N being the dimension to be initialized. A call with N greater than
- -- the number of dimensions generates the component initialization
- -- and terminates the recursion.
-
- ------------------------------------
- -- Build_Component_Invariant_Call --
- ------------------------------------
-
- function Build_Component_Invariant_Call return Node_Id is
- Comp : Node_Id;
- begin
- Comp :=
- Make_Indexed_Component (Loc,
- Prefix => New_Occurrence_Of (Object_Entity, Loc),
- Expressions => Index_List);
- return
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (Invariant_Procedure (Component_Type (A_Type)), Loc),
- Parameter_Associations => New_List (Comp));
- end Build_Component_Invariant_Call;
-
- -------------------------
- -- Check_One_Dimension --
- -------------------------
-
- function Check_One_Dimension (N : Int) return List_Id is
- Index : Entity_Id;
-
- begin
- -- If all dimensions dealt with, we simply check invariant of the
- -- component.
-
- if N > Number_Dimensions (A_Type) then
- return New_List (Build_Component_Invariant_Call);
-
- -- Else generate one loop and recurse
-
- else
- Index :=
- Make_Defining_Identifier (Loc, New_External_Name ('J', N));
-
- Append (New_Occurrence_Of (Index, Loc), Index_List);
-
- return New_List (
- Make_Implicit_Loop_Statement (Nod,
- Identifier => Empty,
- Iteration_Scheme =>
- Make_Iteration_Scheme (Loc,
- Loop_Parameter_Specification =>
- Make_Loop_Parameter_Specification (Loc,
- Defining_Identifier => Index,
- Discrete_Subtype_Definition =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Object_Entity, Loc),
- Attribute_Name => Name_Range,
- Expressions => New_List (
- Make_Integer_Literal (Loc, N))))),
- Statements => Check_One_Dimension (N + 1)));
- end if;
- end Check_One_Dimension;
-
- -- Start of processing for Build_Array_Invariant_Proc
-
- begin
- Index_List := New_List;
-
- Proc_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (A_Type), "CInvariant"));
-
- Body_Stmts := Check_One_Dimension (1);
-
- Proc_Body :=
- Make_Subprogram_Body (Loc,
- Specification =>
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Proc_Id,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Object_Entity,
- Parameter_Type => New_Occurrence_Of (A_Type, Loc)))),
-
- Declarations => Empty_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Body_Stmts));
-
- Set_Ekind (Proc_Id, E_Procedure);
- Set_Is_Public (Proc_Id, Is_Public (A_Type));
- Set_Is_Internal (Proc_Id);
- Set_Has_Completion (Proc_Id);
-
- if not Debug_Generated_Code then
- Set_Debug_Info_Off (Proc_Id);
- end if;
-
- return Proc_Body;
- end Build_Array_Invariant_Proc;
-
- --------------------------------
-- Build_Discr_Checking_Funcs --
--------------------------------
@@ -1446,7 +1286,118 @@ package body Exp_Ch3 is
With_Default_Init : Boolean := False;
Constructor_Ref : Node_Id := Empty) return List_Id
is
- Res : constant List_Id := New_List;
+ Res : constant List_Id := New_List;
+
+ Full_Type : Entity_Id;
+
+ procedure Check_Predicated_Discriminant
+ (Val : Node_Id;
+ Discr : Entity_Id);
+ -- Discriminants whose subtypes have predicates are checked in two
+ -- cases:
+ -- a) When an object is default-initialized and assertions are enabled
+ -- we check that the value of the discriminant obeys the predicate.
+
+ -- b) In all cases, if the discriminant controls a variant and the
+ -- variant has no others_choice, Constraint_Error must be raised if
+ -- the predicate is violated, because there is no variant covered
+ -- by the illegal discriminant value.
+
+ -----------------------------------
+ -- Check_Predicated_Discriminant --
+ -----------------------------------
+
+ procedure Check_Predicated_Discriminant
+ (Val : Node_Id;
+ Discr : Entity_Id)
+ is
+ Typ : constant Entity_Id := Etype (Discr);
+
+ procedure Check_Missing_Others (V : Node_Id);
+ -- ???
+
+ --------------------------
+ -- Check_Missing_Others --
+ --------------------------
+
+ procedure Check_Missing_Others (V : Node_Id) is
+ Alt : Node_Id;
+ Choice : Node_Id;
+ Last_Var : Node_Id;
+
+ begin
+ Last_Var := Last_Non_Pragma (Variants (V));
+ Choice := First (Discrete_Choices (Last_Var));
+
+ -- An others_choice is added during expansion for gcc use, but
+ -- does not cover the illegality.
+
+ if Entity (Name (V)) = Discr then
+ if Present (Choice)
+ and then (Nkind (Choice) /= N_Others_Choice
+ or else not Comes_From_Source (Choice))
+ then
+ Check_Expression_Against_Static_Predicate (Val, Typ);
+
+ if not Is_Static_Expression (Val) then
+ Prepend_To (Res,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Op_Not (Loc,
+ Right_Opnd => Make_Predicate_Call (Typ, Val)),
+ Reason => CE_Invalid_Data));
+ end if;
+ end if;
+ end if;
+
+ -- Check whether some nested variant is ruled by the predicated
+ -- discriminant.
+
+ Alt := First (Variants (V));
+ while Present (Alt) loop
+ if Nkind (Alt) = N_Variant
+ and then Present (Variant_Part (Component_List (Alt)))
+ then
+ Check_Missing_Others
+ (Variant_Part (Component_List (Alt)));
+ end if;
+
+ Next (Alt);
+ end loop;
+ end Check_Missing_Others;
+
+ -- Local variables
+
+ Def : Node_Id;
+
+ -- Start of processing for Check_Predicated_Discriminant
+
+ begin
+ if Ekind (Base_Type (Full_Type)) = E_Record_Type then
+ Def := Type_Definition (Parent (Base_Type (Full_Type)));
+ else
+ return;
+ end if;
+
+ if Policy_In_Effect (Name_Assert) = Name_Check
+ and then not Predicates_Ignored (Etype (Discr))
+ then
+ Prepend_To (Res, Make_Predicate_Check (Typ, Val));
+ end if;
+
+ -- If discriminant controls a variant, verify that predicate is
+ -- obeyed or else an Others_Choice is present.
+
+ if Nkind (Def) = N_Record_Definition
+ and then Present (Variant_Part (Component_List (Def)))
+ and then Policy_In_Effect (Name_Assert) = Name_Ignore
+ then
+ Check_Missing_Others (Variant_Part (Component_List (Def)));
+ end if;
+ end Check_Predicated_Discriminant;
+
+ -- Local variables
+
Arg : Node_Id;
Args : List_Id;
Decls : List_Id;
@@ -1454,10 +1405,12 @@ package body Exp_Ch3 is
Discr : Entity_Id;
First_Arg : Node_Id;
Full_Init_Type : Entity_Id;
- Full_Type : Entity_Id;
+ Init_Call : Node_Id;
Init_Type : Entity_Id;
Proc : Entity_Id;
+ -- Start of processing for Build_Initialization_Call
+
begin
pragma Assert (Constructor_Ref = Empty
or else Is_CPP_Constructor_Call (Constructor_Ref));
@@ -1645,9 +1598,15 @@ package body Exp_Ch3 is
-- The constraints come from the discriminant default exps,
-- they must be reevaluated, so we use New_Copy_Tree but we
-- ensure the proper Sloc (for any embedded calls).
+ -- In addition, if a predicate check is needed on the value
+ -- of the discriminant, insert it ahead of the call.
Arg := New_Copy_Tree (Arg, New_Sloc => Loc);
end if;
+
+ if Has_Predicates (Etype (Discr)) then
+ Check_Predicated_Discriminant (Arg, Discr);
+ end if;
end if;
-- Ada 2005 (AI-287): In case of default initialized components,
@@ -1665,7 +1624,7 @@ package body Exp_Ch3 is
then
Append_To (Args,
Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Prefix (Id_Ref)),
+ Prefix => New_Copy_Tree (Prefix (Id_Ref)),
Selector_Name => Arg));
else
Append_To (Args, Arg);
@@ -1692,17 +1651,24 @@ package body Exp_Ch3 is
Append_To (Res,
Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (Proc, Loc),
+ Name => New_Occurrence_Of (Proc, Loc),
Parameter_Associations => Args));
if Needs_Finalization (Typ)
and then Nkind (Id_Ref) = N_Selected_Component
then
if Chars (Selector_Name (Id_Ref)) /= Name_uParent then
- Append_To (Res,
+ Init_Call :=
Make_Init_Call
(Obj_Ref => New_Copy_Tree (First_Arg),
- Typ => Typ));
+ Typ => Typ);
+
+ -- Guard against a missing [Deep_]Initialize when the type was not
+ -- properly frozen.
+
+ if Present (Init_Call) then
+ Append_To (Res, Init_Call);
+ end if;
end if;
end if;
@@ -1721,7 +1687,7 @@ package body Exp_Ch3 is
Decls : constant List_Id := New_List;
Discr_Map : constant Elist_Id := New_Elmt_List;
Loc : constant Source_Ptr := Sloc (Rec_Ent);
- Counter : Int := 0;
+ Counter : Nat := 0;
Proc_Id : Entity_Id;
Rec_Type : Entity_Id;
Set_Tag : Entity_Id := Empty;
@@ -1801,10 +1767,12 @@ package body Exp_Ch3 is
function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id is
N_Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Underlying_Type (Etype (Id));
- Exp : Node_Id := N;
- Kind : Node_Kind := Nkind (N);
- Lhs : Node_Id;
- Res : List_Id;
+
+ Adj_Call : Node_Id;
+ Exp : Node_Id := N;
+ Kind : Node_Kind := Nkind (N);
+ Lhs : Node_Id;
+ Res : List_Id;
begin
Lhs :=
@@ -1884,10 +1852,29 @@ package body Exp_Ch3 is
and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate))
and then not Is_Limited_View (Typ)
then
- Append_To (Res,
+ Adj_Call :=
Make_Adjust_Call
(Obj_Ref => New_Copy_Tree (Lhs),
- Typ => Etype (Id)));
+ Typ => Etype (Id));
+
+ -- Guard against a missing [Deep_]Adjust when the component type
+ -- was not properly frozen.
+
+ if Present (Adj_Call) then
+ Append_To (Res, Adj_Call);
+ end if;
+ end if;
+
+ -- If a component type has a predicate, add check to the component
+ -- assignment. Discriminants are handled at the point of the call,
+ -- which provides for a better error message.
+
+ if Comes_From_Source (Exp)
+ and then Has_Predicates (Typ)
+ and then not Predicate_Checks_Suppressed (Empty)
+ and then not Predicates_Ignored (Typ)
+ then
+ Append (Make_Predicate_Check (Typ, Exp), Res);
end if;
return Res;
@@ -2868,15 +2855,16 @@ package body Exp_Ch3 is
Actions := Build_Assignment (Id, Expression (Decl));
end if;
- -- CPU, Dispatching_Domain, Priority and Size components are
- -- filled with the corresponding rep item expression of the
- -- concurrent type (if any).
+ -- CPU, Dispatching_Domain, Priority, and Secondary_Stack_Size
+ -- components are filled in with the corresponding rep-item
+ -- expression of the concurrent type (if any).
elsif Ekind (Scope (Id)) = E_Record_Type
and then Present (Corresponding_Concurrent_Type (Scope (Id)))
and then Nam_In (Chars (Id), Name_uCPU,
Name_uDispatching_Domain,
- Name_uPriority)
+ Name_uPriority,
+ Name_uSecondary_Stack_Size)
then
declare
Exp : Node_Id;
@@ -2892,6 +2880,9 @@ package body Exp_Ch3 is
elsif Chars (Id) = Name_uPriority then
Nam := Name_Priority;
+
+ elsif Chars (Id) = Name_uSecondary_Stack_Size then
+ Nam := Name_Secondary_Stack_Size;
end if;
-- Get the Rep Item (aspect specification, attribute
@@ -3314,7 +3305,6 @@ package body Exp_Ch3 is
-- Remaining processing depends on type
case Ekind (Subtype_Mark_Id) is
-
when Array_Kind =>
Constrain_Array (S, Check_List);
@@ -3336,7 +3326,7 @@ package body Exp_Ch3 is
Needs_Simple_Initialization (T)
and then not Is_RTE (T, RE_Tag)
- -- Ada 2005 (AI-251): Check also the tag of abstract interfaces
+ -- Ada 2005 (AI-251): Check also the tag of abstract interfaces
and then not Is_RTE (T, RE_Interface_Tag);
end Component_Needs_Simple_Initialization;
@@ -3592,19 +3582,8 @@ package body Exp_Ch3 is
Build_Offset_To_Top_Functions;
Build_CPP_Init_Procedure;
Build_Init_Procedure;
- Set_Is_Public (Proc_Id, Is_Public (Rec_Ent));
-
- -- The initialization of protected records is not worth inlining.
- -- In addition, when compiled for another unit for inlining purposes,
- -- it may make reference to entities that have not been elaborated
- -- yet. Similar considerations apply to task types.
-
- if not Is_Concurrent_Type (Rec_Type)
- and then not Has_Task (Rec_Type)
- then
- Set_Is_Inlined (Proc_Id);
- end if;
+ Set_Is_Public (Proc_Id, Is_Public (Rec_Ent));
Set_Is_Internal (Proc_Id);
Set_Has_Completion (Proc_Id);
@@ -3612,6 +3591,8 @@ package body Exp_Ch3 is
Set_Debug_Info_Off (Proc_Id);
end if;
+ Set_Is_Inlined (Proc_Id, Inline_Init_Proc (Rec_Type));
+
-- Do not build an aggregate if Modify_Tree_For_C, this isn't
-- needed and may generate early references to non frozen types
-- since we expand aggregate much more systematically.
@@ -3681,235 +3662,6 @@ package body Exp_Ch3 is
end if;
end Build_Record_Init_Proc;
- --------------------------------
- -- Build_Record_Invariant_Proc --
- --------------------------------
-
- function Build_Record_Invariant_Proc
- (R_Type : Entity_Id;
- Nod : Node_Id) return Node_Id
- is
- Loc : constant Source_Ptr := Sloc (Nod);
-
- Object_Name : constant Name_Id := New_Internal_Name ('I');
- -- Name for argument of invariant procedure
-
- Object_Entity : constant Node_Id :=
- Make_Defining_Identifier (Loc, Object_Name);
- -- The procedure declaration entity for the argument
-
- Invariant_Found : Boolean;
- -- Set if any component needs an invariant check.
-
- Proc_Id : Entity_Id;
- Proc_Body : Node_Id;
- Stmts : List_Id;
- Type_Def : Node_Id;
-
- function Build_Invariant_Checks (Comp_List : Node_Id) return List_Id;
- -- Recursive procedure that generates a list of checks for components
- -- that need it, and recurses through variant parts when present.
-
- function Build_Component_Invariant_Call (Comp : Entity_Id)
- return Node_Id;
- -- Build call to invariant procedure for a record component.
-
- ------------------------------------
- -- Build_Component_Invariant_Call --
- ------------------------------------
-
- function Build_Component_Invariant_Call (Comp : Entity_Id)
- return Node_Id
- is
- Sel_Comp : Node_Id;
- Typ : Entity_Id;
- Call : Node_Id;
-
- begin
- Invariant_Found := True;
- Typ := Etype (Comp);
-
- Sel_Comp :=
- Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Object_Entity, Loc),
- Selector_Name => New_Occurrence_Of (Comp, Loc));
-
- if Is_Access_Type (Typ) then
-
- -- If the access component designates a type with an invariant,
- -- the check applies to the designated object. The access type
- -- itself may have an invariant, in which case it applies to the
- -- access value directly.
-
- -- Note: we are assuming that invariants will not occur on both
- -- the access type and the type that it designates. This is not
- -- really justified but it is hard to imagine that this case will
- -- ever cause trouble ???
-
- if not (Has_Invariants (Typ)) then
- Sel_Comp := Make_Explicit_Dereference (Loc, Sel_Comp);
- Typ := Designated_Type (Typ);
- end if;
- end if;
-
- -- The aspect is type-specific, so retrieve it from the base type
-
- Call :=
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (Invariant_Procedure (Base_Type (Typ)), Loc),
- Parameter_Associations => New_List (Sel_Comp));
-
- if Is_Access_Type (Etype (Comp)) then
- Call :=
- Make_If_Statement (Loc,
- Condition =>
- Make_Op_Ne (Loc,
- Left_Opnd => Make_Null (Loc),
- Right_Opnd =>
- Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Object_Entity, Loc),
- Selector_Name => New_Occurrence_Of (Comp, Loc))),
- Then_Statements => New_List (Call));
- end if;
-
- return Call;
- end Build_Component_Invariant_Call;
-
- ----------------------------
- -- Build_Invariant_Checks --
- ----------------------------
-
- function Build_Invariant_Checks (Comp_List : Node_Id) return List_Id is
- Decl : Node_Id;
- Id : Entity_Id;
- Stmts : List_Id;
-
- begin
- Stmts := New_List;
- Decl := First_Non_Pragma (Component_Items (Comp_List));
- while Present (Decl) loop
- if Nkind (Decl) = N_Component_Declaration then
- Id := Defining_Identifier (Decl);
-
- if Has_Invariants (Etype (Id))
- and then In_Open_Scopes (Scope (R_Type))
- then
- if Has_Unchecked_Union (R_Type) then
- Error_Msg_NE
- ("invariants cannot be checked on components of "
- & "unchecked_union type&?", Decl, R_Type);
- return Empty_List;
-
- else
- Append_To (Stmts, Build_Component_Invariant_Call (Id));
- end if;
-
- elsif Is_Access_Type (Etype (Id))
- and then not Is_Access_Constant (Etype (Id))
- and then Has_Invariants (Designated_Type (Etype (Id)))
- and then In_Open_Scopes (Scope (Designated_Type (Etype (Id))))
- then
- Append_To (Stmts, Build_Component_Invariant_Call (Id));
- end if;
- end if;
-
- Next (Decl);
- end loop;
-
- if Present (Variant_Part (Comp_List)) then
- declare
- Variant_Alts : constant List_Id := New_List;
- Var_Loc : Source_Ptr;
- Variant : Node_Id;
- Variant_Stmts : List_Id;
-
- begin
- Variant :=
- First_Non_Pragma (Variants (Variant_Part (Comp_List)));
- while Present (Variant) loop
- Variant_Stmts :=
- Build_Invariant_Checks (Component_List (Variant));
- Var_Loc := Sloc (Variant);
- Append_To (Variant_Alts,
- Make_Case_Statement_Alternative (Var_Loc,
- Discrete_Choices =>
- New_Copy_List (Discrete_Choices (Variant)),
- Statements => Variant_Stmts));
-
- Next_Non_Pragma (Variant);
- end loop;
-
- -- The expression in the case statement is the reference to
- -- the discriminant of the target object.
-
- Append_To (Stmts,
- Make_Case_Statement (Var_Loc,
- Expression =>
- Make_Selected_Component (Var_Loc,
- Prefix => New_Occurrence_Of (Object_Entity, Var_Loc),
- Selector_Name => New_Occurrence_Of
- (Entity
- (Name (Variant_Part (Comp_List))), Var_Loc)),
- Alternatives => Variant_Alts));
- end;
- end if;
-
- return Stmts;
- end Build_Invariant_Checks;
-
- -- Start of processing for Build_Record_Invariant_Proc
-
- begin
- Invariant_Found := False;
- Type_Def := Type_Definition (Parent (R_Type));
-
- if Nkind (Type_Def) = N_Record_Definition
- and then not Null_Present (Type_Def)
- then
- Stmts := Build_Invariant_Checks (Component_List (Type_Def));
- else
- return Empty;
- end if;
-
- if not Invariant_Found then
- return Empty;
- end if;
-
- -- The name of the invariant procedure reflects the fact that the
- -- checks correspond to invariants on the component types. The
- -- record type itself may have invariants that will create a separate
- -- procedure whose name carries the Invariant suffix.
-
- Proc_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (R_Type), "CInvariant"));
-
- Proc_Body :=
- Make_Subprogram_Body (Loc,
- Specification =>
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Proc_Id,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Object_Entity,
- Parameter_Type => New_Occurrence_Of (R_Type, Loc)))),
-
- Declarations => Empty_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Stmts));
-
- Set_Ekind (Proc_Id, E_Procedure);
- Set_Is_Public (Proc_Id, Is_Public (R_Type));
- Set_Is_Internal (Proc_Id);
- Set_Has_Completion (Proc_Id);
-
- return Proc_Body;
- -- Insert_After (Nod, Proc_Body);
- -- Analyze (Proc_Body);
- end Build_Record_Invariant_Proc;
-
----------------------------
-- Build_Slice_Assignment --
----------------------------
@@ -3931,7 +3683,7 @@ package body Exp_Ch3 is
-- return;
-- end if;
- -- if Rev then
+ -- if Rev then
-- Li1 := Left_Hi;
-- Ri1 := Right_Hi;
-- else
@@ -4608,15 +4360,7 @@ package body Exp_Ch3 is
Base : constant Entity_Id := Base_Type (Typ);
Comp_Typ : constant Entity_Id := Component_Type (Typ);
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
-
- Ins_Node : Node_Id;
-
begin
- -- Ensure that all freezing activities are properly flagged as Ghost
-
- Set_Ghost_Mode_From_Entity (Typ);
-
if not Is_Bit_Packed_Array (Typ) then
-- If the component contains tasks, so does the array type. This may
@@ -4624,13 +4368,10 @@ package body Exp_Ch3 is
-- been a private type at the point of definition. Same if component
-- type is controlled or contains protected objects.
- Set_Has_Task (Base, Has_Task (Comp_Typ));
- Set_Has_Protected (Base, Has_Protected (Comp_Typ));
+ Propagate_Concurrent_Flags (Base, Comp_Typ);
Set_Has_Controlled_Component
- (Base, Has_Controlled_Component
- (Comp_Typ)
- or else
- Is_Controlled (Comp_Typ));
+ (Base, Has_Controlled_Component (Comp_Typ)
+ or else Is_Controlled (Comp_Typ));
if No (Init_Proc (Base)) then
@@ -4664,39 +4405,13 @@ package body Exp_Ch3 is
end if;
end if;
- if Typ = Base then
- if Has_Controlled_Component (Base) then
- Build_Controlling_Procs (Base);
-
- if not Is_Limited_Type (Comp_Typ)
- and then Number_Dimensions (Typ) = 1
- then
- Build_Slice_Assignment (Typ);
- end if;
- end if;
-
- -- Create a finalization master to service the anonymous access
- -- components of the array.
+ if Typ = Base and then Has_Controlled_Component (Base) then
+ Build_Controlling_Procs (Base);
- if Ekind (Comp_Typ) = E_Anonymous_Access_Type
- and then Needs_Finalization (Designated_Type (Comp_Typ))
+ if not Is_Limited_Type (Comp_Typ)
+ and then Number_Dimensions (Typ) = 1
then
- -- The finalization master is inserted before the declaration
- -- of the array type. The only exception to this is when the
- -- array type is an itype, in which case the master appears
- -- before the related context.
-
- if Is_Itype (Typ) then
- Ins_Node := Associated_Node_For_Itype (Typ);
- else
- Ins_Node := Parent (Typ);
- end if;
-
- Build_Finalization_Master
- (Typ => Comp_Typ,
- For_Anonymous => True,
- Context_Scope => Scope (Typ),
- Insertion_Node => Ins_Node);
+ Build_Slice_Assignment (Typ);
end if;
end if;
@@ -4713,23 +4428,6 @@ package body Exp_Ch3 is
then
Build_Array_Init_Proc (Base, N);
end if;
-
- if Has_Invariants (Component_Type (Base))
- and then Typ = Base
- and then In_Open_Scopes (Scope (Component_Type (Base)))
- then
- -- Generate component invariant checking procedure. This is only
- -- relevant if the array type is within the scope of the component
- -- type. Otherwise an array object can only be built using the public
- -- subprograms for the component type, and calls to those will have
- -- invariant checks. The invariant procedure is only generated for
- -- a base type, not a subtype.
-
- Insert_Component_Invariant_Checks
- (N, Base, Build_Array_Invariant_Proc (Base, N));
- end if;
-
- Ghost_Mode := Save_Ghost_Mode;
end Expand_Freeze_Array_Type;
-----------------------------------
@@ -4770,8 +4468,6 @@ package body Exp_Ch3 is
Typ : constant Entity_Id := Entity (N);
Root : constant Entity_Id := Root_Type (Typ);
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
-
-- Start of processing for Expand_Freeze_Class_Wide_Type
begin
@@ -4804,15 +4500,10 @@ package body Exp_Ch3 is
return;
end if;
- -- Ensure that all freezing activities are properly flagged as Ghost
-
- Set_Ghost_Mode_From_Entity (Typ);
-
-- Create the body of TSS primitive Finalize_Address. This automatically
-- sets the TSS entry for the class-wide type.
Make_Finalize_Address_Body (Typ);
- Ghost_Mode := Save_Ghost_Mode;
end Expand_Freeze_Class_Wide_Type;
------------------------------------
@@ -4823,8 +4514,6 @@ package body Exp_Ch3 is
Typ : constant Entity_Id := Entity (N);
Loc : constant Source_Ptr := Sloc (Typ);
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
-
Arr : Entity_Id;
Ent : Entity_Id;
Fent : Entity_Id;
@@ -4839,10 +4528,6 @@ package body Exp_Ch3 is
pragma Warnings (Off, Func);
begin
- -- Ensure that all freezing activities are properly flagged as Ghost
-
- Set_Ghost_Mode_From_Entity (Typ);
-
-- Various optimizations possible if given representation is contiguous
Is_Contiguous := True;
@@ -4905,7 +4590,7 @@ package body Exp_Ch3 is
Discrete_Subtype_Definitions => New_List (
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Occurrence_Of (Standard_Natural, Loc),
- Constraint =>
+ Constraint =>
Make_Range_Constraint (Loc,
Range_Expression =>
Make_Range (Loc,
@@ -5044,19 +4729,22 @@ package body Exp_Ch3 is
end loop;
end if;
- -- In normal mode, add the others clause with the test
+ -- In normal mode, add the others clause with the test.
+ -- If Predicates_Ignored is True, validity checks do not apply to
+ -- the subtype.
- if not No_Exception_Handlers_Set then
+ if not No_Exception_Handlers_Set
+ and then not Predicates_Ignored (Typ)
+ then
Append_To (Lst,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => New_List (Make_Others_Choice (Loc)),
- Statements => New_List (
+ Statements => New_List (
Make_Raise_Constraint_Error (Loc,
Condition => Make_Identifier (Loc, Name_uF),
Reason => CE_Invalid_Data),
Make_Simple_Return_Statement (Loc,
- Expression =>
- Make_Integer_Literal (Loc, -1)))));
+ Expression => Make_Integer_Literal (Loc, -1)))));
-- If either of the restrictions No_Exceptions_Handlers/Propagation is
-- active then return -1 (we cannot usefully raise Constraint_Error in
@@ -5066,10 +4754,9 @@ package body Exp_Ch3 is
Append_To (Lst,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => New_List (Make_Others_Choice (Loc)),
- Statements => New_List (
+ Statements => New_List (
Make_Simple_Return_Statement (Loc,
- Expression =>
- Make_Integer_Literal (Loc, -1)))));
+ Expression => Make_Integer_Literal (Loc, -1)))));
end if;
-- Now we can build the function body
@@ -5123,11 +4810,10 @@ package body Exp_Ch3 is
Set_Debug_Info_Off (Fent);
end if;
- Ghost_Mode := Save_Ghost_Mode;
+ Set_Is_Inlined (Fent);
exception
when RE_Not_Available =>
- Ghost_Mode := Save_Ghost_Mode;
return;
end Expand_Freeze_Enumeration_Type;
@@ -5139,13 +4825,13 @@ package body Exp_Ch3 is
Typ : constant Node_Id := Entity (N);
Typ_Decl : constant Node_Id := Parent (Typ);
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
-
Comp : Entity_Id;
Comp_Typ : Entity_Id;
- Has_AACC : Boolean;
Predef_List : List_Id;
+ Wrapper_Decl_List : List_Id := No_List;
+ Wrapper_Body_List : List_Id := No_List;
+
Renamed_Eq : Node_Id := Empty;
-- Defining unit name for the predefined equality function in the case
-- where the type has a primitive operation that is a renaming of
@@ -5153,16 +4839,9 @@ package body Exp_Ch3 is
-- user-defined equality function). Used to pass this entity from
-- Make_Predefined_Primitive_Specs to Predefined_Primitive_Bodies.
- Wrapper_Decl_List : List_Id := No_List;
- Wrapper_Body_List : List_Id := No_List;
-
-- Start of processing for Expand_Freeze_Record_Type
begin
- -- Ensure that all freezing activities are properly flagged as Ghost
-
- Set_Ghost_Mode_From_Entity (Typ);
-
-- Build discriminant checking functions if not a derived type (for
-- derived types that are not tagged types, always use the discriminant
-- checking functions of the parent type). However, for untagged types
@@ -5218,19 +4897,11 @@ package body Exp_Ch3 is
-- of the component types may have been private at the point of the
-- record declaration. Detect anonymous access-to-controlled components.
- Has_AACC := False;
-
Comp := First_Component (Typ);
while Present (Comp) loop
Comp_Typ := Etype (Comp);
- if Has_Task (Comp_Typ) then
- Set_Has_Task (Typ);
- end if;
-
- if Has_Protected (Comp_Typ) then
- Set_Has_Protected (Typ);
- end if;
+ Propagate_Concurrent_Flags (Typ, Comp_Typ);
-- Do not set Has_Controlled_Component on a class-wide equivalent
-- type. See Make_CW_Equivalent_Type.
@@ -5244,15 +4915,6 @@ package body Exp_Ch3 is
Set_Has_Controlled_Component (Typ);
end if;
- -- Non-self-referential anonymous access-to-controlled component
-
- if Ekind (Comp_Typ) = E_Anonymous_Access_Type
- and then Needs_Finalization (Designated_Type (Comp_Typ))
- and then Designated_Type (Comp_Typ) /= Typ
- then
- Has_AACC := True;
- end if;
-
Next_Component (Comp);
end loop;
@@ -5600,117 +5262,6 @@ package body Exp_Ch3 is
end loop;
end;
end if;
-
- -- Create a heterogeneous finalization master to service the anonymous
- -- access-to-controlled components of the record type.
-
- if Has_AACC then
- declare
- Encl_Scope : constant Entity_Id := Scope (Typ);
- Ins_Node : constant Node_Id := Parent (Typ);
- Loc : constant Source_Ptr := Sloc (Typ);
- Fin_Mas_Id : Entity_Id;
-
- Attributes_Set : Boolean := False;
- Master_Built : Boolean := False;
- -- Two flags which control the creation and initialization of a
- -- common heterogeneous master.
-
- begin
- Comp := First_Component (Typ);
- while Present (Comp) loop
- Comp_Typ := Etype (Comp);
-
- -- A non-self-referential anonymous access-to-controlled
- -- component.
-
- if Ekind (Comp_Typ) = E_Anonymous_Access_Type
- and then Needs_Finalization (Designated_Type (Comp_Typ))
- and then Designated_Type (Comp_Typ) /= Typ
- then
- -- Build a homogeneous master for the first anonymous
- -- access-to-controlled component. This master may be
- -- converted into a heterogeneous collection if more
- -- components are to follow.
-
- if not Master_Built then
- Master_Built := True;
-
- -- All anonymous access-to-controlled types allocate
- -- on the global pool. Note that the finalization
- -- master and the associated storage pool must be set
- -- on the root type (both are "root type only").
-
- Set_Associated_Storage_Pool
- (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object));
-
- Build_Finalization_Master
- (Typ => Root_Type (Comp_Typ),
- For_Anonymous => True,
- Context_Scope => Encl_Scope,
- Insertion_Node => Ins_Node);
-
- Fin_Mas_Id := Finalization_Master (Comp_Typ);
-
- -- Subsequent anonymous access-to-controlled components
- -- reuse the available master.
-
- else
- -- All anonymous access-to-controlled types allocate
- -- on the global pool. Note that both the finalization
- -- master and the associated storage pool must be set
- -- on the root type (both are "root type only").
-
- Set_Associated_Storage_Pool
- (Root_Type (Comp_Typ), RTE (RE_Global_Pool_Object));
-
- -- Shared the master among multiple components
-
- Set_Finalization_Master
- (Root_Type (Comp_Typ), Fin_Mas_Id);
-
- -- Convert the master into a heterogeneous collection.
- -- Generate:
- -- Set_Is_Heterogeneous (<Fin_Mas_Id>);
-
- if not Attributes_Set then
- Attributes_Set := True;
-
- Insert_Action (Ins_Node,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (RTE (RE_Set_Is_Heterogeneous), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (Fin_Mas_Id, Loc))));
- end if;
- end if;
- end if;
-
- Next_Component (Comp);
- end loop;
- end;
- end if;
-
- -- Check whether individual components have a defined invariant, and add
- -- the corresponding component invariant checks.
-
- -- Do not create an invariant procedure for some internally generated
- -- subtypes, in particular those created for objects of a class-wide
- -- type. Such types may have components to which invariant apply, but
- -- the corresponding checks will be applied when an object of the parent
- -- type is constructed.
-
- -- Such objects will show up in a class-wide postcondition, and the
- -- invariant will be checked, if necessary, upon return from the
- -- enclosing subprogram.
-
- if not Is_Class_Wide_Equivalent_Type (Typ) then
- Insert_Component_Invariant_Checks
- (N, Typ, Build_Record_Invariant_Proc (Typ, N));
- end if;
-
- Ghost_Mode := Save_Ghost_Mode;
end Expand_Freeze_Record_Type;
------------------------------------
@@ -5914,6 +5465,13 @@ package body Exp_Ch3 is
-- value, it may be possible to build an equivalent aggregate instead,
-- and prevent an actual call to the initialization procedure.
+ procedure Check_Large_Modular_Array;
+ -- Check that the size of the array can be computed without overflow,
+ -- and generate a Storage_Error otherwise. This is only relevant for
+ -- array types whose index in a (mod 2**64) type, where wrap-around
+ -- arithmetic might yield a meaningless value for the length of the
+ -- array, or its corresponding attribute.
+
procedure Default_Initialize_Object (After : Node_Id);
-- Generate all default initialization actions for object Def_Id. Any
-- new code is inserted after node After.
@@ -6052,6 +5610,61 @@ package body Exp_Ch3 is
end Build_Equivalent_Aggregate;
-------------------------------
+ -- Check_Large_Modular_Array --
+ -------------------------------
+
+ procedure Check_Large_Modular_Array is
+ Index_Typ : Entity_Id;
+
+ begin
+ if Is_Array_Type (Typ)
+ and then Is_Modular_Integer_Type (Etype (First_Index (Typ)))
+ then
+ -- To prevent arithmetic overflow with large values, we raise
+ -- Storage_Error under the following guard:
+
+ -- (Arr'Last / 2 - Arr'First / 2) > (2 ** 30)
+
+ -- This takes care of the boundary case, but it is preferable to
+ -- use a smaller limit, because even on 64-bit architectures an
+ -- array of more than 2 ** 30 bytes is likely to raise
+ -- Storage_Error.
+
+ Index_Typ := Etype (First_Index (Typ));
+
+ if RM_Size (Index_Typ) = RM_Size (Standard_Long_Long_Integer) then
+ Insert_Action (N,
+ Make_Raise_Storage_Error (Loc,
+ Condition =>
+ Make_Op_Ge (Loc,
+ Left_Opnd =>
+ Make_Op_Subtract (Loc,
+ Left_Opnd =>
+ Make_Op_Divide (Loc,
+ Left_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Typ, Loc),
+ Attribute_Name => Name_Last),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, Uint_2)),
+ Right_Opnd =>
+ Make_Op_Divide (Loc,
+ Left_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Typ, Loc),
+ Attribute_Name => Name_First),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, Uint_2))),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc, (Uint_2 ** 30))),
+ Reason => SE_Object_Too_Large));
+ end if;
+ end if;
+ end Check_Large_Modular_Array;
+
+ -------------------------------
-- Default_Initialize_Object --
-------------------------------
@@ -6086,16 +5699,12 @@ package body Exp_Ch3 is
Exceptions_OK : constant Boolean :=
not Restriction_Active (No_Exception_Propagation);
- Abrt_Blk : Node_Id;
- Abrt_Blk_Id : Entity_Id;
- Abrt_HSS : Node_Id;
- Aggr_Init : Node_Id;
- AUD : Entity_Id;
- Comp_Init : List_Id := No_List;
- Fin_Call : Node_Id;
- Init_Stmts : List_Id := No_List;
- Obj_Init : Node_Id := Empty;
- Obj_Ref : Node_Id;
+ Aggr_Init : Node_Id;
+ Comp_Init : List_Id := No_List;
+ Fin_Call : Node_Id;
+ Init_Stmts : List_Id := No_List;
+ Obj_Init : Node_Id := Empty;
+ Obj_Ref : Node_Id;
-- Start of processing for Default_Initialize_Object
@@ -6109,6 +5718,15 @@ package body Exp_Ch3 is
if Is_Imported (Def_Id) or else Suppress_Initialization (Def_Id) then
return;
+
+ -- Nothing to do if the object being initialized is of a task type
+ -- and restriction No_Tasking is in effect, because this is a direct
+ -- violation of the restriction.
+
+ elsif Is_Task_Type (Base_Typ)
+ and then Restriction_Active (No_Tasking)
+ then
+ return;
end if;
-- The expansion performed by this routine is as follows:
@@ -6293,26 +5911,10 @@ package body Exp_Ch3 is
-- end;
if Exceptions_OK then
- AUD := RTE (RE_Abort_Undefer_Direct);
-
- Abrt_HSS :=
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Init_Stmts,
- At_End_Proc => New_Occurrence_Of (AUD, Loc));
-
- Abrt_Blk :=
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence => Abrt_HSS);
-
- Add_Block_Identifier (Abrt_Blk, Abrt_Blk_Id);
- Expand_At_End_Handler (Abrt_HSS, Abrt_Blk_Id);
-
- -- Present the Abort_Undefer_Direct function to the backend so
- -- that it can inline the call to the function.
-
- Add_Inlined_Body (AUD, N);
-
- Init_Stmts := New_List (Abrt_Blk);
+ Init_Stmts := New_List (
+ Build_Abort_Undefer_Block (Loc,
+ Stmts => Init_Stmts,
+ Context => N));
-- Otherwise exceptions are not propagated. Generate:
@@ -6346,16 +5948,56 @@ package body Exp_Ch3 is
function Rewrite_As_Renaming return Boolean is
begin
- return not Aliased_Present (N)
- and then Is_Entity_Name (Expr_Q)
- and then Ekind (Entity (Expr_Q)) = E_Variable
- and then OK_To_Rename (Entity (Expr_Q))
- and then Is_Entity_Name (Obj_Def);
+ -- If the object declaration appears in the form
+
+ -- Obj : Ctrl_Typ := Func (...);
+
+ -- where Ctrl_Typ is controlled but not immutably limited type, then
+ -- the expansion of the function call should use a dereference of the
+ -- result to reference the value on the secondary stack.
+
+ -- Obj : Ctrl_Typ renames Func (...).all;
+
+ -- As a result, the call avoids an extra copy. This an optimization,
+ -- but it is required for passing ACATS tests in some cases where it
+ -- would otherwise make two copies. The RM allows removing redunant
+ -- Adjust/Finalize calls, but does not allow insertion of extra ones.
+
+ -- This part is disabled for now, because it breaks GPS builds
+
+ return (False -- ???
+ and then Nkind (Expr_Q) = N_Explicit_Dereference
+ and then not Comes_From_Source (Expr_Q)
+ and then Nkind (Original_Node (Expr_Q)) = N_Function_Call
+ and then Nkind (Object_Definition (N)) in N_Has_Entity
+ and then (Needs_Finalization (Entity (Object_Definition (N)))))
+
+ -- If the initializing expression is for a variable with attribute
+ -- OK_To_Rename set, then transform:
+
+ -- Obj : Typ := Expr;
+
+ -- into
+
+ -- Obj : Typ renames Expr;
+
+ -- provided that Obj is not aliased. The aliased case has to be
+ -- excluded in general because Expr will not be aliased in
+ -- general.
+
+ or else
+ (not Aliased_Present (N)
+ and then Is_Entity_Name (Expr_Q)
+ and then Ekind (Entity (Expr_Q)) = E_Variable
+ and then OK_To_Rename (Entity (Expr_Q))
+ and then Is_Entity_Name (Obj_Def));
end Rewrite_As_Renaming;
-- Local variables
- Next_N : constant Node_Id := Next (N);
+ Next_N : constant Node_Id := Next (N);
+
+ Adj_Call : Node_Id;
Id_Ref : Node_Id;
Tag_Assign : Node_Id;
@@ -6432,6 +6074,8 @@ package body Exp_Ch3 is
Build_Master_Entity (Def_Id);
end if;
+ Check_Large_Modular_Array;
+
-- Default initialization required, and no expression present
if No (Expr) then
@@ -6857,10 +6501,17 @@ package body Exp_Ch3 is
and then not Is_Limited_View (Typ)
and then not Rewrite_As_Renaming
then
- Insert_Action_After (Init_After,
+ Adj_Call :=
Make_Adjust_Call (
Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
- Typ => Base_Typ));
+ Typ => Base_Typ);
+
+ -- Guard against a missing [Deep_]Adjust when the base type
+ -- was not properly frozen.
+
+ if Present (Adj_Call) then
+ Insert_Action_After (Init_After, Adj_Call);
+ end if;
end if;
-- For tagged types, when an init value is given, the tag has to
@@ -6969,6 +6620,7 @@ package body Exp_Ch3 is
-- from previous instantiation errors.
if Validity_Checks_On
+ and then Comes_From_Source (N)
and then Validity_Check_Copies
and then not Is_Generic_Type (Etype (Def_Id))
then
@@ -7003,58 +6655,9 @@ package body Exp_Ch3 is
Insert_After_And_Analyze (Init_After, Stat);
end;
end if;
-
- -- Final transformation, if the initializing expression is an entity
- -- for a variable with OK_To_Rename set, then we transform:
-
- -- X : typ := expr;
-
- -- into
-
- -- X : typ renames expr
-
- -- provided that X is not aliased. The aliased case has to be
- -- excluded in general because Expr will not be aliased in general.
-
- if Rewrite_As_Renaming then
- Rewrite (N,
- Make_Object_Renaming_Declaration (Loc,
- Defining_Identifier => Defining_Identifier (N),
- Subtype_Mark => Obj_Def,
- Name => Expr_Q));
-
- -- We do not analyze this renaming declaration, because all its
- -- components have already been analyzed, and if we were to go
- -- ahead and analyze it, we would in effect be trying to generate
- -- another declaration of X, which won't do.
-
- Set_Renamed_Object (Defining_Identifier (N), Expr_Q);
- Set_Analyzed (N);
-
- -- We do need to deal with debug issues for this renaming
-
- -- First, if entity comes from source, then mark it as needing
- -- debug information, even though it is defined by a generated
- -- renaming that does not come from source.
-
- if Comes_From_Source (Defining_Identifier (N)) then
- Set_Debug_Info_Needed (Defining_Identifier (N));
- end if;
-
- -- Now call the routine to generate debug info for the renaming
-
- declare
- Decl : constant Node_Id := Debug_Renaming_Declaration (N);
- begin
- if Present (Decl) then
- Insert_Action (N, Decl);
- end if;
- end;
- end if;
end if;
- if Nkind (N) = N_Object_Declaration
- and then Nkind (Obj_Def) = N_Access_Definition
+ if Nkind (Obj_Def) = N_Access_Definition
and then not Is_Local_Anonymous_Access (Etype (Def_Id))
then
-- An Ada 2012 stand-alone object of an anonymous access type
@@ -7105,19 +6708,18 @@ package body Exp_Ch3 is
-- pragma Default_Initial_Condition, add a runtime check to verify
-- the assumption of the pragma (SPARK RM 7.3.3). Generate:
- -- <Base_Typ>Default_Init_Cond (<Base_Typ> (Def_Id));
+ -- <Base_Typ>DIC (<Base_Typ> (Def_Id));
-- Note that the check is generated for source objects only
if Comes_From_Source (Def_Id)
- and then (Has_Default_Init_Cond (Typ)
- or else
- Has_Inherited_Default_Init_Cond (Typ))
+ and then Has_DIC (Typ)
+ and then Present (DIC_Procedure (Typ))
and then not Has_Init_Expression (N)
then
declare
- DIC_Call : constant Node_Id :=
- Build_Default_Init_Cond_Call (Loc, Def_Id, Typ);
+ DIC_Call : constant Node_Id := Build_DIC_Call (Loc, Def_Id, Typ);
+
begin
if Present (Next_N) then
Insert_Before_And_Analyze (Next_N, DIC_Call);
@@ -7132,6 +6734,49 @@ package body Exp_Ch3 is
end;
end if;
+ -- Final transformation - turn the object declaration into a renaming
+ -- if appropriate. If this is the completion of a deferred constant
+ -- declaration, then this transformation generates what would be
+ -- illegal code if written by hand, but that's OK.
+
+ if Present (Expr) then
+ if Rewrite_As_Renaming then
+ Rewrite (N,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Defining_Identifier (N),
+ Subtype_Mark => Obj_Def,
+ Name => Expr_Q));
+
+ -- We do not analyze this renaming declaration, because all its
+ -- components have already been analyzed, and if we were to go
+ -- ahead and analyze it, we would in effect be trying to generate
+ -- another declaration of X, which won't do.
+
+ Set_Renamed_Object (Defining_Identifier (N), Expr_Q);
+ Set_Analyzed (N);
+
+ -- We do need to deal with debug issues for this renaming
+
+ -- First, if entity comes from source, then mark it as needing
+ -- debug information, even though it is defined by a generated
+ -- renaming that does not come from source.
+
+ if Comes_From_Source (Defining_Identifier (N)) then
+ Set_Debug_Info_Needed (Defining_Identifier (N));
+ end if;
+
+ -- Now call the routine to generate debug info for the renaming
+
+ declare
+ Decl : constant Node_Id := Debug_Renaming_Declaration (N);
+ begin
+ if Present (Decl) then
+ Insert_Action (N, Decl);
+ end if;
+ end;
+ end if;
+ end if;
+
-- Exception on library entity not available
exception
@@ -7440,6 +7085,10 @@ package body Exp_Ch3 is
-- for initialization) are chained in the Actions field list of the freeze
-- node using Append_Freeze_Actions.
+ -- WARNING: This routine manages Ghost regions. Return statements must be
+ -- replaced by gotos which jump to the end of the routine and restore the
+ -- Ghost mode.
+
function Freeze_Type (N : Node_Id) return Boolean is
procedure Process_RACW_Types (Typ : Entity_Id);
-- Validate and generate stubs for all RACW types associated with type
@@ -7532,9 +7181,10 @@ package body Exp_Ch3 is
-- Local variables
Def_Id : constant Entity_Id := Entity (N);
- Result : Boolean := False;
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
+ Mode : Ghost_Mode_Type;
+ Mode_Set : Boolean := False;
+ Result : Boolean := False;
-- Start of processing for Freeze_Type
@@ -7543,7 +7193,8 @@ package body Exp_Ch3 is
-- now to ensure that any nodes generated during freezing are properly
-- marked as Ghost.
- Set_Ghost_Mode (N, Def_Id);
+ Set_Ghost_Mode (Def_Id, Mode);
+ Mode_Set := True;
-- Process any remote access-to-class-wide types designating the type
-- being frozen.
@@ -7584,11 +7235,11 @@ package body Exp_Ch3 is
elsif Ekind_In (Def_Id, E_Access_Type, E_General_Access_Type) then
declare
- Loc : constant Source_Ptr := Sloc (N);
- Desig_Type : constant Entity_Id := Designated_Type (Def_Id);
- Pool_Object : Entity_Id;
+ Loc : constant Source_Ptr := Sloc (N);
+ Desig_Type : constant Entity_Id := Designated_Type (Def_Id);
Freeze_Action_Typ : Entity_Id;
+ Pool_Object : Entity_Id;
begin
-- Case 1
@@ -7608,8 +7259,8 @@ package body Exp_Ch3 is
elsif Has_Storage_Size_Clause (Def_Id) then
declare
- DT_Size : Node_Id;
DT_Align : Node_Id;
+ DT_Size : Node_Id;
begin
-- For unconstrained composite types we give a size of zero
@@ -7854,12 +7505,35 @@ package body Exp_Ch3 is
Process_Pending_Access_Types (Def_Id);
Freeze_Stream_Operations (N, Def_Id);
- Ghost_Mode := Save_Ghost_Mode;
+ -- Generate the [spec and] body of the procedure tasked with the runtime
+ -- verification of pragma Default_Initial_Condition's expression.
+
+ if Has_DIC (Def_Id) then
+ Build_DIC_Procedure_Body (Def_Id);
+ end if;
+
+ -- Generate the [spec and] body of the invariant procedure tasked with
+ -- the runtime verification of all invariants that pertain to the type.
+ -- This includes invariants on the partial and full view, inherited
+ -- class-wide invariants from parent types or interfaces, and invariants
+ -- on array elements or record components.
+
+ if Has_Invariants (Def_Id) then
+ Build_Invariant_Procedure_Body (Def_Id);
+ end if;
+
+ if Mode_Set then
+ Restore_Ghost_Mode (Mode);
+ end if;
+
return Result;
exception
when RE_Not_Available =>
- Ghost_Mode := Save_Ghost_Mode;
+ if Mode_Set then
+ Restore_Ghost_Mode (Mode);
+ end if;
+
return False;
end Freeze_Type;
@@ -8228,6 +7902,34 @@ package body Exp_Ch3 is
end if;
end Has_New_Non_Standard_Rep;
+ ----------------------
+ -- Inline_Init_Proc --
+ ----------------------
+
+ function Inline_Init_Proc (Typ : Entity_Id) return Boolean is
+ begin
+ -- The initialization proc of protected records is not worth inlining.
+ -- In addition, when compiled for another unit for inlining purposes,
+ -- it may make reference to entities that have not been elaborated yet.
+ -- The initialization proc of records that need finalization contains
+ -- a nested clean-up procedure that makes it impractical to inline as
+ -- well, except for simple controlled types themselves. And similar
+ -- considerations apply to task types.
+
+ if Is_Concurrent_Type (Typ) then
+ return False;
+
+ elsif Needs_Finalization (Typ) and then not Is_Controlled (Typ) then
+ return False;
+
+ elsif Has_Task (Typ) then
+ return False;
+
+ else
+ return True;
+ end if;
+ end Inline_Init_Proc;
+
----------------
-- In_Runtime --
----------------
@@ -8244,77 +7946,6 @@ package body Exp_Ch3 is
return Is_RTU (S1, System) or else Is_RTU (S1, Ada);
end In_Runtime;
- ---------------------------------------
- -- Insert_Component_Invariant_Checks --
- ---------------------------------------
-
- procedure Insert_Component_Invariant_Checks
- (N : Node_Id;
- Typ : Entity_Id;
- Proc : Node_Id)
- is
- Loc : constant Source_Ptr := Sloc (Typ);
- Proc_Id : Entity_Id;
-
- begin
- if Present (Proc) then
- Proc_Id := Defining_Entity (Proc);
-
- if not Has_Invariants (Typ) then
- Set_Has_Invariants (Typ);
- Set_Is_Invariant_Procedure (Proc_Id);
- Set_Invariant_Procedure (Typ, Proc_Id);
- Insert_After (N, Proc);
- Analyze (Proc);
-
- else
-
- -- Find already created invariant subprogram, insert body of
- -- component invariant proc in its body, and add call after
- -- other checks.
-
- declare
- Bod : Node_Id;
- Inv_Id : constant Entity_Id := Invariant_Procedure (Typ);
- Call : constant Node_Id :=
- Make_Procedure_Call_Statement (Sloc (N),
- Name => New_Occurrence_Of (Proc_Id, Loc),
- Parameter_Associations =>
- New_List
- (New_Occurrence_Of (First_Formal (Inv_Id), Loc)));
-
- begin
- -- The invariant body has not been analyzed yet, so we do a
- -- sequential search forward, and retrieve it by name.
-
- Bod := Next (N);
- while Present (Bod) loop
- exit when Nkind (Bod) = N_Subprogram_Body
- and then Chars (Defining_Entity (Bod)) = Chars (Inv_Id);
- Next (Bod);
- end loop;
-
- -- If the body is not found, it is the case of an invariant
- -- appearing on a full declaration in a private part, in
- -- which case the type has been frozen but the invariant
- -- procedure for the composite type not created yet. Create
- -- body now.
-
- if No (Bod) then
- Build_Invariant_Procedure (Typ, Parent (Current_Scope));
- Bod := Unit_Declaration_Node
- (Corresponding_Body (Unit_Declaration_Node (Inv_Id)));
- end if;
-
- Append_To (Declarations (Bod), Proc);
- Append_To (Statements (Handled_Statement_Sequence (Bod)), Call);
- Analyze (Proc);
- Analyze (Call);
- end;
- end if;
- end if;
- end Insert_Component_Invariant_Checks;
-
----------------------------
-- Initialization_Warning --
----------------------------
@@ -9590,11 +9221,13 @@ package body Exp_Ch3 is
exit;
-- If the parent is not an interface type and has an abstract
- -- equality function, the inherited equality is abstract as
- -- well, and no body can be created for it.
+ -- equality function explicitly defined in the sources, then
+ -- the inherited equality is abstract as well, and no body can
+ -- be created for it.
elsif not Is_Interface (Etype (Tag_Typ))
and then Present (Alias (Node (Prim)))
+ and then Comes_From_Source (Alias (Node (Prim)))
and then Is_Abstract_Subprogram (Alias (Node (Prim)))
then
Eq_Needed := False;
@@ -10085,7 +9718,9 @@ package body Exp_Ch3 is
is
Loc : constant Source_Ptr := Sloc (Tag_Typ);
Res : constant List_Id := New_List;
+ Adj_Call : Node_Id;
Decl : Node_Id;
+ Fin_Call : Node_Id;
Prim : Elmt_Id;
Eq_Needed : Boolean;
Eq_Name : Name_Id;
@@ -10311,42 +9946,45 @@ package body Exp_Ch3 is
elsif not Has_Controlled_Component (Tag_Typ) then
if not Is_Limited_Type (Tag_Typ) then
- Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust, True);
+ Adj_Call := Empty;
+ Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust, True);
if Is_Controlled (Tag_Typ) then
- Set_Handled_Statement_Sequence (Decl,
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Adjust_Call (
- Obj_Ref => Make_Identifier (Loc, Name_V),
- Typ => Tag_Typ))));
+ Adj_Call :=
+ Make_Adjust_Call (
+ Obj_Ref => Make_Identifier (Loc, Name_V),
+ Typ => Tag_Typ);
+ end if;
- else
- Set_Handled_Statement_Sequence (Decl,
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Null_Statement (Loc))));
+ if No (Adj_Call) then
+ Adj_Call := Make_Null_Statement (Loc);
end if;
+ Set_Handled_Statement_Sequence (Decl,
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Adj_Call)));
+
Append_To (Res, Decl);
end if;
- Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize, True);
+ Fin_Call := Empty;
+ Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize, True);
if Is_Controlled (Tag_Typ) then
- Set_Handled_Statement_Sequence (Decl,
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Final_Call
- (Obj_Ref => Make_Identifier (Loc, Name_V),
- Typ => Tag_Typ))));
+ Fin_Call :=
+ Make_Final_Call
+ (Obj_Ref => Make_Identifier (Loc, Name_V),
+ Typ => Tag_Typ);
+ end if;
- else
- Set_Handled_Statement_Sequence (Decl,
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Make_Null_Statement (Loc))));
+ if No (Fin_Call) then
+ Fin_Call := Make_Null_Statement (Loc);
end if;
+ Set_Handled_Statement_Sequence (Decl,
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Fin_Call)));
+
Append_To (Res, Decl);
end if;
diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads
index 3f2db942e5..e42fc821f3 100644
--- a/gcc/ada/exp_ch3.ads
+++ b/gcc/ada/exp_ch3.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -119,7 +119,7 @@ package Exp_Ch3 is
-- initialization routine:
-- Access types (which need initializing to null)
-- All scalar types if Normalize_Scalars mode set
- -- Descendents of standard string types if Normalize_Scalars mode set
+ -- Descendants of standard string types if Normalize_Scalars mode set
-- Scalar types having a Default_Value attribute
-- Regarding Initialize_Scalars mode, this is ignored if Consider_IS is
-- set to False, but if Consider_IS is set to True, then the cases above
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index eff75c25ab..385456764e 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -44,7 +44,6 @@ with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Inline; use Inline;
-with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
@@ -57,7 +56,6 @@ with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
-with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
@@ -92,12 +90,6 @@ package body Exp_Ch4 is
-- If a boolean array assignment can be done in place, build call to
-- corresponding library procedure.
- function Current_Anonymous_Master return Entity_Id;
- -- Return the entity of the heterogeneous finalization master belonging to
- -- the current unit (either function, package or procedure). This master
- -- services all anonymous access-to-controlled types. If the current unit
- -- does not have such master, create one.
-
procedure Displace_Allocator_Pointer (N : Node_Id);
-- Ada 2005 (AI-251): Subsidiary procedure to Expand_N_Allocator and
-- Expand_Allocator_Expression. Allocating class-wide interface objects
@@ -232,15 +224,23 @@ package body Exp_Ch4 is
-- simple entity, and op is a comparison operator, optimizes it into a
-- comparison of First and Last.
- procedure Process_Transient_Object
- (Decl : Node_Id;
- Rel_Node : Node_Id);
- -- Subsidiary routine to the expansion of expression_with_actions and if
- -- expressions. Generate all the necessary code to finalize a transient
- -- controlled object when the enclosing context is elaborated or evaluated.
- -- Decl denotes the declaration of the transient controlled object which is
- -- usually the result of a controlled function call. Rel_Node denotes the
- -- context, either an expression_with_actions or an if expression.
+ procedure Process_If_Case_Statements (N : Node_Id; Stmts : List_Id);
+ -- Inspect and process statement list Stmt of if or case expression N for
+ -- transient objects. If such objects are found, the routine generates code
+ -- to clean them up when the context of the expression is evaluated.
+
+ procedure Process_Transient_In_Expression
+ (Obj_Decl : Node_Id;
+ Expr : Node_Id;
+ Stmts : List_Id);
+ -- Subsidiary routine to the expansion of expression_with_actions, if and
+ -- case expressions. Generate all necessary code to finalize a transient
+ -- object when the enclosing context is elaborated or evaluated. Obj_Decl
+ -- denotes the declaration of the transient object, which is usually the
+ -- result of a controlled function call. Expr denotes the expression with
+ -- actions, if expression, or case expression node. Stmts denotes the
+ -- statement list which contains Decl, either at the top level or within a
+ -- nested construct.
procedure Rewrite_Comparison (N : Node_Id);
-- If N is the node for a comparison whose outcome can be determined at
@@ -410,202 +410,6 @@ package body Exp_Ch4 is
return;
end Build_Boolean_Array_Proc_Call;
- ------------------------------
- -- Current_Anonymous_Master --
- ------------------------------
-
- function Current_Anonymous_Master return Entity_Id is
- function Create_Anonymous_Master
- (Unit_Id : Entity_Id;
- Unit_Decl : Node_Id) return Entity_Id;
- -- Create a new anonymous master for a compilation unit denoted by its
- -- entity Unit_Id and declaration Unit_Decl. The declaration of the new
- -- master along with any specialized initialization is inserted at the
- -- top of the unit's declarations (see body for special cases). Return
- -- the entity of the anonymous master.
-
- -----------------------------
- -- Create_Anonymous_Master --
- -----------------------------
-
- function Create_Anonymous_Master
- (Unit_Id : Entity_Id;
- Unit_Decl : Node_Id) return Entity_Id
- is
- Insert_Nod : Node_Id := Empty;
- -- The point of insertion into the declarative list of the unit. All
- -- nodes are inserted before Insert_Nod.
-
- procedure Insert_And_Analyze (Decls : List_Id; N : Node_Id);
- -- Insert arbitrary node N in declarative list Decls and analyze it
-
- ------------------------
- -- Insert_And_Analyze --
- ------------------------
-
- procedure Insert_And_Analyze (Decls : List_Id; N : Node_Id) is
- begin
- -- The declarative list is already populated, the nodes are
- -- inserted at the top of the list, preserving their order.
-
- if Present (Insert_Nod) then
- Insert_Before (Insert_Nod, N);
-
- -- Otherwise append to the declarations to preserve order
-
- else
- Append_To (Decls, N);
- end if;
-
- Analyze (N);
- end Insert_And_Analyze;
-
- -- Local variables
-
- Loc : constant Source_Ptr := Sloc (Unit_Id);
- Spec_Id : constant Entity_Id := Unique_Defining_Entity (Unit_Decl);
- Decls : List_Id;
- FM_Id : Entity_Id;
- Pref : Character;
- Unit_Spec : Node_Id;
-
- -- Start of processing for Create_Anonymous_Master
-
- begin
- -- Find the declarative list of the unit
-
- if Nkind (Unit_Decl) = N_Package_Declaration then
- Unit_Spec := Specification (Unit_Decl);
- Decls := Visible_Declarations (Unit_Spec);
-
- if No (Decls) then
- Decls := New_List (Make_Null_Statement (Loc));
- Set_Visible_Declarations (Unit_Spec, Decls);
- end if;
-
- -- Package or subprogram body
-
- -- ??? A subprogram declaration that acts as a compilation unit may
- -- contain a formal parameter of an anonymous access-to-controlled
- -- type initialized by an allocator.
-
- -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl);
-
- -- There is no suitable place to create the anonymous master as the
- -- subprogram is not in a declarative list.
-
- else
- Decls := Declarations (Unit_Decl);
-
- if No (Decls) then
- Decls := New_List (Make_Null_Statement (Loc));
- Set_Declarations (Unit_Decl, Decls);
- end if;
- end if;
-
- -- The anonymous master and all initialization actions are inserted
- -- before the first declaration (if any).
-
- Insert_Nod := First (Decls);
-
- -- Since the anonymous master and all its initialization actions are
- -- inserted at top level, use the scope of the unit when analyzing.
-
- Push_Scope (Spec_Id);
-
- -- Step 1: Anonymous master creation
-
- -- Use a unique prefix in case the same unit requires two anonymous
- -- masters, one for the spec (S) and one for the body (B).
-
- if Ekind_In (Unit_Id, E_Function, E_Package, E_Procedure) then
- Pref := 'S';
- else
- Pref := 'B';
- end if;
-
- FM_Id :=
- Make_Defining_Identifier (Loc,
- New_External_Name
- (Related_Id => Chars (Unit_Id),
- Suffix => "AM",
- Prefix => Pref));
-
- Set_Anonymous_Master (Unit_Id, FM_Id);
-
- -- Generate:
- -- <FM_Id> : Finalization_Master;
-
- Insert_And_Analyze (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => FM_Id,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Finalization_Master), Loc)));
-
- -- Step 2: Initialization actions
-
- -- Generate:
- -- Set_Base_Pool
- -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access);
-
- Insert_And_Analyze (Decls,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (FM_Id, Loc),
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc),
- Attribute_Name => Name_Unrestricted_Access))));
-
- -- Generate:
- -- Set_Is_Heterogeneous (<FM_Id>);
-
- Insert_And_Analyze (Decls,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Set_Is_Heterogeneous), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (FM_Id, Loc))));
-
- Pop_Scope;
- return FM_Id;
- end Create_Anonymous_Master;
-
- -- Local declarations
-
- Unit_Decl : Node_Id;
- Unit_Id : Entity_Id;
-
- -- Start of processing for Current_Anonymous_Master
-
- begin
- Unit_Decl := Unit (Cunit (Current_Sem_Unit));
- Unit_Id := Defining_Entity (Unit_Decl);
-
- -- The compilation unit is a package instantiation. In this case the
- -- anonymous master is associated with the package spec as both the
- -- spec and body appear at the same level.
-
- if Nkind (Unit_Decl) = N_Package_Body
- and then Nkind (Original_Node (Unit_Decl)) = N_Package_Instantiation
- then
- Unit_Id := Corresponding_Spec (Unit_Decl);
- Unit_Decl := Unit_Declaration_Node (Unit_Id);
- end if;
-
- if Present (Anonymous_Master (Unit_Id)) then
- return Anonymous_Master (Unit_Id);
-
- -- Create a new anonymous master when allocating an object of anonymous
- -- access-to-controlled type for the first time.
-
- else
- return Create_Anonymous_Master (Unit_Id, Unit_Decl);
- end if;
- end Current_Anonymous_Master;
-
--------------------------------
-- Displace_Allocator_Pointer --
--------------------------------
@@ -828,6 +632,13 @@ package body Exp_Ch4 is
Make_Explicit_Dereference (Loc, New_Copy (Obj_Ref)),
Typ => DesigT);
+ -- Guard against a missing [Deep_]Finalize when the designated
+ -- type was not properly frozen.
+
+ if No (Fin_Call) then
+ Fin_Call := Make_Null_Statement (Loc);
+ end if;
+
-- When the target or profile supports deallocation, wrap the
-- finalization call in a block to ensure proper deallocation
-- even if finalization fails. Generate:
@@ -918,6 +729,7 @@ package body Exp_Ch4 is
Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp);
Indic : constant Node_Id := Subtype_Mark (Expression (N));
T : constant Entity_Id := Entity (Indic);
+ Adj_Call : Node_Id;
Node : Node_Id;
Tag_Assign : Node_Id;
Temp : Entity_Id;
@@ -1182,8 +994,6 @@ package body Exp_Ch4 is
end;
end if;
- Apply_Accessibility_Check (Temp);
-
-- Generate the tag assignment
-- Suppress the tag assignment for VM targets because VM tags are
@@ -1241,35 +1051,41 @@ package body Exp_Ch4 is
Insert_Action (N, Tag_Assign);
end if;
- if Needs_Finalization (DesigT) and then Needs_Finalization (T) then
-
- -- Generate an Adjust call if the object will be moved. In Ada
- -- 2005, the object may be inherently limited, in which case
- -- there is no Adjust procedure, and the object is built in
- -- place. In Ada 95, the object can be limited but not
- -- inherently limited if this allocator came from a return
- -- statement (we're allocating the result on the secondary
- -- stack). In that case, the object will be moved, so we _do_
- -- want to Adjust.
-
- if not Aggr_In_Place
- and then not Is_Limited_View (T)
- then
- Insert_Action (N,
+ -- Generate an Adjust call if the object will be moved. In Ada 2005,
+ -- the object may be inherently limited, in which case there is no
+ -- Adjust procedure, and the object is built in place. In Ada 95, the
+ -- object can be limited but not inherently limited if this allocator
+ -- came from a return statement (we're allocating the result on the
+ -- secondary stack). In that case, the object will be moved, so we do
+ -- want to Adjust.
- -- An unchecked conversion is needed in the classwide case
- -- because the designated type can be an ancestor of the
- -- subtype mark of the allocator.
-
- Make_Adjust_Call
- (Obj_Ref =>
- Unchecked_Convert_To (T,
- Make_Explicit_Dereference (Loc,
- Prefix => New_Occurrence_Of (Temp, Loc))),
- Typ => T));
+ if Needs_Finalization (DesigT)
+ and then Needs_Finalization (T)
+ and then not Aggr_In_Place
+ and then not Is_Limited_View (T)
+ then
+ -- An unchecked conversion is needed in the classwide case because
+ -- the designated type can be an ancestor of the subtype mark of
+ -- the allocator.
+
+ Adj_Call :=
+ Make_Adjust_Call
+ (Obj_Ref =>
+ Unchecked_Convert_To (T,
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Temp, Loc))),
+ Typ => T);
+
+ if Present (Adj_Call) then
+ Insert_Action (N, Adj_Call);
end if;
end if;
+ -- Note: the accessibility check must be inserted after the call to
+ -- [Deep_]Adjust to ensure proper completion of the assignment.
+
+ Apply_Accessibility_Check (Temp);
+
Rewrite (N, New_Occurrence_Of (Temp, Loc));
Analyze_And_Resolve (N, PtrT);
@@ -1281,7 +1097,12 @@ package body Exp_Ch4 is
Displace_Allocator_Pointer (N);
end if;
- elsif Aggr_In_Place then
+ -- Always force the generation of a temporary for aggregates when
+ -- generating C code, to simplify the work in the code generator.
+
+ elsif Aggr_In_Place
+ or else (Modify_Tree_For_C and then Nkind (Exp) = N_Aggregate)
+ then
Temp := Make_Temporary (Loc, 'P', N);
Temp_Decl :=
Make_Object_Declaration (Loc,
@@ -2319,47 +2140,47 @@ package body Exp_Ch4 is
if Llo /= No_Uint and then Rlo /= No_Uint then
case N_Op_Compare (Nkind (N)) is
- when N_Op_Eq =>
- if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then
- Set_True;
- elsif Llo > Rhi or else Lhi < Rlo then
- Set_False;
- end if;
+ when N_Op_Eq =>
+ if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then
+ Set_True;
+ elsif Llo > Rhi or else Lhi < Rlo then
+ Set_False;
+ end if;
- when N_Op_Ge =>
- if Llo >= Rhi then
- Set_True;
- elsif Lhi < Rlo then
- Set_False;
- end if;
+ when N_Op_Ge =>
+ if Llo >= Rhi then
+ Set_True;
+ elsif Lhi < Rlo then
+ Set_False;
+ end if;
- when N_Op_Gt =>
- if Llo > Rhi then
- Set_True;
- elsif Lhi <= Rlo then
- Set_False;
- end if;
+ when N_Op_Gt =>
+ if Llo > Rhi then
+ Set_True;
+ elsif Lhi <= Rlo then
+ Set_False;
+ end if;
- when N_Op_Le =>
- if Llo > Rhi then
- Set_False;
- elsif Lhi <= Rlo then
- Set_True;
- end if;
+ when N_Op_Le =>
+ if Llo > Rhi then
+ Set_False;
+ elsif Lhi <= Rlo then
+ Set_True;
+ end if;
- when N_Op_Lt =>
- if Llo >= Rhi then
- Set_False;
- elsif Lhi < Rlo then
- Set_True;
- end if;
+ when N_Op_Lt =>
+ if Llo >= Rhi then
+ Set_False;
+ elsif Lhi < Rlo then
+ Set_True;
+ end if;
- when N_Op_Ne =>
- if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then
- Set_False;
- elsif Llo > Rhi or else Lhi < Rlo then
- Set_True;
- end if;
+ when N_Op_Ne =>
+ if Llo = Lhi and then Rlo = Rhi and then Llo = Rlo then
+ Set_False;
+ elsif Llo > Rhi or else Lhi < Rlo then
+ Set_True;
+ end if;
end case;
-- All done if we did the rewrite
@@ -3465,9 +3286,12 @@ package body Exp_Ch4 is
-- very weird cases, so in the general case we need an overflow check on
-- the high bound. We can avoid this for the common case of string types
-- and other types whose index is Positive, since we chose a wider range
- -- for the arithmetic type.
+ -- for the arithmetic type. If checks are suppressed we do not set the
+ -- flag, and possibly superfluous warnings will be omitted.
- if Istyp /= Standard_Positive then
+ if Istyp /= Standard_Positive
+ and then not Overflow_Checks_Suppressed (Istyp)
+ then
Activate_Overflow_Check (High_Bound);
end if;
@@ -4291,8 +4115,7 @@ package body Exp_Ch4 is
Set_Finalization_Master
(Root_Type (PtrT), Finalization_Master (Rel_Typ));
else
- Set_Finalization_Master
- (Root_Type (PtrT), Current_Anonymous_Master);
+ Build_Anonymous_Master (Root_Type (PtrT));
end if;
end if;
@@ -4471,8 +4294,14 @@ package body Exp_Ch4 is
-- in the aggregate might not match the subtype mark in the allocator.
if Nkind (Expression (N)) = N_Qualified_Expression then
- Apply_Constraint_Check
- (Expression (Expression (N)), Etype (Expression (N)));
+ declare
+ Exp : constant Node_Id := Expression (Expression (N));
+ Typ : constant Entity_Id := Etype (Expression (N));
+
+ begin
+ Apply_Constraint_Check (Exp, Typ);
+ Apply_Predicate_Check (Exp, Typ);
+ end;
Expand_Allocator_Expression (N);
return;
@@ -4501,6 +4330,7 @@ package body Exp_Ch4 is
Discr : Elmt_Id;
Init : Entity_Id;
Init_Arg1 : Node_Id;
+ Init_Call : Node_Id;
Temp_Decl : Node_Id;
Temp_Type : Entity_Id;
@@ -4703,12 +4533,25 @@ package body Exp_Ch4 is
Dis := True;
Typ := T;
- elsif Is_Private_Type (T)
- and then Present (Full_View (T))
- and then Has_Discriminants (Full_View (T))
- then
- Dis := True;
- Typ := Full_View (T);
+ -- Type may be a private type with no visible discriminants
+ -- in which case check full view if in scope, or the
+ -- underlying_full_view if dealing with a type whose full
+ -- view may be derived from a private type whose own full
+ -- view has discriminants.
+
+ elsif Is_Private_Type (T) then
+ if Present (Full_View (T))
+ and then Has_Discriminants (Full_View (T))
+ then
+ Dis := True;
+ Typ := Full_View (T);
+
+ elsif Present (Underlying_Full_View (T))
+ and then Has_Discriminants (Underlying_Full_View (T))
+ then
+ Dis := True;
+ Typ := Underlying_Full_View (T);
+ end if;
end if;
if Dis then
@@ -4808,10 +4651,17 @@ package body Exp_Ch4 is
-- Generate:
-- [Deep_]Initialize (Init_Arg1);
- Insert_Action (N,
+ Init_Call :=
Make_Init_Call
(Obj_Ref => New_Copy_Tree (Init_Arg1),
- Typ => T));
+ Typ => T);
+
+ -- Guard against a missing [Deep_]Initialize when the
+ -- designated type was not properly frozen.
+
+ if Present (Init_Call) then
+ Insert_Action (N, Init_Call);
+ end if;
end if;
Rewrite (N, New_Occurrence_Of (Temp, Loc));
@@ -4845,16 +4695,23 @@ package body Exp_Ch4 is
------------------------------
procedure Expand_N_Case_Expression (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Typ : constant Entity_Id := Etype (N);
- Cstmt : Node_Id;
- Decl : Node_Id;
- Tnn : Entity_Id;
- Pnn : Entity_Id;
- Actions : List_Id;
- Ttyp : Entity_Id;
- Alt : Node_Id;
- Fexp : Node_Id;
+ Loc : constant Source_Ptr := Sloc (N);
+ Par : constant Node_Id := Parent (N);
+ Typ : constant Entity_Id := Etype (N);
+ Acts : List_Id;
+ Alt : Node_Id;
+ Case_Stmt : Node_Id;
+ Decl : Node_Id;
+ Expr : Node_Id;
+ Target : Entity_Id;
+ Target_Typ : Entity_Id;
+
+ In_Predicate : Boolean := False;
+ -- Flag set when the case expression appears within a predicate
+
+ Optimize_Return_Stmt : Boolean := False;
+ -- Flag set when the case expression can be optimized in the context of
+ -- a simple return statement.
begin
-- Check for MINIMIZED/ELIMINATED overflow mode
@@ -4870,48 +4727,61 @@ package body Exp_Ch4 is
if Ekind_In (Current_Scope, E_Function, E_Procedure)
and then Is_Predicate_Function (Current_Scope)
- and then
- Has_Static_Predicate_Aspect (Etype (First_Entity (Current_Scope)))
then
- return;
+ In_Predicate := True;
+
+ if Has_Static_Predicate_Aspect (Etype (First_Entity (Current_Scope)))
+ then
+ return;
+ end if;
end if;
- -- We expand
+ -- When the type of the case expression is elementary, expand
- -- case X is when A => AX, when B => BX ...
+ -- (case X is when A => AX, when B => BX ...)
- -- to
+ -- into
-- do
- -- Tnn : typ;
+ -- Target : Typ;
-- case X is
-- when A =>
- -- Tnn := AX;
+ -- Target := AX;
-- when B =>
- -- Tnn := BX;
+ -- Target := BX;
-- ...
-- end case;
- -- in Tnn end;
+ -- in Target end;
- -- However, this expansion is wrong for limited types, and also
- -- wrong for unconstrained types (since the bounds may not be the
- -- same in all branches). Furthermore it involves an extra copy
- -- for large objects. So we take care of this by using the following
- -- modified expansion for non-elementary types:
+ -- In all other cases expand into
-- do
- -- type Pnn is access all typ;
- -- Tnn : Pnn;
+ -- type Ptr_Typ is access all Typ;
+ -- Target : Ptr_Typ;
-- case X is
-- when A =>
- -- T := AX'Unrestricted_Access;
+ -- Target := AX'Unrestricted_Access;
-- when B =>
- -- T := BX'Unrestricted_Access;
+ -- Target := BX'Unrestricted_Access;
-- ...
-- end case;
- -- in Tnn.all end;
+ -- in Target.all end;
+
+ -- This approach avoids extra copies of potentially large objects. It
+ -- also allows handling of values of limited or unconstrained types.
+
+ -- Small optimization: when the case expression appears in the context
+ -- of a simple return statement, expand into
- Cstmt :=
+ -- case X is
+ -- when A =>
+ -- return AX;
+ -- when B =>
+ -- return BX;
+ -- ...
+ -- end case;
+
+ Case_Stmt :=
Make_Case_Statement (Loc,
Expression => Expression (N),
Alternatives => New_List);
@@ -4921,101 +4791,160 @@ package body Exp_Ch4 is
-- the premature finalization of controlled objects found within the
-- case statement.
- Set_From_Conditional_Expression (Cstmt);
-
- Actions := New_List;
+ Set_From_Conditional_Expression (Case_Stmt);
+ Acts := New_List;
-- Scalar case
if Is_Elementary_Type (Typ) then
- Ttyp := Typ;
+ Target_Typ := Typ;
+
+ -- ??? Do not perform the optimization when the return statement is
+ -- within a predicate function as this causes supurious errors. Could
+ -- this be a possible mismatch in handling this case somewhere else
+ -- in semantic analysis?
+
+ Optimize_Return_Stmt :=
+ Nkind (Par) = N_Simple_Return_Statement and then not In_Predicate;
+
+ -- Otherwise create an access type to handle the general case using
+ -- 'Unrestricted_Access.
+
+ -- Generate:
+ -- type Ptr_Typ is access all Typ;
else
- Pnn := Make_Temporary (Loc, 'P');
- Append_To (Actions,
+ Target_Typ := Make_Temporary (Loc, 'P');
+
+ Append_To (Acts,
Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Pnn,
+ Defining_Identifier => Target_Typ,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
All_Present => True,
Subtype_Indication => New_Occurrence_Of (Typ, Loc))));
- Ttyp := Pnn;
end if;
- Tnn := Make_Temporary (Loc, 'T');
+ -- Create the declaration of the target which captures the value of the
+ -- expression.
- -- Create declaration for target of expression, and indicate that it
- -- does not require initialization.
+ -- Generate:
+ -- Target : [Ptr_]Typ;
- Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Tnn,
- Object_Definition => New_Occurrence_Of (Ttyp, Loc));
- Set_No_Initialization (Decl);
- Append_To (Actions, Decl);
+ if not Optimize_Return_Stmt then
+ Target := Make_Temporary (Loc, 'T');
- -- Now process the alternatives
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Target,
+ Object_Definition => New_Occurrence_Of (Target_Typ, Loc));
+ Set_No_Initialization (Decl);
+
+ Append_To (Acts, Decl);
+ end if;
+
+ -- Process the alternatives
Alt := First (Alternatives (N));
while Present (Alt) loop
declare
- Aexp : Node_Id := Expression (Alt);
- Aloc : constant Source_Ptr := Sloc (Aexp);
- Stats : List_Id;
+ Alt_Expr : Node_Id := Expression (Alt);
+ Alt_Loc : constant Source_Ptr := Sloc (Alt_Expr);
+ Stmts : List_Id;
begin
- -- As described above, take Unrestricted_Access for case of non-
- -- scalar types, to avoid big copies, and special cases.
+ -- Take the unrestricted access of the expression value for non-
+ -- scalar types. This approach avoids big copies and covers the
+ -- limited and unconstrained cases.
+
+ -- Generate:
+ -- AX'Unrestricted_Access
if not Is_Elementary_Type (Typ) then
- Aexp :=
- Make_Attribute_Reference (Aloc,
- Prefix => Relocate_Node (Aexp),
+ Alt_Expr :=
+ Make_Attribute_Reference (Alt_Loc,
+ Prefix => Relocate_Node (Alt_Expr),
Attribute_Name => Name_Unrestricted_Access);
end if;
- Stats := New_List (
- Make_Assignment_Statement (Aloc,
- Name => New_Occurrence_Of (Tnn, Loc),
- Expression => Aexp));
+ -- Generate:
+ -- return AX['Unrestricted_Access];
+
+ if Optimize_Return_Stmt then
+ Stmts := New_List (
+ Make_Simple_Return_Statement (Alt_Loc,
+ Expression => Alt_Expr));
+
+ -- Generate:
+ -- Target := AX['Unrestricted_Access];
+
+ else
+ Stmts := New_List (
+ Make_Assignment_Statement (Alt_Loc,
+ Name => New_Occurrence_Of (Target, Loc),
+ Expression => Alt_Expr));
+ end if;
-- Propagate declarations inserted in the node by Insert_Actions
-- (for example, temporaries generated to remove side effects).
-- These actions must remain attached to the alternative, given
-- that they are generated by the corresponding expression.
- if Present (Sinfo.Actions (Alt)) then
- Prepend_List (Sinfo.Actions (Alt), Stats);
+ if Present (Actions (Alt)) then
+ Prepend_List (Actions (Alt), Stmts);
+ end if;
+
+ -- Finalize any transient objects on exit from the alternative.
+ -- This is done only in the return optimization case because
+ -- otherwise the case expression is converted into an expression
+ -- with actions which already contains this form of processing.
+
+ if Optimize_Return_Stmt then
+ Process_If_Case_Statements (N, Stmts);
end if;
Append_To
- (Alternatives (Cstmt),
+ (Alternatives (Case_Stmt),
Make_Case_Statement_Alternative (Sloc (Alt),
Discrete_Choices => Discrete_Choices (Alt),
- Statements => Stats));
+ Statements => Stmts));
end;
Next (Alt);
end loop;
- Append_To (Actions, Cstmt);
+ -- Rewrite the parent return statement as a case statement
- -- Construct and return final expression with actions
+ if Optimize_Return_Stmt then
+ Rewrite (Par, Case_Stmt);
+ Analyze (Par);
+
+ -- Otherwise convert the case expression into an expression with actions
- if Is_Elementary_Type (Typ) then
- Fexp := New_Occurrence_Of (Tnn, Loc);
else
- Fexp :=
- Make_Explicit_Dereference (Loc,
- Prefix => New_Occurrence_Of (Tnn, Loc));
- end if;
+ Append_To (Acts, Case_Stmt);
- Rewrite (N,
- Make_Expression_With_Actions (Loc,
- Expression => Fexp,
- Actions => Actions));
+ if Is_Elementary_Type (Typ) then
+ Expr := New_Occurrence_Of (Target, Loc);
- Analyze_And_Resolve (N, Typ);
+ else
+ Expr :=
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Target, Loc));
+ end if;
+
+ -- Generate:
+ -- do
+ -- ...
+ -- in Target[.all] end;
+
+ Rewrite (N,
+ Make_Expression_With_Actions (Loc,
+ Expression => Expr,
+ Actions => Acts));
+
+ Analyze_And_Resolve (N, Typ);
+ end if;
end Expand_N_Case_Expression;
-----------------------------------
@@ -5050,9 +4979,9 @@ package body Exp_Ch4 is
function Process_Action (Act : Node_Id) return Traverse_Result;
-- Inspect and process a single action of an expression_with_actions for
- -- transient controlled objects. If such objects are found, the routine
- -- generates code to clean them up when the context of the expression is
- -- evaluated or elaborated.
+ -- transient objects. If such objects are found, the routine generates
+ -- code to clean them up when the context of the expression is evaluated
+ -- or elaborated.
------------------------------
-- Force_Boolean_Evaluation --
@@ -5095,7 +5024,7 @@ package body Exp_Ch4 is
if Nkind (Act) = N_Object_Declaration
and then Is_Finalizable_Transient (Act, N)
then
- Process_Transient_Object (Act, N);
+ Process_Transient_In_Expression (Act, N, Acts);
return Abandon;
-- Avoid processing temporary function results multiple times when
@@ -5136,11 +5065,11 @@ package body Exp_Ch4 is
null;
-- Force the evaluation of the expression by capturing its value in a
- -- temporary. This ensures that aliases of transient controlled objects
- -- do not leak to the expression of the expression_with_actions node:
+ -- temporary. This ensures that aliases of transient objects do not leak
+ -- to the expression of the expression_with_actions node:
-- do
- -- Trans_Id : Ctrl_Typ : ...;
+ -- Trans_Id : Ctrl_Typ := ...;
-- Alias : ... := Trans_Id;
-- in ... Alias ... end;
@@ -5150,19 +5079,19 @@ package body Exp_Ch4 is
-- reference to the Alias within the actions list:
-- do
- -- Trans_Id : Ctrl_Typ : ...;
+ -- Trans_Id : Ctrl_Typ := ...;
-- Alias : ... := Trans_Id;
-- Val : constant Boolean := ... Alias ...;
-- <finalize Trans_Id>
-- in Val end;
-- Once this transformation is performed, it is safe to finalize the
- -- transient controlled object at the end of the actions list.
+ -- transient object at the end of the actions list.
-- Note that Force_Evaluation does not remove side effects in operators
-- because it assumes that all operands are evaluated and side effect
-- free. This is not the case when an operand depends implicitly on the
- -- transient controlled object through the use of access types.
+ -- transient object through the use of access types.
elsif Is_Boolean_Type (Etype (Expression (N))) then
Force_Boolean_Evaluation (Expression (N));
@@ -5175,8 +5104,8 @@ package body Exp_Ch4 is
Force_Evaluation (Expression (N));
end if;
- -- Process all transient controlled objects found within the actions of
- -- the EWA node.
+ -- Process all transient objects found within the actions of the EWA
+ -- node.
Act := First (Acts);
while Present (Act) loop
@@ -5205,39 +5134,11 @@ package body Exp_Ch4 is
-- Deal with limited types and condition actions
procedure Expand_N_If_Expression (N : Node_Id) is
- procedure Process_Actions (Actions : List_Id);
- -- Inspect and process a single action list of an if expression for
- -- transient controlled objects. If such objects are found, the routine
- -- generates code to clean them up when the context of the expression is
- -- evaluated or elaborated.
-
- ---------------------
- -- Process_Actions --
- ---------------------
-
- procedure Process_Actions (Actions : List_Id) is
- Act : Node_Id;
-
- begin
- Act := First (Actions);
- while Present (Act) loop
- if Nkind (Act) = N_Object_Declaration
- and then Is_Finalizable_Transient (Act, N)
- then
- Process_Transient_Object (Act, N);
- end if;
-
- Next (Act);
- end loop;
- end Process_Actions;
-
- -- Local variables
-
- Loc : constant Source_Ptr := Sloc (N);
- Cond : constant Node_Id := First (Expressions (N));
- Thenx : constant Node_Id := Next (Cond);
- Elsex : constant Node_Id := Next (Thenx);
- Typ : constant Entity_Id := Etype (N);
+ Cond : constant Node_Id := First (Expressions (N));
+ Loc : constant Source_Ptr := Sloc (N);
+ Thenx : constant Node_Id := Next (Cond);
+ Elsex : constant Node_Id := Next (Thenx);
+ Typ : constant Entity_Id := Etype (N);
Actions : List_Id;
Cnn : Entity_Id;
@@ -5247,8 +5148,6 @@ package body Exp_Ch4 is
New_N : Node_Id;
Ptr_Typ : Entity_Id;
- -- Start of processing for Expand_N_If_Expression
-
begin
-- Check for MINIMIZED/ELIMINATED overflow mode
@@ -5267,31 +5166,58 @@ package body Exp_Ch4 is
-- expression, and Sem_Elab circuitry removing it repeatedly.
if Compile_Time_Known_Value (Cond) then
- if Is_True (Expr_Value (Cond)) then
- Expr := Thenx;
- Actions := Then_Actions (N);
- else
- Expr := Elsex;
- Actions := Else_Actions (N);
- end if;
+ declare
+ function Fold_Known_Value (Cond : Node_Id) return Boolean;
+ -- Fold at compile time. Assumes condition known. Return True if
+ -- folding occurred, meaning we're done.
- Remove (Expr);
+ ----------------------
+ -- Fold_Known_Value --
+ ----------------------
- if Present (Actions) then
- Rewrite (N,
- Make_Expression_With_Actions (Loc,
- Expression => Relocate_Node (Expr),
- Actions => Actions));
- Analyze_And_Resolve (N, Typ);
- else
- Rewrite (N, Relocate_Node (Expr));
- end if;
+ function Fold_Known_Value (Cond : Node_Id) return Boolean is
+ begin
+ if Is_True (Expr_Value (Cond)) then
+ Expr := Thenx;
+ Actions := Then_Actions (N);
+ else
+ Expr := Elsex;
+ Actions := Else_Actions (N);
+ end if;
- -- Note that the result is never static (legitimate cases of static
- -- if expressions were folded in Sem_Eval).
+ Remove (Expr);
- Set_Is_Static_Expression (N, False);
- return;
+ if Present (Actions) then
+
+ -- To minimize the use of Expression_With_Actions, just skip
+ -- the optimization as it is not critical for correctness.
+
+ if Minimize_Expression_With_Actions then
+ return False;
+ end if;
+
+ Rewrite (N,
+ Make_Expression_With_Actions (Loc,
+ Expression => Relocate_Node (Expr),
+ Actions => Actions));
+ Analyze_And_Resolve (N, Typ);
+
+ else
+ Rewrite (N, Relocate_Node (Expr));
+ end if;
+
+ -- Note that the result is never static (legitimate cases of
+ -- static if expressions were folded in Sem_Eval).
+
+ Set_Is_Static_Expression (N, False);
+ return True;
+ end Fold_Known_Value;
+
+ begin
+ if Fold_Known_Value (Cond) then
+ return;
+ end if;
+ end;
end if;
-- If the type is limited, and the back end does not handle limited
@@ -5321,8 +5247,8 @@ package body Exp_Ch4 is
-- of actions. These temporaries need to be finalized after the if
-- expression is evaluated.
- Process_Actions (Then_Actions (N));
- Process_Actions (Else_Actions (N));
+ Process_If_Case_Statements (N, Then_Actions (N));
+ Process_If_Case_Statements (N, Else_Actions (N));
-- Generate:
-- type Ann is access all Typ;
@@ -5423,27 +5349,75 @@ package body Exp_Ch4 is
-- We now wrap the actions into the appropriate expression
- if Present (Then_Actions (N)) then
- Rewrite (Thenx,
- Make_Expression_With_Actions (Sloc (Thenx),
- Actions => Then_Actions (N),
- Expression => Relocate_Node (Thenx)));
+ if Minimize_Expression_With_Actions
+ and then (Is_Elementary_Type (Underlying_Type (Typ))
+ or else Is_Constrained (Underlying_Type (Typ)))
+ then
+ -- If we can't use N_Expression_With_Actions nodes, then we insert
+ -- the following sequence of actions (using Insert_Actions):
+
+ -- Cnn : typ;
+ -- if cond then
+ -- <<then actions>>
+ -- Cnn := then-expr;
+ -- else
+ -- <<else actions>>
+ -- Cnn := else-expr
+ -- end if;
- Set_Then_Actions (N, No_List);
- Analyze_And_Resolve (Thenx, Typ);
- end if;
+ -- and replace the if expression by a reference to Cnn
- if Present (Else_Actions (N)) then
- Rewrite (Elsex,
- Make_Expression_With_Actions (Sloc (Elsex),
- Actions => Else_Actions (N),
- Expression => Relocate_Node (Elsex)));
+ Cnn := Make_Temporary (Loc, 'C', N);
- Set_Else_Actions (N, No_List);
- Analyze_And_Resolve (Elsex, Typ);
- end if;
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Cnn,
+ Object_Definition => New_Occurrence_Of (Typ, Loc));
- return;
+ New_If :=
+ Make_Implicit_If_Statement (N,
+ Condition => Relocate_Node (Cond),
+
+ Then_Statements => New_List (
+ Make_Assignment_Statement (Sloc (Thenx),
+ Name => New_Occurrence_Of (Cnn, Sloc (Thenx)),
+ Expression => Relocate_Node (Thenx))),
+
+ Else_Statements => New_List (
+ Make_Assignment_Statement (Sloc (Elsex),
+ Name => New_Occurrence_Of (Cnn, Sloc (Elsex)),
+ Expression => Relocate_Node (Elsex))));
+
+ Set_Assignment_OK (Name (First (Then_Statements (New_If))));
+ Set_Assignment_OK (Name (First (Else_Statements (New_If))));
+
+ New_N := New_Occurrence_Of (Cnn, Loc);
+
+ -- Regular path using Expression_With_Actions
+
+ else
+ if Present (Then_Actions (N)) then
+ Rewrite (Thenx,
+ Make_Expression_With_Actions (Sloc (Thenx),
+ Actions => Then_Actions (N),
+ Expression => Relocate_Node (Thenx)));
+
+ Set_Then_Actions (N, No_List);
+ Analyze_And_Resolve (Thenx, Typ);
+ end if;
+
+ if Present (Else_Actions (N)) then
+ Rewrite (Elsex,
+ Make_Expression_With_Actions (Sloc (Elsex),
+ Actions => Else_Actions (N),
+ Expression => Relocate_Node (Elsex)));
+
+ Set_Else_Actions (N, No_List);
+ Analyze_And_Resolve (Elsex, Typ);
+ end if;
+
+ return;
+ end if;
-- If no actions then no expansion needed, gigi will handle it using the
-- same approach as a C conditional expression.
@@ -6160,18 +6134,60 @@ package body Exp_Ch4 is
-- (the check is only done when the right operand is a subtype; see
-- RM12-4.5.2 (28.1/3-30/3)).
- declare
+ Predicate_Check : declare
+ function In_Range_Check return Boolean;
+ -- Within an expanded range check that may raise Constraint_Error do
+ -- not generate a predicate check as well. It is redundant because
+ -- the context will add an explicit predicate check, and it will
+ -- raise the wrong exception if it fails.
+
+ --------------------
+ -- In_Range_Check --
+ --------------------
+
+ function In_Range_Check return Boolean is
+ P : Node_Id;
+ begin
+ P := Parent (N);
+ while Present (P) loop
+ if Nkind (P) = N_Raise_Constraint_Error then
+ return True;
+
+ elsif Nkind (P) in N_Statement_Other_Than_Procedure_Call
+ or else Nkind (P) = N_Procedure_Call_Statement
+ or else Nkind (P) in N_Declaration
+ then
+ return False;
+ end if;
+
+ P := Parent (P);
+ end loop;
+
+ return False;
+ end In_Range_Check;
+
+ -- Local variables
+
PFunc : constant Entity_Id := Predicate_Function (Rtyp);
+ R_Op : Node_Id;
+
+ -- Start of processing for Predicate_Check
begin
if Present (PFunc)
and then Current_Scope /= PFunc
and then Nkind (Rop) /= N_Range
then
+ if not In_Range_Check then
+ R_Op := Make_Predicate_Call (Rtyp, Lop, Mem => True);
+ else
+ R_Op := New_Occurrence_Of (Standard_True, Loc);
+ end if;
+
Rewrite (N,
Make_And_Then (Loc,
Left_Opnd => Relocate_Node (N),
- Right_Opnd => Make_Predicate_Call (Rtyp, Lop, Mem => True)));
+ Right_Opnd => R_Op));
-- Analyze new expression, mark left operand as analyzed to
-- avoid infinite recursion adding predicate calls. Similarly,
@@ -6184,7 +6200,7 @@ package body Exp_Ch4 is
return;
end if;
- end;
+ end Predicate_Check;
end Expand_N_In;
--------------------------------
@@ -6276,9 +6292,11 @@ package body Exp_Ch4 is
Activate_Atomic_Synchronization (N);
end if;
- -- All done for the non-packed case
+ -- All done if the prefix is not a packed array implemented specially
- if not Is_Packed (Etype (Prefix (N))) then
+ if not (Is_Packed (Etype (Prefix (N)))
+ and then Present (Packed_Array_Impl_Type (Etype (Prefix (N)))))
+ then
return;
end if;
@@ -7676,7 +7694,11 @@ package body Exp_Ch4 is
-- the case of 0.0 ** (negative) even if Machine_Overflows = False.
-- See ACVC test C4A012B, and it is not worth generating the test.
- if Expv >= 0 and then Expv <= 4 then
+ -- For small negative exponents, we return the reciprocal of
+ -- the folding of the exponentiation for the opposite (positive)
+ -- exponent, as required by Ada RM 4.5.6(11/3).
+
+ if abs Expv <= 4 then
-- X ** 0 = 1 (or 1.0)
@@ -7727,8 +7749,7 @@ package body Exp_Ch4 is
-- in
-- En * En
- else
- pragma Assert (Expv = 4);
+ elsif Expv = 4 then
Temp := Make_Temporary (Loc, 'E', Base);
Xnode :=
@@ -7751,6 +7772,27 @@ package body Exp_Ch4 is
Make_Op_Multiply (Loc,
Left_Opnd => New_Occurrence_Of (Temp, Loc),
Right_Opnd => New_Occurrence_Of (Temp, Loc))));
+
+ -- X ** N = 1.0 / X ** (-N)
+ -- N in -4 .. -1
+
+ else
+ pragma Assert
+ (Expv = -1 or Expv = -2 or Expv = -3 or Expv = -4);
+
+ Xnode :=
+ Make_Op_Divide (Loc,
+ Left_Opnd =>
+ Make_Float_Literal (Loc,
+ Radix => Uint_1,
+ Significand => Uint_1,
+ Exponent => Uint_0),
+ Right_Opnd =>
+ Make_Op_Expon (Loc,
+ Left_Opnd => Duplicate_Subexpr (Base),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc,
+ Intval => -Expv)));
end if;
Rewrite (N, Xnode);
@@ -8004,11 +8046,7 @@ package body Exp_Ch4 is
then
Etyp := Standard_Long_Long_Integer;
- -- Overflow checking is the only choice on the AAMP target, where
- -- arithmetic instructions check overflow automatically, so only
- -- one version of the exponentiation unit is needed.
-
- if Ovflo or AAMP_On_Target then
+ if Ovflo then
Rent := RE_Exp_Long_Long_Integer;
else
Rent := RE_Exn_Long_Long_Integer;
@@ -8017,11 +8055,7 @@ package body Exp_Ch4 is
elsif Is_Signed_Integer_Type (Rtyp) then
Etyp := Standard_Integer;
- -- Overflow checking is the only choice on the AAMP target, where
- -- arithmetic instructions check overflow automatically, so only
- -- one version of the exponentiation unit is needed.
-
- if Ovflo or AAMP_On_Target then
+ if Ovflo then
Rent := RE_Exp_Integer;
else
Rent := RE_Exn_Integer;
@@ -8379,8 +8413,8 @@ package body Exp_Ch4 is
else
-- Apply optimization x mod 1 = 0. We don't really need that with
- -- gcc, but it is useful with other back ends (e.g. AAMP), and is
- -- certainly harmless.
+ -- gcc, but it is useful with other back ends and is certainly
+ -- harmless.
if Is_Integer_Type (Etype (N))
and then Compile_Time_Known_Value (Right)
@@ -9131,8 +9165,7 @@ package body Exp_Ch4 is
Right := Right_Opnd (N);
-- Apply optimization x rem 1 = 0. We don't really need that with gcc,
- -- but it is useful with other back ends (e.g. AAMP), and is certainly
- -- harmless.
+ -- but it is useful with other back ends, and is certainly harmless.
if Is_Integer_Type (Etype (N))
and then Compile_Time_Known_Value (Right)
@@ -10591,15 +10624,16 @@ package body Exp_Ch4 is
end if;
-- Check for case of converting to a type that has an invariant
- -- associated with it. This required an invariant check. We convert
+ -- associated with it. This requires an invariant check. We insert
+ -- a call:
- -- typ (expr)
+ -- invariant_check (typ (expr))
- -- into
-
- -- do invariant_check (typ (expr)) in typ (expr);
-
- -- using Duplicate_Subexpr to avoid multiple side effects
+ -- in the code, after removing side effects from the expression.
+ -- This is clearer than replacing the conversion into an expression
+ -- with actions, because the context may impose additional actions
+ -- (tag checks, membership tests, etc.) that conflict with this
+ -- rewriting (used previously).
-- Note: the Comes_From_Source check, and then the resetting of this
-- flag prevents what would otherwise be an infinite recursion.
@@ -10609,12 +10643,8 @@ package body Exp_Ch4 is
and then Comes_From_Source (N)
then
Set_Comes_From_Source (N, False);
- Rewrite (N,
- Make_Expression_With_Actions (Loc,
- Actions => New_List (
- Make_Invariant_Call (Duplicate_Subexpr (N))),
- Expression => Duplicate_Subexpr_No_Checks (N)));
- Analyze_And_Resolve (N, Target_Type);
+ Remove_Side_Effects (N);
+ Insert_Action (N, Make_Invariant_Call (Duplicate_Subexpr (N)));
goto Done;
end if;
@@ -11243,8 +11273,8 @@ package body Exp_Ch4 is
Set_Do_Overflow_Check (N, False);
- if not Is_Descendent_Of_Address (Etype (Expr))
- and then not Is_Descendent_Of_Address (Target_Type)
+ if not Is_Descendant_Of_Address (Etype (Expr))
+ and then not Is_Descendant_Of_Address (Target_Type)
then
Generate_Range_Check
(Expr, Target_Type, CE_Range_Check_Failed);
@@ -11264,6 +11294,7 @@ package body Exp_Ch4 is
-- internal conversions for the purpose of checking predicates.
if Present (Predicate_Function (Target_Type))
+ and then not Predicates_Ignored (Target_Type)
and then Target_Type /= Operand_Type
and then Comes_From_Source (N)
then
@@ -11364,7 +11395,7 @@ package body Exp_Ch4 is
-- spurious type error on the literal when Address is a visible
-- integer type.
- if Is_Descendent_Of_Address (Target_Type) then
+ if Is_Descendant_Of_Address (Target_Type) then
Set_Etype (N, Target_Type);
else
Analyze_And_Resolve (N, Target_Type);
@@ -11614,6 +11645,31 @@ package body Exp_Ch4 is
Shortcut_Ent : constant Entity_Id := Boolean_Literals (Shortcut_Value);
-- If Left = Shortcut_Value then Right need not be evaluated
+ function Make_Test_Expr (Opnd : Node_Id) return Node_Id;
+ -- For Opnd a boolean expression, return a Boolean expression equivalent
+ -- to Opnd /= Shortcut_Value.
+
+ --------------------
+ -- Make_Test_Expr --
+ --------------------
+
+ function Make_Test_Expr (Opnd : Node_Id) return Node_Id is
+ begin
+ if Shortcut_Value then
+ return Make_Op_Not (Sloc (Opnd), Opnd);
+ else
+ return Opnd;
+ end if;
+ end Make_Test_Expr;
+
+ -- Local variables
+
+ Op_Var : Entity_Id;
+ -- Entity for a temporary variable holding the value of the operator,
+ -- used for expansion in the case where actions are present.
+
+ -- Start of processing for Expand_Short_Circuit_Operator
+
begin
-- Deal with non-standard booleans
@@ -11668,17 +11724,72 @@ package body Exp_Ch4 is
if Present (Actions (N)) then
Actlist := Actions (N);
- -- We now use an Expression_With_Actions node for the right operand
- -- of the short-circuit form. Note that this solves the traceability
+ -- The old approach is to expand:
+
+ -- left AND THEN right
+
+ -- into
+
+ -- C : Boolean := False;
+ -- IF left THEN
+ -- Actions;
+ -- IF right THEN
+ -- C := True;
+ -- END IF;
+ -- END IF;
+
+ -- and finally rewrite the operator into a reference to C. Similarly
+ -- for left OR ELSE right, with negated values. Note that this
+ -- rewrite causes some difficulties for coverage analysis because
+ -- of the introduction of the new variable C, which obscures the
+ -- structure of the test.
+
+ -- We use this "old approach" if Minimize_Expression_With_Actions
+ -- is True.
+
+ if Minimize_Expression_With_Actions then
+ Op_Var := Make_Temporary (Loc, 'C', Related_Node => N);
+
+ Insert_Action (N,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Op_Var,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc),
+ Expression =>
+ New_Occurrence_Of (Shortcut_Ent, Loc)));
+
+ Append_To (Actlist,
+ Make_Implicit_If_Statement (Right,
+ Condition => Make_Test_Expr (Right),
+ Then_Statements => New_List (
+ Make_Assignment_Statement (LocR,
+ Name => New_Occurrence_Of (Op_Var, LocR),
+ Expression =>
+ New_Occurrence_Of
+ (Boolean_Literals (not Shortcut_Value), LocR)))));
+
+ Insert_Action (N,
+ Make_Implicit_If_Statement (Left,
+ Condition => Make_Test_Expr (Left),
+ Then_Statements => Actlist));
+
+ Rewrite (N, New_Occurrence_Of (Op_Var, Loc));
+ Analyze_And_Resolve (N, Standard_Boolean);
+
+ -- The new approach (the default) is to use an
+ -- Expression_With_Actions node for the right operand of the
+ -- short-circuit form. Note that this solves the traceability
-- problems for coverage analysis.
- Rewrite (Right,
- Make_Expression_With_Actions (LocR,
- Expression => Relocate_Node (Right),
- Actions => Actlist));
+ else
+ Rewrite (Right,
+ Make_Expression_With_Actions (LocR,
+ Expression => Relocate_Node (Right),
+ Actions => Actlist));
- Set_Actions (N, No_List);
- Analyze_And_Resolve (Right, Standard_Boolean);
+ Set_Actions (N, No_List);
+ Analyze_And_Resolve (Right, Standard_Boolean);
+ end if;
Adjust_Result_Type (N, Typ);
return;
@@ -11694,8 +11805,8 @@ package body Exp_Ch4 is
Set_SCO_Condition (Right, Expr_Value_E (Right) = Standard_True);
end if;
- -- Change (Left and then True), (Left or else False) to Left.
- -- Note that we know there are no actions associated with the right
+ -- Change (Left and then True), (Left or else False) to Left. Note
+ -- that we know there are no actions associated with the right
-- operand, since we just checked for this case above.
if Expr_Value_E (Right) /= Shortcut_Ent then
@@ -12653,7 +12764,7 @@ package body Exp_Ch4 is
return;
end if;
- -- Nothing to do if special -gnatd.P debug flag set
+ -- Nothing to do if special -gnatd.P debug flag set.
if Debug_Flag_Dot_PP then
return;
@@ -12880,117 +12991,124 @@ package body Exp_Ch4 is
return;
end Optimize_Length_Comparison;
- ------------------------------
- -- Process_Transient_Object --
- ------------------------------
+ --------------------------------
+ -- Process_If_Case_Statements --
+ --------------------------------
+
+ procedure Process_If_Case_Statements (N : Node_Id; Stmts : List_Id) is
+ Decl : Node_Id;
+
+ begin
+ Decl := First (Stmts);
+ while Present (Decl) loop
+ if Nkind (Decl) = N_Object_Declaration
+ and then Is_Finalizable_Transient (Decl, N)
+ then
+ Process_Transient_In_Expression (Decl, N, Stmts);
+ end if;
+
+ Next (Decl);
+ end loop;
+ end Process_If_Case_Statements;
+
+ -------------------------------------
+ -- Process_Transient_In_Expression --
+ -------------------------------------
- procedure Process_Transient_Object
- (Decl : Node_Id;
- Rel_Node : Node_Id)
+ procedure Process_Transient_In_Expression
+ (Obj_Decl : Node_Id;
+ Expr : Node_Id;
+ Stmts : List_Id)
is
- Loc : constant Source_Ptr := Sloc (Decl);
- Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
- Obj_Typ : constant Node_Id := Etype (Obj_Id);
- Desig_Typ : Entity_Id;
- Expr : Node_Id;
- Hook_Id : Entity_Id;
- Hook_Insert : Node_Id;
- Ptr_Id : Entity_Id;
+ Loc : constant Source_Ptr := Sloc (Obj_Decl);
+ Obj_Id : constant Entity_Id := Defining_Identifier (Obj_Decl);
- Hook_Context : constant Node_Id := Find_Hook_Context (Rel_Node);
+ Hook_Context : constant Node_Id := Find_Hook_Context (Expr);
-- The node on which to insert the hook as an action. This is usually
-- the innermost enclosing non-transient construct.
+ Fin_Call : Node_Id;
+ Hook_Assign : Node_Id;
+ Hook_Clear : Node_Id;
+ Hook_Decl : Node_Id;
+ Hook_Insert : Node_Id;
+ Ptr_Decl : Node_Id;
+
Fin_Context : Node_Id;
-- The node after which to insert the finalization actions of the
- -- transient controlled object.
+ -- transient object.
begin
- if Is_Boolean_Type (Etype (Rel_Node)) then
- Fin_Context := Last (Actions (Rel_Node));
+ pragma Assert (Nkind_In (Expr, N_Case_Expression,
+ N_Expression_With_Actions,
+ N_If_Expression));
+
+ -- When the context is a Boolean evaluation, all three nodes capture the
+ -- result of their computation in a local temporary:
+
+ -- do
+ -- Trans_Id : Ctrl_Typ := ...;
+ -- Result : constant Boolean := ... Trans_Id ...;
+ -- <finalize Trans_Id>
+ -- in Result end;
+
+ -- As a result, the finalization of any transient objects can safely
+ -- take place after the result capture.
+
+ -- ??? could this be extended to elementary types?
+
+ if Is_Boolean_Type (Etype (Expr)) then
+ Fin_Context := Last (Stmts);
+
+ -- Otherwise the immediate context may not be safe enough to carry
+ -- out transient object finalization due to aliasing and nesting of
+ -- constructs. Insert calls to [Deep_]Finalize after the innermost
+ -- enclosing non-transient construct.
+
else
Fin_Context := Hook_Context;
end if;
- -- Step 1: Create the access type which provides a reference to the
- -- transient controlled object.
+ -- Mark the transient object as successfully processed to avoid double
+ -- finalization.
- if Is_Access_Type (Obj_Typ) then
- Desig_Typ := Directly_Designated_Type (Obj_Typ);
- else
- Desig_Typ := Obj_Typ;
- end if;
+ Set_Is_Finalized_Transient (Obj_Id);
- Desig_Typ := Base_Type (Desig_Typ);
+ -- Construct all the pieces necessary to hook and finalize a transient
+ -- object.
- -- Generate:
- -- Ann : access [all] <Desig_Typ>;
+ Build_Transient_Object_Statements
+ (Obj_Decl => Obj_Decl,
+ Fin_Call => Fin_Call,
+ Hook_Assign => Hook_Assign,
+ Hook_Clear => Hook_Clear,
+ Hook_Decl => Hook_Decl,
+ Ptr_Decl => Ptr_Decl,
+ Finalize_Obj => False);
- Ptr_Id := Make_Temporary (Loc, 'A');
+ -- Add the access type which provides a reference to the transient
+ -- object. Generate:
- Insert_Action (Hook_Context,
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Ptr_Id,
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- All_Present => Ekind (Obj_Typ) = E_General_Access_Type,
- Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc))));
+ -- type Ptr_Typ is access all Desig_Typ;
- -- Step 2: Create a temporary which acts as a hook to the transient
- -- controlled object. Generate:
+ Insert_Action (Hook_Context, Ptr_Decl);
+
+ -- Add the temporary which acts as a hook to the transient object.
+ -- Generate:
-- Hook : Ptr_Id := null;
- Hook_Id := Make_Temporary (Loc, 'T');
+ Insert_Action (Hook_Context, Hook_Decl);
- Insert_Action (Hook_Context,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Hook_Id,
- Object_Definition => New_Occurrence_Of (Ptr_Id, Loc)));
-
- -- Mark the hook as created for the purposes of exporting the transient
- -- controlled object out of the expression_with_action or if expression.
- -- This signals the machinery in Build_Finalizer to treat this case in
- -- a special manner.
-
- Set_Status_Flag_Or_Transient_Decl (Hook_Id, Decl);
-
- -- Step 3: Associate the transient object to the hook
-
- -- This must be inserted right after the object declaration, so that
- -- the assignment is executed if, and only if, the object is actually
- -- created (whereas the declaration of the hook pointer, and the
- -- finalization call, may be inserted at an outer level, and may
- -- remain unused for some executions, if the actual creation of
- -- the object is conditional).
-
- -- The use of unchecked conversion / unrestricted access is needed to
- -- avoid an accessibility violation. Note that the finalization code is
- -- structured in such a way that the "hook" is processed only when it
- -- points to an existing object.
-
- if Is_Access_Type (Obj_Typ) then
- Expr :=
- Unchecked_Convert_To
- (Typ => Ptr_Id,
- Expr => New_Occurrence_Of (Obj_Id, Loc));
- else
- Expr :=
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Obj_Id, Loc),
- Attribute_Name => Name_Unrestricted_Access);
- end if;
+ -- When the transient object is initialized by an aggregate, the hook
+ -- must capture the object after the last aggregate assignment takes
+ -- place. Only then is the object considered initialized. Generate:
- -- Generate:
- -- Hook := Ptr_Id (Obj_Id);
+ -- Hook := Ptr_Typ (Obj_Id);
-- <or>
-- Hook := Obj_Id'Unrestricted_Access;
- -- When the transient object is initialized by an aggregate, the hook
- -- must capture the object after the last component assignment takes
- -- place. Only then is the object fully initialized.
-
- if Ekind (Obj_Id) = E_Variable
+ if Ekind_In (Obj_Id, E_Constant, E_Variable)
and then Present (Last_Aggregate_Assignment (Obj_Id))
then
Hook_Insert := Last_Aggregate_Assignment (Obj_Id);
@@ -12998,54 +13116,42 @@ package body Exp_Ch4 is
-- Otherwise the hook seizes the related object immediately
else
- Hook_Insert := Decl;
+ Hook_Insert := Obj_Decl;
end if;
- Insert_After_And_Analyze (Hook_Insert,
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Hook_Id, Loc),
- Expression => Expr));
-
- -- Step 4: Finalize the hook after the context has been evaluated or
- -- elaborated. Generate:
-
- -- if Hook /= null then
- -- [Deep_]Finalize (Hook.all);
- -- Hook := null;
- -- end if;
+ Insert_After_And_Analyze (Hook_Insert, Hook_Assign);
-- When the node is part of a return statement, there is no need to
-- insert a finalization call, as the general finalization mechanism
- -- (see Build_Finalizer) would take care of the transient controlled
- -- object on subprogram exit. Note that it would also be impossible to
- -- insert the finalization code after the return statement as this will
- -- render it unreachable.
+ -- (see Build_Finalizer) would take care of the transient object on
+ -- subprogram exit. Note that it would also be impossible to insert the
+ -- finalization code after the return statement as this will render it
+ -- unreachable.
if Nkind (Fin_Context) = N_Simple_Return_Statement then
null;
- -- Otherwise finalize the hook
+ -- Finalize the hook after the context has been evaluated. Generate:
+
+ -- if Hook /= null then
+ -- [Deep_]Finalize (Hook.all);
+ -- Hook := null;
+ -- end if;
else
Insert_Action_After (Fin_Context,
- Make_Implicit_If_Statement (Decl,
+ Make_Implicit_If_Statement (Obj_Decl,
Condition =>
Make_Op_Ne (Loc,
- Left_Opnd => New_Occurrence_Of (Hook_Id, Loc),
+ Left_Opnd =>
+ New_Occurrence_Of (Defining_Entity (Hook_Decl), Loc),
Right_Opnd => Make_Null (Loc)),
Then_Statements => New_List (
- Make_Final_Call
- (Obj_Ref =>
- Make_Explicit_Dereference (Loc,
- Prefix => New_Occurrence_Of (Hook_Id, Loc)),
- Typ => Desig_Typ),
-
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Hook_Id, Loc),
- Expression => Make_Null (Loc)))));
+ Fin_Call,
+ Hook_Clear)));
end if;
- end Process_Transient_Object;
+ end Process_Transient_In_Expression;
------------------------
-- Rewrite_Comparison --
@@ -13091,56 +13197,57 @@ package body Exp_Ch4 is
begin
case N_Op_Compare (Nkind (N)) is
- when N_Op_Eq =>
- True_Result := Res = EQ;
- False_Result := Res = LT or else Res = GT or else Res = NE;
-
- when N_Op_Ge =>
- True_Result := Res in Compare_GE;
- False_Result := Res = LT;
-
- if Res = LE
- and then Constant_Condition_Warnings
- and then Comes_From_Source (Original_Node (N))
- and then Nkind (Original_Node (N)) = N_Op_Ge
- and then not In_Instance
- and then Is_Integer_Type (Etype (Left_Opnd (N)))
- and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
- then
- Error_Msg_N
- ("can never be greater than, could replace by ""'=""?c?",
- N);
- Warning_Generated := True;
- end if;
-
- when N_Op_Gt =>
- True_Result := Res = GT;
- False_Result := Res in Compare_LE;
-
- when N_Op_Lt =>
- True_Result := Res = LT;
- False_Result := Res in Compare_GE;
-
- when N_Op_Le =>
- True_Result := Res in Compare_LE;
- False_Result := Res = GT;
+ when N_Op_Eq =>
+ True_Result := Res = EQ;
+ False_Result := Res = LT or else Res = GT or else Res = NE;
+
+ when N_Op_Ge =>
+ True_Result := Res in Compare_GE;
+ False_Result := Res = LT;
+
+ if Res = LE
+ and then Constant_Condition_Warnings
+ and then Comes_From_Source (Original_Node (N))
+ and then Nkind (Original_Node (N)) = N_Op_Ge
+ and then not In_Instance
+ and then Is_Integer_Type (Etype (Left_Opnd (N)))
+ and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
+ then
+ Error_Msg_N
+ ("can never be greater than, could replace by "
+ & """'=""?c?", N);
+ Warning_Generated := True;
+ end if;
- if Res = GE
- and then Constant_Condition_Warnings
- and then Comes_From_Source (Original_Node (N))
- and then Nkind (Original_Node (N)) = N_Op_Le
- and then not In_Instance
- and then Is_Integer_Type (Etype (Left_Opnd (N)))
- and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
- then
- Error_Msg_N
- ("can never be less than, could replace by ""'=""?c?", N);
- Warning_Generated := True;
- end if;
+ when N_Op_Gt =>
+ True_Result := Res = GT;
+ False_Result := Res in Compare_LE;
+
+ when N_Op_Lt =>
+ True_Result := Res = LT;
+ False_Result := Res in Compare_GE;
+
+ when N_Op_Le =>
+ True_Result := Res in Compare_LE;
+ False_Result := Res = GT;
+
+ if Res = GE
+ and then Constant_Condition_Warnings
+ and then Comes_From_Source (Original_Node (N))
+ and then Nkind (Original_Node (N)) = N_Op_Le
+ and then not In_Instance
+ and then Is_Integer_Type (Etype (Left_Opnd (N)))
+ and then not Has_Warnings_Off (Etype (Left_Opnd (N)))
+ then
+ Error_Msg_N
+ ("can never be less than, could replace by ""'=""?c?",
+ N);
+ Warning_Generated := True;
+ end if;
- when N_Op_Ne =>
- True_Result := Res = NE or else Res = GT or else Res = LT;
- False_Result := Res = EQ;
+ when N_Op_Ne =>
+ True_Result := Res = NE or else Res = GT or else Res = LT;
+ False_Result := Res = EQ;
end case;
-- If this is the first iteration, then we actually convert the
diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index f7433225f3..6a808a35a3 100644
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -38,7 +38,6 @@ with Exp_Dbug; use Exp_Dbug;
with Exp_Pakd; use Exp_Pakd;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
-with Ghost; use Ghost;
with Inline; use Inline;
with Namet; use Namet;
with Nlists; use Nlists;
@@ -59,7 +58,6 @@ with Sem_Util; use Sem_Util;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
-with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
with Validsw; use Validsw;
@@ -77,15 +75,15 @@ package body Exp_Ch5 is
-- of formal container iterators.
function Change_Of_Representation (N : Node_Id) return Boolean;
- -- Determine if the right hand side of assignment N is a type conversion
+ -- Determine if the right-hand side of assignment N is a type conversion
-- which requires a change of representation. Called only for the array
-- and record cases.
procedure Expand_Assign_Array (N : Node_Id; Rhs : Node_Id);
-- N is an assignment which assigns an array value. This routine process
-- the various special cases and checks required for such assignments,
- -- including change of representation. Rhs is normally simply the right
- -- hand side of the assignment, except that if the right hand side is a
+ -- including change of representation. Rhs is normally simply the right-
+ -- hand side of the assignment, except that if the right-hand side is a
-- type conversion or a qualified expression, then the RHS is the actual
-- expression inside any such type conversions or qualifications.
@@ -100,14 +98,14 @@ package body Exp_Ch5 is
-- N is an assignment statement which assigns an array value. This routine
-- expands the assignment into a loop (or nested loops for the case of a
-- multi-dimensional array) to do the assignment component by component.
- -- Larray and Rarray are the entities of the actual arrays on the left
- -- hand and right hand sides. L_Type and R_Type are the types of these
- -- arrays (which may not be the same, due to either sliding, or to a
- -- change of representation case). Ndim is the number of dimensions and
- -- the parameter Rev indicates if the loops run normally (Rev = False),
- -- or reversed (Rev = True). The value returned is the constructed
- -- loop statement. Auxiliary declarations are inserted before node N
- -- using the standard Insert_Actions mechanism.
+ -- Larray and Rarray are the entities of the actual arrays on the left-hand
+ -- and right-hand sides. L_Type and R_Type are the types of these arrays
+ -- (which may not be the same, due to either sliding, or to a change of
+ -- representation case). Ndim is the number of dimensions and the parameter
+ -- Rev indicates if the loops run normally (Rev = False), or reversed
+ -- (Rev = True). The value returned is the constructed loop statement.
+ -- Auxiliary declarations are inserted before node N using the standard
+ -- Insert_Actions mechanism.
procedure Expand_Assign_Record (N : Node_Id);
-- N is an assignment of an untagged record value. This routine handles
@@ -117,6 +115,13 @@ package body Exp_Ch5 is
-- clause (this last case is required because holes in the tagged type
-- might be filled with components from child types).
+ procedure Expand_Assign_With_Target_Names (N : Node_Id);
+ -- (AI12-0125): N is an assignment statement whose RHS contains occurrences
+ -- of @ that designate the value of the LHS of the assignment. If the LHS
+ -- is side-effect free the target names can be replaced with a copy of the
+ -- LHS; otherwise the semantics of the assignment is described in terms of
+ -- a procedure with an in-out parameter, and expanded as such.
+
procedure Expand_Formal_Container_Loop (N : Node_Id);
-- Use the primitives specified in an Iterable aspect to expand a loop
-- over a so-called formal container, primarily for SPARK usage.
@@ -279,9 +284,9 @@ package body Exp_Ch5 is
function Is_Non_Local_Array (Exp : Node_Id) return Boolean;
-- Determine if Exp is a reference to an array variable which is other
- -- than an object defined in the current scope, or a slice of such
- -- an object. Such objects can be aliased to parameters (unlike local
- -- array references).
+ -- than an object defined in the current scope, or a component or a
+ -- slice of such an object. Such objects can be aliased to parameters
+ -- (unlike local array references).
-----------------------
-- Apply_Dereference --
@@ -328,10 +333,18 @@ package body Exp_Ch5 is
function Is_Non_Local_Array (Exp : Node_Id) return Boolean is
begin
- return (Is_Entity_Name (Exp)
- and then Scope (Entity (Exp)) /= Current_Scope)
- or else (Nkind (Exp) = N_Slice
- and then Is_Non_Local_Array (Prefix (Exp)));
+ case Nkind (Exp) is
+ when N_Indexed_Component
+ | N_Selected_Component
+ | N_Slice
+ =>
+ return Is_Non_Local_Array (Prefix (Exp));
+
+ when others =>
+ return
+ not (Is_Entity_Name (Exp)
+ and then Scope (Entity (Exp)) = Current_Scope);
+ end case;
end Is_Non_Local_Array;
-- Determine if Lhs, Rhs are formal arrays or nonlocal arrays
@@ -346,7 +359,7 @@ package body Exp_Ch5 is
begin
-- Deal with length check. Note that the length check is done with
- -- respect to the right hand side as given, not a possible underlying
+ -- respect to the right-hand side as given, not a possible underlying
-- renamed object, since this would generate incorrect extra checks.
Apply_Length_Check (Rhs, L_Type);
@@ -407,8 +420,8 @@ package body Exp_Ch5 is
end if;
-- We certainly must use a loop for change of representation and also
- -- we use the operand of the conversion on the right hand side as the
- -- effective right hand side (the component types must match in this
+ -- we use the operand of the conversion on the right-hand side as the
+ -- effective right-hand side (the component types must match in this
-- situation).
if Crep then
@@ -704,7 +717,7 @@ package body Exp_Ch5 is
Act_L_Array := Get_Referenced_Object (Prefix (Act_Lhs));
Act_R_Array := Get_Referenced_Object (Prefix (Act_Rhs));
- -- If both left and right hand arrays are entity names, and refer
+ -- If both left- and right-hand arrays are entity names, and refer
-- to different entities, then we know that the move is safe (the
-- two storage areas are completely disjoint).
@@ -736,10 +749,15 @@ package body Exp_Ch5 is
end if;
case Cresult is
- when LT | LE | EQ => Set_Backwards_OK (N, False);
- when GT | GE => Set_Forwards_OK (N, False);
- when NE | Unknown => Set_Backwards_OK (N, False);
- Set_Forwards_OK (N, False);
+ when EQ | LE | LT =>
+ Set_Backwards_OK (N, False);
+
+ when GE | GT =>
+ Set_Forwards_OK (N, False);
+
+ when NE | Unknown =>
+ Set_Backwards_OK (N, False);
+ Set_Forwards_OK (N, False);
end case;
end if;
end if;
@@ -749,25 +767,11 @@ package body Exp_Ch5 is
-- then the outcome depends on the capabilities of the back end.
if not Loop_Required then
+ -- Assume the back end can deal with all cases of overlap by
+ -- falling back to memmove if it cannot use a more efficient
+ -- approach.
- -- The GCC back end can deal with all cases of overlap by falling
- -- back to memmove if it cannot use a more efficient approach.
-
- if not AAMP_On_Target then
- return;
-
- -- Assume other back ends can handle it if Forwards_OK is set
-
- elsif Forwards_OK (N) then
- return;
-
- -- If Forwards_OK is not set, the back end will need something
- -- like memmove to handle the move. For now, this processing is
- -- activated using the .s debug flag (-gnatd.s).
-
- elsif Debug_Flag_Dot_S then
- return;
- end if;
+ return;
end if;
-- At this stage we have to generate an explicit loop, and we have
@@ -1000,7 +1004,7 @@ package body Exp_Ch5 is
then
-- Call TSS procedure for array assignment, passing the
- -- explicit bounds of right and left hand sides.
+ -- explicit bounds of right- and left-hand sides.
declare
Proc : constant Entity_Id :=
@@ -1076,7 +1080,7 @@ package body Exp_Ch5 is
-- end loop;
-- end;
- -- Here Rev is False, and Tm1Xn are the subscript types for the right hand
+ -- Here Rev is False, and Tm1Xn are the subscript types for the right-hand
-- side. The declarations of R2b and R4b are inserted before the original
-- assignment statement.
@@ -1272,7 +1276,7 @@ package body Exp_Ch5 is
L_Typ : constant Entity_Id := Base_Type (Etype (Lhs));
begin
- -- If change of representation, then extract the real right hand side
+ -- If change of representation, then extract the real right-hand side
-- from the type conversion, and proceed with component-wise assignment,
-- since the two types are not the same as far as the back end is
-- concerned.
@@ -1336,7 +1340,7 @@ package body Exp_Ch5 is
-- Given C, the entity for a discriminant or component, build an
-- assignment for the corresponding field values. The flag U_U
-- signals the presence of an Unchecked_Union and forces the usage
- -- of the inferred discriminant value of C as the right hand side
+ -- of the inferred discriminant value of C as the right-hand side
-- of the assignment.
function Make_Field_Assigns (CI : List_Id) return List_Id;
@@ -1448,7 +1452,7 @@ package body Exp_Ch5 is
begin
-- In the case of an Unchecked_Union, use the discriminant
- -- constraint value as on the right hand side of the assignment.
+ -- constraint value as on the right-hand side of the assignment.
if U_U then
Expr :=
@@ -1608,6 +1612,142 @@ package body Exp_Ch5 is
end;
end Expand_Assign_Record;
+ -------------------------------------
+ -- Expand_Assign_With_Target_Names --
+ -------------------------------------
+
+ procedure Expand_Assign_With_Target_Names (N : Node_Id) is
+ LHS : constant Node_Id := Name (N);
+ LHS_Typ : constant Entity_Id := Etype (LHS);
+ Loc : constant Source_Ptr := Sloc (N);
+ RHS : constant Node_Id := Expression (N);
+
+ Ent : Entity_Id;
+ -- The entity of the left-hand side
+
+ function Replace_Target (N : Node_Id) return Traverse_Result;
+ -- Replace occurrences of the target name by the proper entity: either
+ -- the entity of the LHS in simple cases, or the formal of the
+ -- constructed procedure otherwise.
+
+ --------------------
+ -- Replace_Target --
+ --------------------
+
+ function Replace_Target (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) = N_Target_Name then
+ Rewrite (N, New_Occurrence_Of (Ent, Sloc (N)));
+ end if;
+
+ Set_Analyzed (N, False);
+ return OK;
+ end Replace_Target;
+
+ procedure Replace_Target_Name is new Traverse_Proc (Replace_Target);
+
+ -- Local variables
+
+ New_RHS : Node_Id;
+ Proc_Id : Entity_Id;
+
+ -- Start of processing for Expand_Assign_With_Target_Names
+
+ begin
+ New_RHS := New_Copy_Tree (RHS);
+
+ -- The left-hand side is a direct name
+
+ if Is_Entity_Name (LHS)
+ and then not Is_Renaming_Of_Object (Entity (LHS))
+ then
+ Ent := Entity (LHS);
+ Replace_Target_Name (New_RHS);
+
+ -- Generate:
+ -- LHS := ... LHS ...;
+
+ Rewrite (N,
+ Make_Assignment_Statement (Loc,
+ Name => Relocate_Node (LHS),
+ Expression => New_RHS));
+
+ -- The left-hand side is not a direct name, but is side-effect free.
+ -- Capture its value in a temporary to avoid multiple evaluations.
+
+ elsif Side_Effect_Free (LHS) then
+ Ent := Make_Temporary (Loc, 'T');
+ Replace_Target_Name (New_RHS);
+
+ -- Generate:
+ -- T : LHS_Typ := LHS;
+
+ Insert_Before_And_Analyze (N,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Ent,
+ Object_Definition => New_Occurrence_Of (LHS_Typ, Loc),
+ Expression => New_Copy_Tree (LHS)));
+
+ -- Generate:
+ -- LHS := ... T ...;
+
+ Rewrite (N,
+ Make_Assignment_Statement (Loc,
+ Name => Relocate_Node (LHS),
+ Expression => New_RHS));
+
+ -- Otherwise wrap the whole assignment statement in a procedure with an
+ -- IN OUT parameter. The original assignment then becomes a call to the
+ -- procedure with the left-hand side as an actual.
+
+ else
+ Ent := Make_Temporary (Loc, 'T');
+ Replace_Target_Name (New_RHS);
+
+ -- Generate:
+ -- procedure P (T : in out LHS_Typ) is
+ -- begin
+ -- T := ... T ...;
+ -- end P;
+
+ Proc_Id := Make_Temporary (Loc, 'P');
+
+ Insert_Before_And_Analyze (N,
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Proc_Id,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Ent,
+ In_Present => True,
+ Out_Present => True,
+ Parameter_Type =>
+ New_Occurrence_Of (LHS_Typ, Loc)))),
+
+ Declarations => Empty_List,
+
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Ent, Loc),
+ Expression => New_RHS)))));
+
+ -- Generate:
+ -- P (LHS);
+
+ Rewrite (N,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Proc_Id, Loc),
+ Parameter_Associations => New_List (Relocate_Node (LHS))));
+ end if;
+
+ -- Analyze rewritten node, either as assignment or procedure call
+
+ Analyze (N);
+ end Expand_Assign_With_Target_Names;
+
-----------------------------------
-- Expand_N_Assignment_Statement --
-----------------------------------
@@ -1623,15 +1763,7 @@ package body Exp_Ch5 is
Typ : constant Entity_Id := Underlying_Type (Etype (Lhs));
Exp : Node_Id;
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
-
begin
- -- The assignment statement is Ghost when the left hand side is Ghost.
- -- Set the mode now to ensure that any nodes generated during expansion
- -- are properly marked as Ghost.
-
- Set_Ghost_Mode (N);
-
-- Special case to check right away, if the Componentwise_Assignment
-- flag is set, this is a reanalysis from the expansion of the primitive
-- assignment procedure for a tagged type, and all we need to do is to
@@ -1641,7 +1773,6 @@ package body Exp_Ch5 is
if Componentwise_Assignment (N) then
Expand_Assign_Record (N);
- Ghost_Mode := Save_Ghost_Mode;
return;
end if;
@@ -1659,6 +1790,14 @@ package body Exp_Ch5 is
Check_Valid_Lvalue_Subscripts (Lhs);
end if;
+ -- Separate expansion if RHS contain target names. Note that assignment
+ -- may already have been expanded if RHS is aggregate.
+
+ if Nkind (N) = N_Assignment_Statement and then Has_Target_Names (N) then
+ Expand_Assign_With_Target_Names (N);
+ return;
+ end if;
+
-- Ada 2005 (AI-327): Handle assignment to priority of protected object
-- Rewrite an assignment to X'Priority into a run-time call
@@ -1693,13 +1832,10 @@ package body Exp_Ch5 is
-- The attribute Priority applied to protected objects has been
-- previously expanded into a call to the Get_Ceiling run-time
- -- subprogram.
+ -- subprogram. In restricted profiles this is not available.
+
+ if Is_Expanded_Priority_Attribute (Ent) then
- if Nkind (Ent) = N_Function_Call
- and then (Entity (Name (Ent)) = RTE (RE_Get_Ceiling)
- or else
- Entity (Name (Ent)) = RTE (RO_PE_Get_Ceiling))
- then
-- Look for the enclosing concurrent type
Conctyp := Current_Scope;
@@ -1736,7 +1872,6 @@ package body Exp_Ch5 is
Rewrite (N, Call);
Analyze (N);
- Ghost_Mode := Save_Ghost_Mode;
return;
end if;
end;
@@ -1816,7 +1951,7 @@ package body Exp_Ch5 is
-- where the reference was not expanded in the original tree,
-- since it was on the left side of an assignment. But in the
-- pre-assignment statement (the object definition), BPAR_Expr
- -- will end up on the right hand side, and must be reexpanded. To
+ -- will end up on the right-hand side, and must be reexpanded. To
-- achieve this, we reset the analyzed flag of all selected and
-- indexed components down to the actual indexed component for
-- the packed array.
@@ -1825,8 +1960,8 @@ package body Exp_Ch5 is
loop
Set_Analyzed (Exp, False);
- if Nkind_In
- (Exp, N_Selected_Component, N_Indexed_Component)
+ if Nkind_In (Exp, N_Indexed_Component,
+ N_Selected_Component)
then
Exp := Prefix (Exp);
else
@@ -1887,7 +2022,6 @@ package body Exp_Ch5 is
Rewrite (N, Make_Null_Statement (Loc));
Analyze (N);
- Ghost_Mode := Save_Ghost_Mode;
return;
end if;
@@ -1949,10 +2083,12 @@ package body Exp_Ch5 is
-- have a full view with discriminants, but those are nameable only
-- in the underlying type, so convert the Rhs to it before potential
-- checking. Convert Lhs as well, otherwise the actual subtype might
- -- not be constructible.
+ -- not be constructible. If the discriminants have defaults the type
+ -- is unconstrained and there is nothing to check.
elsif Has_Unknown_Discriminants (Base_Type (Etype (Lhs)))
and then Has_Discriminants (Typ)
+ and then not Has_Defaulted_Discriminants (Typ)
then
Rewrite (Rhs, OK_Convert_To (Base_Type (Typ), Rhs));
Rewrite (Lhs, OK_Convert_To (Base_Type (Typ), Lhs));
@@ -2031,10 +2167,13 @@ package body Exp_Ch5 is
end if;
-- Ada 2012 (AI05-148): Update current accessibility level if Rhs is a
- -- stand-alone obj of an anonymous access type.
+ -- stand-alone obj of an anonymous access type. Do not install the check
+ -- when the Lhs denotes a container cursor and the Next function employs
+ -- an access type, because this can never result in a dangling pointer.
if Is_Access_Type (Typ)
and then Is_Entity_Name (Lhs)
+ and then Ekind (Entity (Lhs)) /= E_Loop_Parameter
and then Present (Effective_Extra_Accessibility (Entity (Lhs)))
then
declare
@@ -2107,7 +2246,6 @@ package body Exp_Ch5 is
if not Crep then
Expand_Bit_Packed_Element_Set (N);
- Ghost_Mode := Save_Ghost_Mode;
return;
-- Change of representation case
@@ -2164,7 +2302,7 @@ package body Exp_Ch5 is
begin
-- In the controlled case, we ensure that function calls are
-- evaluated before finalizing the target. In all cases, it makes
- -- the expansion easier if the side-effects are removed first.
+ -- the expansion easier if the side effects are removed first.
Remove_Side_Effects (Lhs);
Remove_Side_Effects (Rhs);
@@ -2206,7 +2344,6 @@ package body Exp_Ch5 is
-- expansion, since they would be missed in -gnatc mode ???
Error_Msg_N ("assignment not available on limited type", N);
- Ghost_Mode := Save_Ghost_Mode;
return;
end if;
@@ -2238,21 +2375,51 @@ package body Exp_Ch5 is
and then Is_Tagged_Type (Typ)
and then Is_Tagged_Type (Underlying_Type (Etype (Rhs)))
then
- Append_To (L,
- Make_Raise_Constraint_Error (Loc,
- Condition =>
- Make_Op_Ne (Loc,
- Left_Opnd =>
- Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr (Lhs),
- Selector_Name =>
- Make_Identifier (Loc, Name_uTag)),
- Right_Opnd =>
- Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr (Rhs),
- Selector_Name =>
- Make_Identifier (Loc, Name_uTag))),
- Reason => CE_Tag_Check_Failed));
+ declare
+ Lhs_Tag : Node_Id;
+ Rhs_Tag : Node_Id;
+
+ begin
+ if not Is_Interface (Typ) then
+ Lhs_Tag :=
+ Make_Selected_Component (Loc,
+ Prefix => Duplicate_Subexpr (Lhs),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uTag));
+ Rhs_Tag :=
+ Make_Selected_Component (Loc,
+ Prefix => Duplicate_Subexpr (Rhs),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uTag));
+ else
+ -- Displace the pointer to the base of the objects
+ -- applying 'Address, which is later expanded into
+ -- a call to RE_Base_Address.
+
+ Lhs_Tag :=
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => Duplicate_Subexpr (Lhs),
+ Attribute_Name => Name_Address)));
+ Rhs_Tag :=
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => Duplicate_Subexpr (Rhs),
+ Attribute_Name => Name_Address)));
+ end if;
+
+ Append_To (L,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Op_Ne (Loc,
+ Left_Opnd => Lhs_Tag,
+ Right_Opnd => Rhs_Tag),
+ Reason => CE_Tag_Check_Failed));
+ end;
end if;
declare
@@ -2354,6 +2521,8 @@ package body Exp_Ch5 is
AUD : constant Entity_Id := RTE (RE_Abort_Undefer_Direct);
begin
+ Set_Is_Abort_Block (N);
+
Set_Scope (Blk, Current_Scope);
Set_Etype (Blk, Standard_Void_Type);
Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N)));
@@ -2377,7 +2546,6 @@ package body Exp_Ch5 is
-- it with all checks suppressed.
Analyze (N, Suppress => All_Checks);
- Ghost_Mode := Save_Ghost_Mode;
return;
end Tagged_Case;
@@ -2395,7 +2563,6 @@ package body Exp_Ch5 is
end loop;
Expand_Assign_Array (N, Actual_Rhs);
- Ghost_Mode := Save_Ghost_Mode;
return;
end;
@@ -2403,7 +2570,6 @@ package body Exp_Ch5 is
elsif Is_Record_Type (Typ) then
Expand_Assign_Record (N);
- Ghost_Mode := Save_Ghost_Mode;
return;
-- Scalar types. This is where we perform the processing related to the
@@ -2462,7 +2628,7 @@ package body Exp_Ch5 is
if Validity_Checks_On
and then Validity_Check_Copies
then
- -- Skip this if left hand side is an array or record component
+ -- Skip this if left-hand side is an array or record component
-- and elementary component validity checks are suppressed.
if Nkind_In (Lhs, N_Selected_Component, N_Indexed_Component)
@@ -2516,11 +2682,8 @@ package body Exp_Ch5 is
end if;
end if;
- Ghost_Mode := Save_Ghost_Mode;
-
exception
when RE_Not_Available =>
- Ghost_Mode := Save_Ghost_Mode;
return;
end Expand_N_Assignment_Statement;
@@ -2556,10 +2719,11 @@ package body Exp_Ch5 is
-- does not obey the predicate, the value is marked non-static, and
-- there can be no corresponding static alternative. In that case we
-- replace the case statement with an exception, regardless of whether
- -- assertions are enabled or not.
+ -- assertions are enabled or not, unless predicates are ignored.
if Compile_Time_Known_Value (Expr)
and then Has_Predicates (Etype (Expr))
+ and then not Predicates_Ignored (Etype (Expr))
and then not Is_OK_Static_Expression (Expr)
then
Rewrite (N,
@@ -2642,7 +2806,9 @@ package body Exp_Ch5 is
-- comes from source -- no need to validity check internally
-- generated case statements).
- if Validity_Check_Default then
+ if Validity_Check_Default
+ and then not Predicates_Ignored (Etype (Expr))
+ then
Ensure_Valid (Expr);
end if;
@@ -2771,9 +2937,33 @@ package body Exp_Ch5 is
if not Others_Present then
Others_Node := Make_Others_Choice (Sloc (Last_Alt));
- Set_Others_Discrete_Choices
- (Others_Node, Discrete_Choices (Last_Alt));
- Set_Discrete_Choices (Last_Alt, New_List (Others_Node));
+
+ -- If Predicates_Ignored is true the value does not satisfy the
+ -- predicate, and there is no Others choice, Constraint_Error
+ -- must be raised (4.5.7 (21/3)).
+
+ if Predicates_Ignored (Etype (Expr)) then
+ declare
+ Except : constant Node_Id :=
+ Make_Raise_Constraint_Error (Loc,
+ Reason => CE_Invalid_Data);
+ New_Alt : constant Node_Id :=
+ Make_Case_Statement_Alternative (Loc,
+ Discrete_Choices => New_List (
+ Make_Others_Choice (Loc)),
+ Statements => New_List (Except));
+
+ begin
+ Append (New_Alt, Alternatives (N));
+ Analyze_And_Resolve (Except);
+ end;
+
+ else
+ Set_Others_Discrete_Choices
+ (Others_Node, Discrete_Choices (Last_Alt));
+ Set_Discrete_Choices (Last_Alt, New_List (Others_Node));
+ end if;
+
end if;
-- Deal with possible declarations of controlled objects, and also
@@ -2888,7 +3078,7 @@ package body Exp_Ch5 is
-- For an element iterator, the Element aspect must be present,
-- (this is checked during analysis) and the expansion takes the form:
- -- Cursor : Cursor_type := First (Container);
+ -- Cursor : Cursor_Type := First (Container);
-- Elmt : Element_Type;
-- while Has_Element (Cursor, Container) loop
-- Elmt := Element (Container, Cursor);
@@ -2900,10 +3090,10 @@ package body Exp_Ch5 is
-- In that case we create a block to hold a variable declaration
-- initialized with a call to Element, and generate:
- -- Cursor : Cursor_type := First (Container);
+ -- Cursor : Cursor_Type := First (Container);
-- while Has_Element (Cursor, Container) loop
-- declare
- -- Elmt : Element-Type := Element (Container, Cursor);
+ -- Elmt : Element_Type := Element (Container, Cursor);
-- begin
-- <original loop statements>
-- Cursor := Next (Container, Cursor);
@@ -2917,7 +3107,7 @@ package body Exp_Ch5 is
Set_Ekind (Cursor, E_Variable);
Insert_Action (N, Init);
- -- Declaration for Element.
+ -- Declaration for Element
Elmt_Decl :=
Make_Object_Declaration (Loc,
@@ -3158,10 +3348,6 @@ package body Exp_Ch5 is
if Present (Condition_Actions (E))
or else Compile_Time_Known_Value (Condition (E))
then
- -- Note this is not an implicit if statement, since it is part
- -- of an explicit if statement in the source (or of an implicit
- -- if statement that has already been tested).
-
New_If :=
Make_If_Statement (Sloc (E),
Condition => Condition (E),
@@ -3192,6 +3378,15 @@ package body Exp_Ch5 is
end if;
Analyze (New_If);
+
+ -- Note this is not an implicit if statement, since it is part
+ -- of an explicit if statement in the source (or of an implicit
+ -- if statement that has already been tested). We set the flag
+ -- after calling Analyze to avoid generating extra warnings
+ -- specific to pure if statements, however (see
+ -- Sem_Ch5.Analyze_If_Statement).
+
+ Set_Comes_From_Source (New_If, Comes_From_Source (N));
return;
-- No special processing for that elsif part, move to next
@@ -3606,25 +3801,31 @@ package body Exp_Ch5 is
Container : Node_Id;
Container_Typ : Entity_Id)
is
- Id : constant Entity_Id := Defining_Identifier (I_Spec);
- Loc : constant Source_Ptr := Sloc (N);
-
- I_Kind : constant Entity_Kind := Ekind (Id);
- Cursor : Entity_Id;
- Iterator : Entity_Id;
- New_Loop : Node_Id;
- Stats : constant List_Id := Statements (N);
+ Id : constant Entity_Id := Defining_Identifier (I_Spec);
+ Elem_Typ : constant Entity_Id := Etype (Id);
+ Id_Kind : constant Entity_Kind := Ekind (Id);
+ Loc : constant Source_Ptr := Sloc (N);
+ Stats : constant List_Id := Statements (N);
- Element_Type : constant Entity_Id := Etype (Id);
- Iter_Type : Entity_Id;
- Pack : Entity_Id;
- Decl : Node_Id;
- Name_Init : Name_Id;
- Name_Step : Name_Id;
+ Cursor : Entity_Id;
+ Decl : Node_Id;
+ Iter_Type : Entity_Id;
+ Iterator : Entity_Id;
+ Name_Init : Name_Id;
+ Name_Step : Name_Id;
+ New_Loop : Node_Id;
- Fast_Element_Access_Op, Fast_Step_Op : Entity_Id := Empty;
+ Fast_Element_Access_Op : Entity_Id := Empty;
+ Fast_Step_Op : Entity_Id := Empty;
-- Only for optimized version of "for ... of"
+ Iter_Pack : Entity_Id;
+ -- The package in which the iterator interface is instantiated. This is
+ -- typically an instance within the container package.
+
+ Pack : Entity_Id;
+ -- The package in which the container type is declared
+
begin
-- Determine the advancement and initialization steps for the cursor.
-- Analysis of the expanded loop will verify that the container has a
@@ -3659,8 +3860,6 @@ package body Exp_Ch5 is
Pack := Scope (Container_Typ);
end if;
- Iter_Type := Etype (Name (I_Spec));
-
if Of_Present (I_Spec) then
Handle_Of : declare
Container_Arg : Node_Id;
@@ -3709,14 +3908,18 @@ package body Exp_Ch5 is
elsif Is_Derived_Type (T) then
-- The default iterator must be a primitive operation of the
- -- type, at the same dispatch slot position.
+ -- type, at the same dispatch slot position. The DT position
+ -- may not be established if type is not frozen yet.
Prim := First_Elmt (Primitive_Operations (T));
while Present (Prim) loop
Op := Node (Prim);
- if Chars (Op) = Chars (Iter)
- and then DT_Position (Op) = DT_Position (Iter)
+ if Alias (Op) = Iter
+ or else
+ (Chars (Op) = Chars (Iter)
+ and then Present (DTC_Entity (Op))
+ and then DT_Position (Op) = DT_Position (Iter))
then
return Op;
end if;
@@ -3735,6 +3938,8 @@ package body Exp_Ch5 is
end if;
end Get_Default_Iterator;
+ -- Local variables
+
Default_Iter : Entity_Id;
Ent : Entity_Id;
@@ -3761,6 +3966,12 @@ package body Exp_Ch5 is
Iter_Type := Etype (Default_Iter);
+ -- The iterator type, which is a class-wide type, may itself be
+ -- derived locally, so the desired instantiation is the scope of
+ -- the root type of the iterator type.
+
+ Iter_Pack := Scope (Root_Type (Etype (Iter_Type)));
+
-- Find declarations needed for "for ... of" optimization
Ent := First_Entity (Pack);
@@ -3799,28 +4010,35 @@ package body Exp_Ch5 is
New_List (New_Copy_Tree (Container_Arg)))));
end if;
- -- The iterator type, which is a class-wide type, may itself be
- -- derived locally, so the desired instantiation is the scope of
- -- the root type of the iterator type. Currently, Pack is the
- -- container instance; this overwrites it with the iterator
- -- package.
+ -- Rewrite domain of iteration as a call to the default iterator
+ -- for the container type. The formal may be an access parameter
+ -- in which case we must build a reference to the container.
- Pack := Scope (Root_Type (Etype (Iter_Type)));
+ declare
+ Arg : Node_Id;
+ begin
+ if Is_Access_Type (Etype (First_Entity (Default_Iter))) then
+ Arg :=
+ Make_Attribute_Reference (Loc,
+ Prefix => Container_Arg,
+ Attribute_Name => Name_Unrestricted_Access);
+ else
+ Arg := Container_Arg;
+ end if;
- -- Rewrite domain of iteration as a call to the default iterator
- -- for the container type.
+ Rewrite (Name (I_Spec),
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (Default_Iter, Loc),
+ Parameter_Associations => New_List (Arg)));
+ end;
- Rewrite (Name (I_Spec),
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (Default_Iter, Loc),
- Parameter_Associations => New_List (Container_Arg)));
Analyze_And_Resolve (Name (I_Spec));
-- Find cursor type in proper iterator package, which is an
-- instantiation of Iterator_Interfaces.
- Ent := First_Entity (Pack);
+ Ent := First_Entity (Iter_Pack);
while Present (Ent) loop
if Chars (Ent) = Name_Cursor then
Set_Etype (Cursor, Etype (Ent));
@@ -3835,7 +4053,7 @@ package body Exp_Ch5 is
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Id,
Subtype_Mark =>
- New_Occurrence_Of (Element_Type, Loc),
+ New_Occurrence_Of (Elem_Typ, Loc),
Name =>
Make_Explicit_Dereference (Loc,
Prefix =>
@@ -3850,7 +4068,7 @@ package body Exp_Ch5 is
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Id,
Subtype_Mark =>
- New_Occurrence_Of (Element_Type, Loc),
+ New_Occurrence_Of (Elem_Typ, Loc),
Name =>
Make_Indexed_Component (Loc,
Prefix => Relocate_Node (Container_Arg),
@@ -3858,8 +4076,8 @@ package body Exp_Ch5 is
New_List (New_Occurrence_Of (Cursor, Loc))));
end if;
- -- The defining identifier in the iterator is user-visible
- -- and must be visible in the debugger.
+ -- The defining identifier in the iterator is user-visible and
+ -- must be visible in the debugger.
Set_Debug_Info_Needed (Id);
@@ -3879,18 +4097,25 @@ package body Exp_Ch5 is
Prepend_To (Stats, Decl);
end Handle_Of;
- -- X in Iterate (S) : type of iterator is type of explicitly
- -- given Iterate function, and the loop variable is the cursor.
- -- It will be assigned in the loop and must be a variable.
+ -- X in Iterate (S) : type of iterator is type of explicitly given
+ -- Iterate function, and the loop variable is the cursor. It will be
+ -- assigned in the loop and must be a variable.
else
+ Iter_Type := Etype (Name (I_Spec));
+
+ -- The iterator type, which is a class-wide type, may itself be
+ -- derived locally, so the desired instantiation is the scope of
+ -- the root type of the iterator type, as in the "of" case.
+
+ Iter_Pack := Scope (Root_Type (Etype (Iter_Type)));
Cursor := Id;
end if;
Iterator := Make_Temporary (Loc, 'I');
- -- For both iterator forms, add a call to the step operation to
- -- advance the cursor. Generate:
+ -- For both iterator forms, add a call to the step operation to advance
+ -- the cursor. Generate:
-- Cursor := Iterator.Next (Cursor);
@@ -3900,8 +4125,9 @@ package body Exp_Ch5 is
if Present (Fast_Element_Access_Op) and then Present (Fast_Step_Op) then
declare
- Step_Call : Node_Id;
Curs_Name : constant Node_Id := New_Occurrence_Of (Cursor, Loc);
+ Step_Call : Node_Id;
+
begin
Step_Call :=
Make_Procedure_Call_Statement (Loc,
@@ -3949,16 +4175,16 @@ package body Exp_Ch5 is
Condition =>
Make_Function_Call (Loc,
Name =>
- New_Occurrence_Of (
- Next_Entity (First_Entity (Pack)), Loc),
- Parameter_Associations =>
- New_List (New_Occurrence_Of (Cursor, Loc)))),
+ New_Occurrence_Of
+ (Next_Entity (First_Entity (Iter_Pack)), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Cursor, Loc)))),
Statements => Stats,
End_Label => Empty);
- -- If present, preserve identifier of loop, which can be used in
- -- an exit statement in the body.
+ -- If present, preserve identifier of loop, which can be used in an exit
+ -- statement in the body.
if Present (Identifier (N)) then
Set_Identifier (New_Loop, Relocate_Node (Identifier (N)));
@@ -3972,22 +4198,23 @@ package body Exp_Ch5 is
Insert_Action (N,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Iterator,
- Subtype_Mark => New_Occurrence_Of (Iter_Type, Loc),
- Name => Relocate_Node (Name (I_Spec))));
+ Subtype_Mark => New_Occurrence_Of (Iter_Type, Loc),
+ Name => Relocate_Node (Name (I_Spec))));
-- Create declaration for cursor
declare
Cursor_Decl : constant Node_Id :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Cursor,
- Object_Definition =>
- New_Occurrence_Of (Etype (Cursor), Loc),
- Expression =>
- Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Iterator, Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Init)));
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Cursor,
+ Object_Definition =>
+ New_Occurrence_Of (Etype (Cursor), Loc),
+ Expression =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (Iterator, Loc),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_Init)));
begin
-- The cursor is only modified in expanded code, so it appears
@@ -4000,7 +4227,7 @@ package body Exp_Ch5 is
Set_Assignment_OK (Cursor_Decl);
Insert_Action (N, Cursor_Decl);
- Set_Ekind (Cursor, I_Kind);
+ Set_Ekind (Cursor, Id_Kind);
end;
-- If the range of iteration is given by a function call that returns
@@ -4588,7 +4815,9 @@ package body Exp_Ch5 is
and then not Comp_Asn
and then not No_Ctrl_Actions (N)
and then Tagged_Type_Expansion;
- Tag_Id : Entity_Id;
+ Adj_Call : Node_Id;
+ Fin_Call : Node_Id;
+ Tag_Id : Entity_Id;
begin
-- Finalize the target of the assignment when controlled
@@ -4610,7 +4839,7 @@ package body Exp_Ch5 is
if not Ctrl_Act then
null;
- -- The left hand side is an uninitialized temporary object
+ -- The left-hand side is an uninitialized temporary object
elsif Nkind (L) = N_Type_Conversion
and then Is_Entity_Name (Expression (L))
@@ -4621,10 +4850,14 @@ package body Exp_Ch5 is
null;
else
- Append_To (Res,
+ Fin_Call :=
Make_Final_Call
(Obj_Ref => Duplicate_Subexpr_No_Checks (L),
- Typ => Etype (L)));
+ Typ => Etype (L));
+
+ if Present (Fin_Call) then
+ Append_To (Res, Fin_Call);
+ end if;
end if;
-- Save the Tag in a local variable Tag_Id
@@ -4677,10 +4910,14 @@ package body Exp_Ch5 is
-- init proc since it is an initialization more than an assignment).
if Ctrl_Act then
- Append_To (Res,
+ Adj_Call :=
Make_Adjust_Call
(Obj_Ref => Duplicate_Subexpr_Move_Checks (L),
- Typ => Etype (L)));
+ Typ => Etype (L));
+
+ if Present (Adj_Call) then
+ Append_To (Res, Adj_Call);
+ end if;
end if;
return Res;
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index bdde498306..e9f13319ed 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -42,10 +42,8 @@ with Exp_Dist; use Exp_Dist;
with Exp_Intr; use Exp_Intr;
with Exp_Pakd; use Exp_Pakd;
with Exp_Tss; use Exp_Tss;
-with Exp_Unst; use Exp_Unst;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
-with Ghost; use Ghost;
with Inline; use Inline;
with Lib; use Lib;
with Namet; use Namet;
@@ -59,6 +57,7 @@ with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch12; use Sem_Ch12;
with Sem_Ch13; use Sem_Ch13;
with Sem_Dim; use Sem_Dim;
with Sem_Disp; use Sem_Disp;
@@ -71,7 +70,6 @@ with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
-with Table;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
@@ -79,33 +77,6 @@ with Validsw; use Validsw;
package body Exp_Ch6 is
- -------------------------------------
- -- Table for Unnesting Subprograms --
- -------------------------------------
-
- -- When we expand a subprogram body, if it has nested subprograms and if
- -- we are in Unnest_Subprogram_Mode, then we record the subprogram entity
- -- and the body in this table, to later be passed to Unnest_Subprogram.
-
- -- We need this delaying mechanism, because we have to wait until all
- -- instantiated bodies have been inserted before doing the unnesting.
-
- type Unest_Entry is record
- Ent : Entity_Id;
- -- Entity for subprogram to be unnested
-
- Bod : Node_Id;
- -- Subprogram body to be unnested
- end record;
-
- package Unest_Bodies is new Table.Table (
- Table_Component_Type => Unest_Entry,
- Table_Index_Type => Nat,
- Table_Low_Bound => 1,
- Table_Initial => 100,
- Table_Increment => 200,
- Table_Name => "Unest_Bodies");
-
-----------------------
-- Local Subprograms --
-----------------------
@@ -248,15 +219,15 @@ package body Exp_Ch6 is
-- reference to the object itself, and the call becomes a call to the
-- corresponding protected subprogram.
- function Has_Unconstrained_Access_Discriminants
- (Subtyp : Entity_Id) return Boolean;
- -- Returns True if the given subtype is unconstrained and has one
- -- or more access discriminants.
-
procedure Expand_Simple_Function_Return (N : Node_Id);
-- Expand simple return from function. In the case where we are returning
-- from a function body this is called by Expand_N_Simple_Return_Statement.
+ function Has_Unconstrained_Access_Discriminants
+ (Subtyp : Entity_Id) return Boolean;
+ -- Returns True if the given subtype is unconstrained and has one or more
+ -- access discriminants.
+
procedure Rewrite_Function_Call_For_C (N : Node_Id);
-- When generating C code, replace a call to a function that returns an
-- array into the generated procedure with an additional out parameter.
@@ -450,11 +421,7 @@ package body Exp_Ch6 is
if Ekind (Ptr_Typ) = E_Anonymous_Access_Type
and then No (Finalization_Master (Ptr_Typ))
then
- Build_Finalization_Master
- (Typ => Ptr_Typ,
- For_Anonymous => True,
- Context_Scope => Scope (Ptr_Typ),
- Insertion_Node => Associated_Node_For_Itype (Ptr_Typ));
+ Build_Anonymous_Master (Ptr_Typ);
end if;
-- Access-to-controlled types should always have a master
@@ -622,17 +589,22 @@ package body Exp_Ch6 is
function BIP_Formal_Suffix (Kind : BIP_Formal_Kind) return String is
begin
case Kind is
- when BIP_Alloc_Form =>
+ when BIP_Alloc_Form =>
return "BIPalloc";
- when BIP_Storage_Pool =>
+
+ when BIP_Storage_Pool =>
return "BIPstoragepool";
+
when BIP_Finalization_Master =>
return "BIPfinalizationmaster";
- when BIP_Task_Master =>
+
+ when BIP_Task_Master =>
return "BIPtaskmaster";
- when BIP_Activation_Chain =>
+
+ when BIP_Activation_Chain =>
return "BIPactivationchain";
- when BIP_Object_Access =>
+
+ when BIP_Object_Access =>
return "BIPaccess";
end case;
end BIP_Formal_Suffix;
@@ -720,6 +692,44 @@ package body Exp_Ch6 is
end loop;
end;
+ elsif Nkind (Stmt) = N_Extended_Return_Statement then
+ declare
+ Ret_Obj : constant Entity_Id :=
+ Defining_Entity
+ (First (Return_Object_Declarations (Stmt)));
+ Assign : constant Node_Id :=
+ Make_Assignment_Statement (Sloc (Stmt),
+ Name =>
+ New_Occurrence_Of (Param_Id, Loc),
+ Expression =>
+ New_Occurrence_Of (Ret_Obj, Sloc (Stmt)));
+ Stmts : List_Id;
+
+ begin
+ -- The extended return may just contain the declaration
+
+ if Present (Handled_Statement_Sequence (Stmt)) then
+ Stmts := Statements (Handled_Statement_Sequence (Stmt));
+ else
+ Stmts := New_List;
+ end if;
+
+ Set_Assignment_OK (Name (Assign));
+
+ Rewrite (Stmt,
+ Make_Block_Statement (Sloc (Stmt),
+ Declarations =>
+ Return_Object_Declarations (Stmt),
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stmts)));
+
+ Replace_Returns (Param_Id, Stmts);
+
+ Append_To (Stmts, Assign);
+ Append_To (Stmts, Make_Simple_Return_Statement (Loc));
+ end;
+
elsif Nkind (Stmt) = N_If_Statement then
Replace_Returns (Param_Id, Then_Statements (Stmt));
Replace_Returns (Param_Id, Else_Statements (Stmt));
@@ -729,7 +739,7 @@ package body Exp_Ch6 is
begin
Part := First (Elsif_Parts (Stmt));
while Present (Part) loop
- Replace_Returns (Part, Then_Statements (Part));
+ Replace_Returns (Param_Id, Then_Statements (Part));
Next (Part);
end loop;
end;
@@ -796,6 +806,11 @@ package body Exp_Ch6 is
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts));
+ -- If the function is a generic instance, so is the new procedure.
+ -- Set flag accordingly so that the proper renaming declarations are
+ -- generated.
+
+ Set_Is_Generic_Instance (Proc_Id, Is_Generic_Instance (Func_Id));
return New_Body;
end Build_Procedure_Body_Form;
@@ -1183,14 +1198,14 @@ package body Exp_Ch6 is
---------------------------
procedure Add_Call_By_Copy_Code is
+ Crep : Boolean;
Expr : Node_Id;
+ F_Typ : Entity_Id := Etype (Formal);
+ Indic : Node_Id;
Init : Node_Id;
Temp : Entity_Id;
- Indic : Node_Id;
- Var : Entity_Id;
- F_Typ : constant Entity_Id := Etype (Formal);
V_Typ : Entity_Id;
- Crep : Boolean;
+ Var : Entity_Id;
begin
if not Is_Legal_Copy then
@@ -1199,6 +1214,14 @@ package body Exp_Ch6 is
Temp := Make_Temporary (Loc, 'T', Actual);
+ -- Handle formals whose type comes from the limited view
+
+ if From_Limited_With (F_Typ)
+ and then Has_Non_Limited_View (F_Typ)
+ then
+ F_Typ := Non_Limited_View (F_Typ);
+ end if;
+
-- Use formal type for temp, unless formal type is an unconstrained
-- array, in which case we don't have to worry about bounds checks,
-- and we use the actual type, since that has appropriate bounds.
@@ -1206,7 +1229,7 @@ package body Exp_Ch6 is
if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then
Indic := New_Occurrence_Of (Etype (Actual), Loc);
else
- Indic := New_Occurrence_Of (Etype (Formal), Loc);
+ Indic := New_Occurrence_Of (F_Typ, Loc);
end if;
if Nkind (Actual) = N_Type_Conversion then
@@ -1458,20 +1481,28 @@ package body Exp_Ch6 is
----------------------------------
procedure Add_Simple_Call_By_Copy_Code is
- Temp : Entity_Id;
Decl : Node_Id;
+ F_Typ : Entity_Id := Etype (Formal);
Incod : Node_Id;
- Outcod : Node_Id;
+ Indic : Node_Id;
Lhs : Node_Id;
+ Outcod : Node_Id;
Rhs : Node_Id;
- Indic : Node_Id;
- F_Typ : constant Entity_Id := Etype (Formal);
+ Temp : Entity_Id;
begin
if not Is_Legal_Copy then
return;
end if;
+ -- Handle formals whose type comes from the limited view
+
+ if From_Limited_With (F_Typ)
+ and then Has_Non_Limited_View (F_Typ)
+ then
+ F_Typ := Non_Limited_View (F_Typ);
+ end if;
+
-- Use formal type for temp, unless formal type is an unconstrained
-- array, in which case we don't have to worry about bounds checks,
-- and we use the actual type, since that has appropriate bounds.
@@ -1479,7 +1510,7 @@ package body Exp_Ch6 is
if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then
Indic := New_Occurrence_Of (Etype (Actual), Loc);
else
- Indic := New_Occurrence_Of (Etype (Formal), Loc);
+ Indic := New_Occurrence_Of (F_Typ, Loc);
end if;
-- Prepare to generate code
@@ -1502,7 +1533,7 @@ package body Exp_Ch6 is
if Ekind (Formal) = E_Out_Parameter then
Incod := Empty;
- if Has_Discriminants (Etype (Formal)) then
+ if Has_Discriminants (F_Typ) then
Indic := New_Occurrence_Of (Etype (Actual), Loc);
end if;
@@ -1704,6 +1735,14 @@ package body Exp_Ch6 is
E_Formal := Etype (Formal);
E_Actual := Etype (Actual);
+ -- Handle formals whose type comes from the limited view
+
+ if From_Limited_With (E_Formal)
+ and then Has_Non_Limited_View (E_Formal)
+ then
+ E_Formal := Non_Limited_View (E_Formal);
+ end if;
+
if Is_Scalar_Type (E_Formal)
or else Nkind (Actual) = N_Slice
then
@@ -1799,7 +1838,7 @@ package body Exp_Ch6 is
then
Add_Call_By_Copy_Code;
- -- References to components of bit packed arrays are expanded
+ -- References to components of bit-packed arrays are expanded
-- at this point, rather than at the point of analysis of the
-- actuals, to handle the expansion of the assignment to
-- [in] out parameters.
@@ -1823,7 +1862,7 @@ package body Exp_Ch6 is
then
Add_Simple_Call_By_Copy_Code;
- -- References to slices of bit packed arrays are expanded
+ -- References to slices of bit-packed arrays are expanded
elsif Is_Ref_To_Bit_Packed_Slice (Actual) then
Add_Call_By_Copy_Code;
@@ -2003,7 +2042,7 @@ package body Exp_Ch6 is
-- Processing for IN parameters
else
- -- For IN parameters is in the packed array case, we expand an
+ -- For IN parameters in the bit-packed array case, we expand an
-- indexed component (the circuit in Exp_Ch4 deliberately left
-- indexed components appearing as actuals untouched, so that
-- the special processing above for the OUT and IN OUT cases
@@ -2012,12 +2051,12 @@ package body Exp_Ch6 is
-- easier simply to handle all cases here.)
if Nkind (Actual) = N_Indexed_Component
- and then Is_Packed (Etype (Prefix (Actual)))
+ and then Is_Bit_Packed_Array (Etype (Prefix (Actual)))
then
Reset_Packed_Prefix;
Expand_Packed_Element_Reference (Actual);
- -- If we have a reference to a bit packed array, we copy it, since
+ -- If we have a reference to a bit-packed array, we copy it, since
-- the actual must be byte aligned.
-- Is this really necessary in all cases???
@@ -2073,10 +2112,13 @@ package body Exp_Ch6 is
if not Is_Empty_List (Post_Call) then
- -- Cases where the call is not a member of a statement list
-
- if not Is_List_Member (N) then
+ -- Cases where the call is not a member of a statement list.
+ -- This includes the case where the call is an actual in another
+ -- function call or indexing, i.e. an expression context as well.
+ if not Is_List_Member (N)
+ or else Nkind_In (Parent (N), N_Function_Call, N_Indexed_Component)
+ then
-- In Ada 2012 the call may be a function call in an expression
-- (since OUT and IN OUT parameters are now allowed for such
-- calls). The write-back of (in)-out parameters is handled
@@ -2226,6 +2268,12 @@ package body Exp_Ch6 is
-- expression for the value of the actual, EF is the entity for the
-- extra formal.
+ procedure Add_View_Conversion_Invariants
+ (Formal : Entity_Id;
+ Actual : Node_Id);
+ -- Adds invariant checks for every intermediate type between the range
+ -- of a view converted argument to its ancestor (from parent to child).
+
function Inherited_From_Formal (S : Entity_Id) return Entity_Id;
-- Within an instance, a type derived from an untagged formal derived
-- type inherits from the original parent, not from the actual. The
@@ -2312,6 +2360,64 @@ package body Exp_Ch6 is
end if;
end Add_Extra_Actual;
+ ------------------------------------
+ -- Add_View_Conversion_Invariants --
+ ------------------------------------
+
+ procedure Add_View_Conversion_Invariants
+ (Formal : Entity_Id;
+ Actual : Node_Id)
+ is
+ Arg : Entity_Id;
+ Curr_Typ : Entity_Id;
+ Inv_Checks : List_Id;
+ Par_Typ : Entity_Id;
+
+ begin
+ Inv_Checks := No_List;
+
+ -- Extract the argument from a potentially nested set of view
+ -- conversions.
+
+ Arg := Actual;
+ while Nkind (Arg) = N_Type_Conversion loop
+ Arg := Expression (Arg);
+ end loop;
+
+ -- Move up the derivation chain starting with the type of the formal
+ -- parameter down to the type of the actual object.
+
+ Curr_Typ := Empty;
+ Par_Typ := Etype (Arg);
+ while Par_Typ /= Etype (Formal) and Par_Typ /= Curr_Typ loop
+ Curr_Typ := Par_Typ;
+
+ if Has_Invariants (Curr_Typ)
+ and then Present (Invariant_Procedure (Curr_Typ))
+ then
+ -- Verify the invariate of the current type. Generate:
+
+ -- <Curr_Typ>Invariant (Curr_Typ (Arg));
+
+ Prepend_New_To (Inv_Checks,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Invariant_Procedure (Curr_Typ), Loc),
+ Parameter_Associations => New_List (
+ Make_Type_Conversion (Loc,
+ Subtype_Mark => New_Occurrence_Of (Curr_Typ, Loc),
+ Expression => New_Copy_Tree (Arg)))));
+ end if;
+
+ Par_Typ := Base_Type (Etype (Curr_Typ));
+ end loop;
+
+ if not Is_Empty_List (Inv_Checks) then
+ Insert_Actions_After (N, Inv_Checks);
+ end if;
+ end Add_View_Conversion_Invariants;
+
---------------------------
-- Inherited_From_Formal --
---------------------------
@@ -2486,7 +2592,7 @@ package body Exp_Ch6 is
-- Local variables
- Remote : constant Boolean := Is_Remote_Call (Call_Node);
+ Remote : constant Boolean := Is_Remote_Call (Call_Node);
Actual : Node_Id;
Formal : Entity_Id;
Orig_Subp : Entity_Id := Empty;
@@ -2637,8 +2743,24 @@ package body Exp_Ch6 is
if Modify_Tree_For_C
and then Nkind (Call_Node) = N_Function_Call
and then Is_Entity_Name (Name (Call_Node))
- and then Rewritten_For_C (Entity (Name (Call_Node)))
+ and then Rewritten_For_C (Ultimate_Alias (Entity (Name (Call_Node))))
then
+ -- For internally generated calls ensure that they reference the
+ -- entity of the spec of the called function (needed since the
+ -- expander may generate calls using the entity of their body).
+ -- See for example Expand_Boolean_Operator().
+
+ if not (Comes_From_Source (Call_Node))
+ and then Nkind (Unit_Declaration_Node
+ (Ultimate_Alias (Entity (Name (Call_Node))))) =
+ N_Subprogram_Body
+ then
+ Set_Entity (Name (Call_Node),
+ Corresponding_Function
+ (Corresponding_Procedure
+ (Ultimate_Alias (Entity (Name (Call_Node))))));
+ end if;
+
Rewrite_Function_Call_For_C (Call_Node);
return;
end if;
@@ -2710,10 +2832,12 @@ package body Exp_Ch6 is
CW_Interface_Formals_Present :=
CW_Interface_Formals_Present
or else
- (Ekind (Etype (Formal)) = E_Class_Wide_Type
+ (Is_Class_Wide_Type (Etype (Formal))
and then Is_Interface (Etype (Etype (Formal))))
or else
(Ekind (Etype (Formal)) = E_Anonymous_Access_Type
+ and then Is_Class_Wide_Type (Directly_Designated_Type
+ (Etype (Etype (Formal))))
and then Is_Interface (Directly_Designated_Type
(Etype (Etype (Formal)))));
@@ -2919,7 +3043,6 @@ package body Exp_Ch6 is
else
case Nkind (Prev_Orig) is
-
when N_Attribute_Reference =>
case Get_Attribute_Id (Attribute_Name (Prev_Orig)) is
@@ -2963,8 +3086,9 @@ package body Exp_Ch6 is
-- Treat the unchecked attributes as library-level
- when Attribute_Unchecked_Access |
- Attribute_Unrestricted_Access =>
+ when Attribute_Unchecked_Access
+ | Attribute_Unrestricted_Access
+ =>
Add_Extra_Actual
(Make_Integer_Literal (Loc,
Intval => Scope_Depth (Standard_Standard)),
@@ -3179,6 +3303,31 @@ package body Exp_Ch6 is
Duplicate_Subexpr_Move_Checks (Actual)));
end if;
+ -- Perform invariant checks for all intermediate types in a view
+ -- conversion after successful return from a call that passes the
+ -- view conversion as an IN OUT or OUT parameter (RM 7.3.2 (12/3,
+ -- 13/3, 14/3)). Consider only source conversion in order to avoid
+ -- generating spurious checks on complex expansion such as object
+ -- initialization through an extension aggregate.
+
+ if Comes_From_Source (N)
+ and then Ekind (Formal) /= E_In_Parameter
+ and then Nkind (Actual) = N_Type_Conversion
+ then
+ Add_View_Conversion_Invariants (Formal, Actual);
+ end if;
+
+ -- Generating C the initialization of an allocator is performed by
+ -- means of individual statements, and hence it must be done before
+ -- the call.
+
+ if Modify_Tree_For_C
+ and then Nkind (Actual) = N_Allocator
+ and then Nkind (Expression (Actual)) = N_Qualified_Expression
+ then
+ Remove_Side_Effects (Actual);
+ end if;
+
-- This label is required when skipping extra actual generation for
-- Unchecked_Union parameters.
@@ -3236,7 +3385,9 @@ package body Exp_Ch6 is
Defer := True;
- when N_Object_Declaration | N_Object_Renaming_Declaration =>
+ when N_Object_Declaration
+ | N_Object_Renaming_Declaration
+ =>
declare
Def_Id : constant Entity_Id :=
Defining_Identifier (Ancestor);
@@ -3273,8 +3424,8 @@ package body Exp_Ch6 is
Level :=
New_Occurrence_Of
(Extra_Accessibility_Of_Result
- (Return_Applies_To
- (Return_Statement_Entity (Ancestor))), Loc);
+ (Return_Applies_To
+ (Return_Statement_Entity (Ancestor))), Loc);
end if;
when others =>
@@ -3291,8 +3442,9 @@ package body Exp_Ch6 is
-- calls to subps whose enclosing scope is unknown (e.g.,
-- Anon_Access_To_Subp_Param.all)?
- Level := Make_Integer_Literal (Loc,
- Scope_Depth (Current_Scope) + 1);
+ Level :=
+ Make_Integer_Literal (Loc,
+ Intval => Scope_Depth (Current_Scope) + 1);
end if;
Add_Extra_Actual
@@ -3706,7 +3858,7 @@ package body Exp_Ch6 is
Make_Explicit_Dereference (Loc,
Prefix => Nam);
- if Present (Parameter_Associations (Call_Node)) then
+ if Present (Parameter_Associations (Call_Node)) then
Parm := Parameter_Associations (Call_Node);
else
Parm := New_List;
@@ -3770,16 +3922,13 @@ package body Exp_Ch6 is
if Ekind_In (Subp, E_Function, E_Procedure) then
- -- We perform two simple optimization on calls:
-
- -- a) replace calls to null procedures unconditionally;
-
- -- b) for To_Address, just do an unchecked conversion. Not only is
- -- this efficient, but it also avoids order of elaboration problems
- -- when address clauses are inlined (address expression elaborated
+ -- We perform a simple optimization on calls for To_Address by
+ -- replacing them with an unchecked conversion. Not only is this
+ -- efficient, but it also avoids order of elaboration problems when
+ -- address clauses are inlined (address expression elaborated at the
-- at the wrong point).
- -- We perform these optimization regardless of whether we are in the
+ -- We perform this optimization regardless of whether we are in the
-- main unit or in a unit in the context of the main unit, to ensure
-- that tree generated is the same in both cases, for CodePeer use.
@@ -3788,10 +3937,6 @@ package body Exp_Ch6 is
Unchecked_Convert_To
(RTE (RE_Address), Relocate_Node (First_Actual (Call_Node))));
return;
-
- elsif Is_Null_Procedure (Subp) then
- Rewrite (Call_Node, Make_Null_Statement (Loc));
- return;
end if;
-- Handle inlining. No action needed if the subprogram is not inlined
@@ -3799,6 +3944,14 @@ package body Exp_Ch6 is
if not Is_Inlined (Subp) then
null;
+ -- Frontend inlining of expression functions (performed also when
+ -- backend inlining is enabled).
+
+ elsif Is_Inlinable_Expression_Function (Subp) then
+ Rewrite (N, New_Copy (Expression_Of_Expression_Function (Subp)));
+ Analyze (N);
+ return;
+
-- Handle frontend inlining
elsif not Back_End_Inlining then
@@ -3862,6 +4015,14 @@ package body Exp_Ch6 is
and then In_Package_Body
then
Must_Inline := not In_Extended_Main_Source_Unit (Subp);
+
+ -- Inline calls to _postconditions when generating C code
+
+ elsif Modify_Tree_For_C
+ and then In_Same_Extended_Unit (Sloc (Bod), Loc)
+ and then Chars (Name (N)) = Name_uPostconditions
+ then
+ Must_Inline := True;
end if;
end if;
@@ -3898,6 +4059,66 @@ package body Exp_Ch6 is
then
Add_Inlined_Body (Subp, Call_Node);
+ -- If the inlined call appears within an instantiation and some
+ -- level of optimization is required, ensure that the enclosing
+ -- instance body is available so that the back-end can actually
+ -- perform the inlining.
+
+ if In_Instance
+ and then Comes_From_Source (Subp)
+ and then Optimization_Level > 0
+ then
+ declare
+ Decl : Node_Id;
+ Inst : Entity_Id;
+ Inst_Node : Node_Id;
+
+ begin
+ Inst := Scope (Subp);
+
+ -- Find enclosing instance
+
+ while Present (Inst) and then Inst /= Standard_Standard loop
+ exit when Is_Generic_Instance (Inst);
+ Inst := Scope (Inst);
+ end loop;
+
+ if Present (Inst)
+ and then Is_Generic_Instance (Inst)
+ and then not Is_Inlined (Inst)
+ then
+ Set_Is_Inlined (Inst);
+ Decl := Unit_Declaration_Node (Inst);
+
+ -- Do not add a pending instantiation if the body exits
+ -- already, or if the instance is a compilation unit, or
+ -- the instance node is missing.
+
+ if Present (Corresponding_Body (Decl))
+ or else Nkind (Parent (Decl)) = N_Compilation_Unit
+ or else No (Next (Decl))
+ then
+ null;
+
+ else
+ -- The instantiation node usually follows the package
+ -- declaration for the instance. If the generic unit
+ -- has aspect specifications, they are transformed
+ -- into pragmas in the instance, and the instance node
+ -- appears after them.
+
+ Inst_Node := Next (Decl);
+
+ while Nkind (Inst_Node) /= N_Package_Instantiation loop
+ Inst_Node := Next (Inst_Node);
+ end loop;
+
+ Add_Pending_Instantiation (Inst_Node, Decl);
+ end if;
+ end if;
+ end;
+ end if;
+
-- Front end expansion of simple functions returning unconstrained
-- types (see Check_And_Split_Unconstrained_Function). Note that the
-- case of a simple renaming (Body_To_Inline in N_Entity above, see
@@ -3993,10 +4214,6 @@ package body Exp_Ch6 is
and then Present (Generalized_Indexing (Ref));
end Is_Element_Reference;
- -- Local variables
-
- Is_Elem_Ref : constant Boolean := Is_Element_Reference (N);
-
-- Start of processing for Expand_Ctrl_Function_Call
begin
@@ -4020,20 +4237,24 @@ package body Exp_Ch6 is
Remove_Side_Effects (N);
- -- When the temporary function result appears inside a case expression
- -- or an if expression, its lifetime must be extended to match that of
- -- the context. If not, the function result will be finalized too early
- -- and the evaluation of the expression could yield incorrect result. An
- -- exception to this rule are references to Ada 2012 container elements.
+ -- The side effect removal of the function call produced a temporary.
+ -- When the context is a case expression, if expression, or expression
+ -- with actions, the lifetime of the temporary must be extended to match
+ -- that of the context. Otherwise the function result will be finalized
+ -- too early and affect the result of the expression. To prevent this
+ -- unwanted effect, the temporary should not be considered for clean up
+ -- actions by the general finalization machinery.
+
+ -- Exception to this rule are references to Ada 2012 container elements.
-- Such references must be finalized at the end of each iteration of the
-- related quantified expression, otherwise the container will remain
-- busy.
- if not Is_Elem_Ref
+ if Nkind (N) = N_Explicit_Dereference
and then Within_Case_Or_If_Expression (N)
- and then Nkind (N) = N_Explicit_Dereference
+ and then not Is_Element_Reference (N)
then
- Set_Is_Processed_Transient (Entity (Prefix (N)));
+ Set_Is_Ignored_Transient (Entity (Prefix (N)));
end if;
end Expand_Ctrl_Function_Call;
@@ -4988,17 +5209,8 @@ package body Exp_Ch6 is
---------------------------------------
procedure Expand_N_Procedure_Call_Statement (N : Node_Id) is
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
-
begin
- -- The procedure call is Ghost when the name is Ghost. Set the mode now
- -- to ensure that any nodes generated during expansion are properly set
- -- as Ghost.
-
- Set_Ghost_Mode (N);
-
Expand_Call (N);
- Ghost_Mode := Save_Ghost_Mode;
end Expand_N_Procedure_Call_Statement;
--------------------------------------
@@ -5020,16 +5232,17 @@ package body Exp_Ch6 is
-- Distinguish the function and non-function cases:
case Ekind (Return_Applies_To (Return_Statement_Entity (N))) is
-
- when E_Function |
- E_Generic_Function =>
+ when E_Function
+ | E_Generic_Function
+ =>
Expand_Simple_Function_Return (N);
- when E_Procedure |
- E_Generic_Procedure |
- E_Entry |
- E_Entry_Family |
- E_Return_Statement =>
+ when E_Entry
+ | E_Entry_Family
+ | E_Generic_Procedure
+ | E_Procedure
+ | E_Return_Statement
+ =>
Expand_Non_Function_Return (N);
when others =>
@@ -5158,8 +5371,6 @@ package body Exp_Ch6 is
-- Local variables
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
-
Except_H : Node_Id;
L : List_Id;
Spec_Id : Entity_Id;
@@ -5190,13 +5401,6 @@ package body Exp_Ch6 is
end if;
end if;
- -- The subprogram body is Ghost when it is stand alone and subject to
- -- pragma Ghost or the corresponding spec is Ghost. To accomodate both
- -- cases, set the mode now to ensure that any nodes generated during
- -- expansion are marked as Ghost.
-
- Set_Ghost_Mode (N, Spec_Id);
-
-- Set L to either the list of declarations if present, or to the list
-- of statements if no declarations are present. This is used to insert
-- new stuff at the start.
@@ -5318,7 +5522,6 @@ package body Exp_Ch6 is
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Make_Null_Statement (Loc))));
- Ghost_Mode := Save_Ghost_Mode;
return;
end if;
end if;
@@ -5341,13 +5544,7 @@ package body Exp_Ch6 is
Utyp : constant Entity_Id := Underlying_Type (Typ);
begin
- if not Acts_As_Spec (N)
- and then Nkind (Parent (Parent (Spec_Id))) /=
- N_Subprogram_Body_Stub
- then
- null;
-
- elsif Is_Limited_View (Typ) then
+ if Is_Limited_View (Typ) then
Set_Returns_By_Ref (Spec_Id);
elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
@@ -5431,30 +5628,6 @@ package body Exp_Ch6 is
-- Set to encode entity names in package body before gigi is called
Qualify_Entity_Names (N);
-
- -- If we are unnesting procedures, and this is an outer level procedure
- -- with nested subprograms, do the unnesting operation now.
-
- if Opt.Unnest_Subprogram_Mode
-
- -- We are only interested in subprograms (not generic subprograms)
-
- and then Is_Subprogram (Spec_Id)
-
- -- Only deal with outer level subprograms. Nested subprograms are
- -- handled as part of dealing with the outer level subprogram in
- -- which they are nested.
-
- and then Enclosing_Subprogram (Spec_Id) = Empty
-
- -- We are only interested in subprograms that have nested subprograms
-
- and then Has_Nested_Subprogram (Spec_Id)
- then
- Unest_Bodies.Append ((Spec_Id, N));
- end if;
-
- Ghost_Mode := Save_Ghost_Mode;
end Expand_N_Subprogram_Body;
-----------------------------------
@@ -5462,10 +5635,24 @@ package body Exp_Ch6 is
-----------------------------------
procedure Expand_N_Subprogram_Body_Stub (N : Node_Id) is
+ Bod : Node_Id;
+
begin
if Present (Corresponding_Body (N)) then
- Expand_N_Subprogram_Body (
- Unit_Declaration_Node (Corresponding_Body (N)));
+ Bod := Unit_Declaration_Node (Corresponding_Body (N));
+
+ -- The body may have been expanded already when it is analyzed
+ -- through the subunit node. Do no expand again: it interferes
+ -- with the construction of unnesting tables when generating C.
+
+ if not Analyzed (Bod) then
+ Expand_N_Subprogram_Body (Bod);
+ end if;
+
+ -- Add full qualification to entities that may be created late
+ -- during unnesting.
+
+ Qualify_Entity_Names (N);
end if;
end Expand_N_Subprogram_Body_Stub;
@@ -5484,64 +5671,6 @@ package body Exp_Ch6 is
Loc : constant Source_Ptr := Sloc (N);
Subp : constant Entity_Id := Defining_Entity (N);
- procedure Build_Procedure_Form;
- -- Create a procedure declaration which emulates the behavior of
- -- function Subp, for C-compatible generation.
-
- --------------------------
- -- Build_Procedure_Form --
- --------------------------
-
- procedure Build_Procedure_Form is
- Func_Formal : Entity_Id;
- Proc_Formals : List_Id;
-
- begin
- Proc_Formals := New_List;
-
- -- Create a list of formal parameters with the same types as the
- -- function.
-
- Func_Formal := First_Formal (Subp);
- while Present (Func_Formal) loop
- Append_To (Proc_Formals,
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Chars (Func_Formal)),
- Parameter_Type =>
- New_Occurrence_Of (Etype (Func_Formal), Loc)));
-
- Next_Formal (Func_Formal);
- end loop;
-
- -- Add an extra out parameter to carry the function result
-
- Name_Len := 6;
- Name_Buffer (1 .. Name_Len) := "RESULT";
- Append_To (Proc_Formals,
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Chars => Name_Find),
- Out_Present => True,
- Parameter_Type => New_Occurrence_Of (Etype (Subp), Loc)));
-
- -- The new procedure declaration is inserted immediately after the
- -- function declaration. The processing in Build_Procedure_Body_Form
- -- relies on this order.
-
- Insert_After_And_Analyze (N,
- Make_Subprogram_Declaration (Loc,
- Specification =>
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, Chars (Subp)),
- Parameter_Specifications => Proc_Formals)));
-
- -- Mark the function as having a procedure form
-
- Set_Rewritten_For_C (Subp);
- end Build_Procedure_Form;
-
-- Local variables
Scop : constant Entity_Id := Scope (Subp);
@@ -5562,7 +5691,7 @@ package body Exp_Ch6 is
elsif Present (Next (N))
and then Nkind (Next (N)) = N_Pragma
- and then Get_Pragma_Id (Pragma_Name (Next (N))) = Pragma_Import
+ and then Get_Pragma_Id (Next (N)) = Pragma_Import
then
-- In SPARK, subprogram declarations are also permitted in
-- declarative parts when immediately followed by a corresponding
@@ -5667,7 +5796,7 @@ package body Exp_Ch6 is
and then Is_Constrained (Etype (Subp))
and then not Is_Unchecked_Conversion_Instance (Subp)
then
- Build_Procedure_Form;
+ Build_Procedure_Form (N);
end if;
end Expand_N_Subprogram_Declaration;
@@ -5887,7 +6016,13 @@ package body Exp_Ch6 is
Subp : Entity_Id;
Scop : Entity_Id)
is
- Rec : Node_Id;
+ Rec : Node_Id;
+
+ procedure Expand_Internal_Init_Call;
+ -- A call to an operation of the type may occur in the initialization
+ -- of a private component. In that case the prefix of the call is an
+ -- entity name and the call is treated as internal even though it
+ -- appears in code outside of the protected type.
procedure Freeze_Called_Function;
-- If it is a function call it can appear in elaboration code and
@@ -5896,6 +6031,31 @@ package body Exp_Ch6 is
-- to something other than a call (e.g. a temporary initialized in a
-- transient block).
+ -------------------------------
+ -- Expand_Internal_Init_Call --
+ -------------------------------
+
+ procedure Expand_Internal_Init_Call is
+ begin
+ -- If the context is a protected object (rather than a protected
+ -- type) the call itself is bound to raise program_error because
+ -- the protected body will not have been elaborated yet. This is
+ -- diagnosed subsequently in Sem_Elab.
+
+ Freeze_Called_Function;
+
+ -- The target of the internal call is the first formal of the
+ -- enclosing initialization procedure.
+
+ Rec := New_Occurrence_Of (First_Formal (Current_Scope), Sloc (N));
+ Build_Protected_Subprogram_Call (N,
+ Name => Name (N),
+ Rec => Rec,
+ External => False);
+ Analyze (N);
+ Resolve (N, Etype (Subp));
+ end Expand_Internal_Init_Call;
+
----------------------------
-- Freeze_Called_Function --
----------------------------
@@ -5915,18 +6075,43 @@ package body Exp_Ch6 is
-- Exp_Ch9.Build_Simple_Entry_Call. The call is intra-object only if the
-- subprogram being called is in the protected body being compiled, and
-- if the protected object in the call is statically the enclosing type.
- -- The object may be an component of some other data structure, in which
+ -- The object may be a component of some other data structure, in which
-- case this must be handled as an inter-object call.
if not In_Open_Scopes (Scop)
+ or else Is_Entry_Wrapper (Current_Scope)
or else not Is_Entity_Name (Name (N))
then
if Nkind (Name (N)) = N_Selected_Component then
Rec := Prefix (Name (N));
- else
- pragma Assert (Nkind (Name (N)) = N_Indexed_Component);
+ elsif Nkind (Name (N)) = N_Indexed_Component then
Rec := Prefix (Prefix (Name (N)));
+
+ -- If this is a call within an entry wrapper, it appears within a
+ -- precondition that calls another primitive of the synchronized
+ -- type. The target object of the call is the first actual on the
+ -- wrapper. Note that this is an external call, because the wrapper
+ -- is called outside of the synchronized object. This means that
+ -- an entry call to an entry with preconditions involves two
+ -- synchronized operations.
+
+ elsif Ekind (Current_Scope) = E_Procedure
+ and then Is_Entry_Wrapper (Current_Scope)
+ then
+ Rec := New_Occurrence_Of (First_Entity (Current_Scope), Sloc (N));
+
+ else
+ -- If the context is the initialization procedure for a protected
+ -- type, the call is legal because the called entity must be a
+ -- function of that enclosing type, and this is treated as an
+ -- internal call.
+
+ pragma Assert
+ (Is_Entity_Name (Name (N)) and then Inside_Init_Proc);
+
+ Expand_Internal_Init_Call;
+ return;
end if;
Freeze_Called_Function;
@@ -5947,7 +6132,6 @@ package body Exp_Ch6 is
Name => Name (N),
Rec => Rec,
External => False);
-
end if;
-- Analyze and resolve the new call. The actuals have already been
@@ -6568,7 +6752,6 @@ package body Exp_Ch6 is
case Nkind (Discrim_Source) is
when N_Defining_Identifier =>
-
pragma Assert (Is_Composite_Type (Discrim_Source)
and then Has_Discriminants (Discrim_Source)
and then Is_Constrained (Discrim_Source));
@@ -6594,8 +6777,9 @@ package body Exp_Ch6 is
end loop;
end;
- when N_Aggregate | N_Extension_Aggregate =>
-
+ when N_Aggregate
+ | N_Extension_Aggregate
+ =>
-- Unimplemented: extension aggregate case where discrims
-- come from ancestor part, not extension part.
@@ -6690,7 +6874,6 @@ package body Exp_Ch6 is
null;
when others =>
-
declare
Level : constant Node_Id :=
Make_Integer_Literal (Loc,
@@ -6708,7 +6891,6 @@ package body Exp_Ch6 is
Set_Etype (Level, Standard_Natural);
Check_Against_Result_Level (Level);
end;
-
end case;
end;
end if;
@@ -6757,7 +6939,7 @@ package body Exp_Ch6 is
-- once in the call to _Postconditions, and once in the actual return
-- statement, but we can't have side effects happening twice.
- Remove_Side_Effects (Exp);
+ Force_Evaluation (Exp, Mode => Strict);
-- Generate call to _Postconditions
@@ -6810,15 +6992,6 @@ package body Exp_Ch6 is
return False;
end Has_Unconstrained_Access_Discriminants;
- ----------------
- -- Initialize --
- ----------------
-
- procedure Initialize is
- begin
- Unest_Bodies.Init;
- end Initialize;
-
--------------------------------
-- Is_Build_In_Place_Function --
--------------------------------
@@ -7099,9 +7272,11 @@ package body Exp_Ch6 is
declare
Typ : constant Entity_Id := Etype (Subp);
Utyp : constant Entity_Id := Underlying_Type (Typ);
+
begin
if Is_Limited_View (Typ) then
Set_Returns_By_Ref (Subp);
+
elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
Set_Returns_By_Ref (Subp);
end if;
@@ -7207,6 +7382,7 @@ package body Exp_Ch6 is
if Nkind_In (Func_Call,
N_Qualified_Expression,
+ N_Type_Conversion,
N_Unchecked_Type_Conversion)
then
Func_Call := Expression (Func_Call);
@@ -7426,6 +7602,14 @@ package body Exp_Ch6 is
Return_Obj_Id : Entity_Id;
Return_Obj_Decl : Entity_Id;
+ Definite : Boolean;
+ -- True if result subtype is definite, or has a size that does not
+ -- require secondary stack usage (i.e. no variant part or components
+ -- whose type depends on discriminants). In particular, untagged types
+ -- with only access discriminants do not require secondary stack use.
+ -- Note that if the return type is tagged we must always use the sec.
+ -- stack because the call may dispatch on result.
+
begin
-- Step past qualification, type conversion (which can occur in actual
-- parameter contexts), and unchecked conversion (which can occur in
@@ -7465,6 +7649,10 @@ package body Exp_Ch6 is
end if;
Result_Subt := Etype (Function_Id);
+ Definite :=
+ (Is_Definite_Subtype (Underlying_Type (Result_Subt))
+ and then not Is_Tagged_Type (Result_Subt))
+ or else not Requires_Transient_Scope (Underlying_Type (Result_Subt));
-- If the build-in-place function returns a controlled object, then the
-- object needs to be finalized immediately after the context. Since
@@ -7503,10 +7691,10 @@ package body Exp_Ch6 is
Analyze (Function_Call);
end;
- -- When the result subtype is constrained, an object of the subtype is
+ -- When the result subtype is definite, an object of the subtype is
-- declared and an access value designating it is passed as an actual.
- elsif Is_Constrained (Underlying_Type (Result_Subt)) then
+ elsif Definite then
-- Create a temporary object to hold the function result
@@ -7732,7 +7920,12 @@ package body Exp_Ch6 is
Result_Subt : Entity_Id;
Definite : Boolean;
- -- True for definite function result subtype
+ -- True if result subtype is definite, or has a size that does not
+ -- require secondary stack usage (i.e. no variant part or components
+ -- whose type depends on discriminants). In particular, untagged types
+ -- with only access discriminants do not require secondary stack use.
+ -- Note that if the return type is tagged we must always use the sec.
+ -- stack because the call may dispatch on result.
begin
-- Step past qualification or unchecked conversion (the latter can occur
@@ -7767,7 +7960,10 @@ package body Exp_Ch6 is
end if;
Result_Subt := Etype (Function_Id);
- Definite := Is_Definite_Subtype (Underlying_Type (Result_Subt));
+ Definite :=
+ (Is_Definite_Subtype (Underlying_Type (Result_Subt))
+ and then not Is_Tagged_Type (Result_Subt))
+ or else not Requires_Transient_Scope (Underlying_Type (Result_Subt));
-- Create an access type designating the function's result subtype. We
-- use the type of the original call because it may be a call to an
@@ -8199,9 +8395,20 @@ package body Exp_Ch6 is
pragma Assert (Is_Build_In_Place_Function (Func_Id));
Func_Typ : constant Entity_Id := Underlying_Type (Etype (Func_Id));
begin
+ -- A formal giving the finalization master is needed for build-in-place
+ -- functions whose result type needs finalization or is a tagged type.
+ -- Tagged primitive build-in-place functions need such a formal because
+ -- they can be called by a dispatching call, and extensions may require
+ -- finalization even if the root type doesn't. This means they're also
+ -- needed for tagged nonprimitive build-in-place functions with tagged
+ -- results, since such functions can be called via access-to-function
+ -- types, and those can be used to call primitives, so masters have to
+ -- be passed to all such build-in-place functions, primitive or not.
+
return
not Restriction_Active (No_Finalization)
- and then Needs_Finalization (Func_Typ);
+ and then (Needs_Finalization (Func_Typ)
+ or else Is_Tagged_Type (Func_Typ));
end Needs_BIP_Finalization_Master;
--------------------------
@@ -8346,14 +8553,17 @@ package body Exp_Ch6 is
---------------------------------
procedure Rewrite_Function_Call_For_C (N : Node_Id) is
- Func_Id : constant Entity_Id := Entity (Name (N));
- Func_Decl : constant Node_Id := Unit_Declaration_Node (Func_Id);
+ Orig_Func : constant Entity_Id := Entity (Name (N));
+ Func_Id : constant Entity_Id := Ultimate_Alias (Orig_Func);
Par : constant Node_Id := Parent (N);
- Proc_Id : constant Entity_Id := Defining_Entity (Next (Func_Decl));
+ Proc_Id : constant Entity_Id := Corresponding_Procedure (Func_Id);
Loc : constant Source_Ptr := Sloc (Par);
Actuals : List_Id;
+ Last_Actual : Node_Id;
Last_Formal : Entity_Id;
+ -- Start of processing for Rewrite_Function_Call_For_C
+
begin
-- The actuals may be given by named associations, so the added actual
-- that is the target of the return value of the call must be a named
@@ -8380,12 +8590,25 @@ package body Exp_Ch6 is
-- Proc_Call (..., LHS);
+ -- If function is inherited, a conversion may be necessary.
+
if Nkind (Par) = N_Assignment_Statement then
+ Last_Actual := Name (Par);
+
+ if not Comes_From_Source (Orig_Func)
+ and then Etype (Orig_Func) /= Etype (Func_Id)
+ then
+ Last_Actual :=
+ Make_Type_Conversion (Loc,
+ New_Occurrence_Of (Etype (Func_Id), Loc),
+ Last_Actual);
+ end if;
+
Append_To (Actuals,
Make_Parameter_Association (Loc,
Selector_Name =>
Make_Identifier (Loc, Chars (Last_Formal)),
- Explicit_Actual_Parameter => Name (Par)));
+ Explicit_Actual_Parameter => Last_Actual));
Rewrite (Par,
Make_Procedure_Call_Statement (Loc,
@@ -8478,19 +8701,4 @@ package body Exp_Ch6 is
end loop;
end Set_Enclosing_Sec_Stack_Return;
- ------------------------
- -- Unnest_Subprograms --
- ------------------------
-
- procedure Unnest_Subprograms is
- begin
- for J in Unest_Bodies.First .. Unest_Bodies.Last loop
- declare
- UBJ : Unest_Entry renames Unest_Bodies.Table (J);
- begin
- Unnest_Subprogram (UBJ.Ent, UBJ.Bod);
- end;
- end loop;
- end Unnest_Subprograms;
-
end Exp_Ch6;
diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads
index 7ae19de637..249bf14a10 100644
--- a/gcc/ada/exp_ch6.ads
+++ b/gcc/ada/exp_ch6.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -117,9 +117,6 @@ package Exp_Ch6 is
-- 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 Initialize;
- -- Initialize internal tables
-
function Is_Build_In_Place_Function (E : Entity_Id) return Boolean;
-- Ada 2005 (AI-318-02): Returns True if E denotes a function, generic
-- function, or access-to-function type whose result must be built in
@@ -204,7 +201,9 @@ package Exp_Ch6 is
function Needs_BIP_Finalization_Master (Func_Id : Entity_Id) return Boolean;
-- Ada 2005 (AI-318-02): Return True if the result subtype of function
- -- Func_Id needs finalization actions.
+ -- Func_Id might need finalization actions. This includes build-in-place
+ -- functions with tagged result types, since they can be invoked via
+ -- dispatching calls, and descendant types may require finalization.
function Needs_Result_Accessibility_Level
(Func_Id : Entity_Id) return Boolean;
@@ -212,9 +211,4 @@ package Exp_Ch6 is
-- parameter to identify the accessibility level of the function result
-- "determined by the point of call".
- procedure Unnest_Subprograms;
- -- Called to unnest subprograms. If we are in unnest subprogram mode, and
- -- subprograms have been gathered in the Unest_Bodies table, this is the
- -- call that causes them to be processed for unnesting.
-
end Exp_Ch6;
diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb
index f5b97e2340..93573a29ea 100644
--- a/gcc/ada/exp_ch7.adb
+++ b/gcc/ada/exp_ch7.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -55,12 +55,15 @@ with Sinfo; use Sinfo;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch13; use Sem_Ch13;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Snames; use Snames;
with Stand; use Stand;
+with Stringt; use Stringt;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Uintp; use Uintp;
@@ -301,6 +304,9 @@ package body Exp_Ch7 is
Finalize_Case => TSS_Deep_Finalize,
Address_Case => TSS_Finalize_Address);
+ function Allows_Finalization_Master (Typ : Entity_Id) return Boolean;
+ -- Determine whether access type Typ may have a finalization master
+
procedure Build_Array_Deep_Procs (Typ : Entity_Id);
-- Build the deep Initialize/Adjust/Finalize for a record Typ with
-- Has_Controlled_Component set and store them using the TSS mechanism.
@@ -427,6 +433,327 @@ package body Exp_Ch7 is
-- [Deep_]Finalize (Acc_Typ (V).all);
-- end;
+ --------------------------------
+ -- Allows_Finalization_Master --
+ --------------------------------
+
+ function Allows_Finalization_Master (Typ : Entity_Id) return Boolean is
+ function In_Deallocation_Instance (E : Entity_Id) return Boolean;
+ -- Determine whether entity E is inside a wrapper package created for
+ -- an instance of Ada.Unchecked_Deallocation.
+
+ ------------------------------
+ -- In_Deallocation_Instance --
+ ------------------------------
+
+ function In_Deallocation_Instance (E : Entity_Id) return Boolean is
+ Pkg : constant Entity_Id := Scope (E);
+ Par : Node_Id := Empty;
+
+ begin
+ if Ekind (Pkg) = E_Package
+ and then Present (Related_Instance (Pkg))
+ and then Ekind (Related_Instance (Pkg)) = E_Procedure
+ then
+ Par := Generic_Parent (Parent (Related_Instance (Pkg)));
+
+ return
+ Present (Par)
+ and then Chars (Par) = Name_Unchecked_Deallocation
+ and then Chars (Scope (Par)) = Name_Ada
+ and then Scope (Scope (Par)) = Standard_Standard;
+ end if;
+
+ return False;
+ end In_Deallocation_Instance;
+
+ -- Local variables
+
+ Desig_Typ : constant Entity_Id := Designated_Type (Typ);
+ Ptr_Typ : constant Entity_Id :=
+ Root_Type_Of_Full_View (Base_Type (Typ));
+
+ -- Start of processing for Allows_Finalization_Master
+
+ begin
+ -- Certain run-time configurations and targets do not provide support
+ -- for controlled types and therefore do not need masters.
+
+ if Restriction_Active (No_Finalization) then
+ return False;
+
+ -- Do not consider C and C++ types since it is assumed that the non-Ada
+ -- side will handle their clean up.
+
+ elsif Convention (Desig_Typ) = Convention_C
+ or else Convention (Desig_Typ) = Convention_CPP
+ then
+ return False;
+
+ -- Do not consider types that return on the secondary stack
+
+ elsif Present (Associated_Storage_Pool (Ptr_Typ))
+ and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool)
+ then
+ return False;
+
+ -- Do not consider types which may never allocate an object
+
+ elsif No_Pool_Assigned (Ptr_Typ) then
+ return False;
+
+ -- Do not consider access types coming from Ada.Unchecked_Deallocation
+ -- instances. Even though the designated type may be controlled, the
+ -- access type will never participate in allocation.
+
+ elsif In_Deallocation_Instance (Ptr_Typ) then
+ return False;
+
+ -- Do not consider non-library access types when restriction
+ -- No_Nested_Finalization is in effect since masters are controlled
+ -- objects.
+
+ elsif Restriction_Active (No_Nested_Finalization)
+ and then not Is_Library_Level_Entity (Ptr_Typ)
+ then
+ return False;
+
+ -- Do not create finalization masters in GNATprove mode because this
+ -- causes unwanted extra expansion. A compilation in this mode must
+ -- keep the tree as close as possible to the original sources.
+
+ elsif GNATprove_Mode then
+ return False;
+
+ -- Otherwise the access type may use a finalization master
+
+ else
+ return True;
+ end if;
+ end Allows_Finalization_Master;
+
+ ----------------------------
+ -- Build_Anonymous_Master --
+ ----------------------------
+
+ procedure Build_Anonymous_Master (Ptr_Typ : Entity_Id) is
+ function Create_Anonymous_Master
+ (Desig_Typ : Entity_Id;
+ Unit_Id : Entity_Id;
+ Unit_Decl : Node_Id) return Entity_Id;
+ -- Create a new anonymous master for access type Ptr_Typ with designated
+ -- type Desig_Typ. The declaration of the master and its initialization
+ -- are inserted in the declarative part of unit Unit_Decl. Unit_Id is
+ -- the entity of Unit_Decl.
+
+ function Current_Anonymous_Master
+ (Desig_Typ : Entity_Id;
+ Unit_Id : Entity_Id) return Entity_Id;
+ -- Find an anonymous master declared within unit Unit_Id which services
+ -- designated type Desig_Typ. If there is no such master, return Empty.
+
+ -----------------------------
+ -- Create_Anonymous_Master --
+ -----------------------------
+
+ function Create_Anonymous_Master
+ (Desig_Typ : Entity_Id;
+ Unit_Id : Entity_Id;
+ Unit_Decl : Node_Id) return Entity_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Unit_Id);
+
+ All_FMs : Elist_Id;
+ Decls : List_Id;
+ FM_Decl : Node_Id;
+ FM_Id : Entity_Id;
+ FM_Init : Node_Id;
+ Unit_Spec : Node_Id;
+
+ begin
+ -- Generate:
+ -- <FM_Id> : Finalization_Master;
+
+ FM_Id := Make_Temporary (Loc, 'A');
+
+ FM_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => FM_Id,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Finalization_Master), Loc));
+
+ -- Generate:
+ -- Set_Base_Pool
+ -- (<FM_Id>, Global_Pool_Object'Unrestricted_Access);
+
+ FM_Init :=
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Set_Base_Pool), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (FM_Id, Loc),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (RTE (RE_Global_Pool_Object), Loc),
+ Attribute_Name => Name_Unrestricted_Access)));
+
+ -- Find the declarative list of the unit
+
+ if Nkind (Unit_Decl) = N_Package_Declaration then
+ Unit_Spec := Specification (Unit_Decl);
+ Decls := Visible_Declarations (Unit_Spec);
+
+ if No (Decls) then
+ Decls := New_List;
+ Set_Visible_Declarations (Unit_Spec, Decls);
+ end if;
+
+ -- Package body or subprogram case
+
+ -- ??? A subprogram spec or body that acts as a compilation unit may
+ -- contain a formal parameter of an anonymous access-to-controlled
+ -- type initialized by an allocator.
+
+ -- procedure Comp_Unit_Proc (Param : access Ctrl := new Ctrl);
+
+ -- There is no suitable place to create the master as the subprogram
+ -- is not in a declarative list.
+
+ else
+ Decls := Declarations (Unit_Decl);
+
+ if No (Decls) then
+ Decls := New_List;
+ Set_Declarations (Unit_Decl, Decls);
+ end if;
+ end if;
+
+ Prepend_To (Decls, FM_Init);
+ Prepend_To (Decls, FM_Decl);
+
+ -- Use the scope of the unit when analyzing the declaration of the
+ -- master and its initialization actions.
+
+ Push_Scope (Unit_Id);
+ Analyze (FM_Decl);
+ Analyze (FM_Init);
+ Pop_Scope;
+
+ -- Mark the master as servicing this specific designated type
+
+ Set_Anonymous_Designated_Type (FM_Id, Desig_Typ);
+
+ -- Include the anonymous master in the list of existing masters which
+ -- appear in this unit. This effectively creates a mapping between a
+ -- master and a designated type which in turn allows for the reuse of
+ -- masters on a per-unit basis.
+
+ All_FMs := Anonymous_Masters (Unit_Id);
+
+ if No (All_FMs) then
+ All_FMs := New_Elmt_List;
+ Set_Anonymous_Masters (Unit_Id, All_FMs);
+ end if;
+
+ Prepend_Elmt (FM_Id, All_FMs);
+
+ return FM_Id;
+ end Create_Anonymous_Master;
+
+ ------------------------------
+ -- Current_Anonymous_Master --
+ ------------------------------
+
+ function Current_Anonymous_Master
+ (Desig_Typ : Entity_Id;
+ Unit_Id : Entity_Id) return Entity_Id
+ is
+ All_FMs : constant Elist_Id := Anonymous_Masters (Unit_Id);
+ FM_Elmt : Elmt_Id;
+ FM_Id : Entity_Id;
+
+ begin
+ -- Inspect the list of anonymous masters declared within the unit
+ -- looking for an existing master which services the same designated
+ -- type.
+
+ if Present (All_FMs) then
+ FM_Elmt := First_Elmt (All_FMs);
+ while Present (FM_Elmt) loop
+ FM_Id := Node (FM_Elmt);
+
+ -- The currect master services the same designated type. As a
+ -- result the master can be reused and associated with another
+ -- anonymous access-to-controlled type.
+
+ if Anonymous_Designated_Type (FM_Id) = Desig_Typ then
+ return FM_Id;
+ end if;
+
+ Next_Elmt (FM_Elmt);
+ end loop;
+ end if;
+
+ return Empty;
+ end Current_Anonymous_Master;
+
+ -- Local variables
+
+ Desig_Typ : Entity_Id;
+ FM_Id : Entity_Id;
+ Priv_View : Entity_Id;
+ Unit_Decl : Node_Id;
+ Unit_Id : Entity_Id;
+
+ -- Start of processing for Build_Anonymous_Master
+
+ begin
+ -- Nothing to do if the circumstances do not allow for a finalization
+ -- master.
+
+ if not Allows_Finalization_Master (Ptr_Typ) then
+ return;
+ end if;
+
+ Unit_Decl := Unit (Cunit (Current_Sem_Unit));
+ Unit_Id := Unique_Defining_Entity (Unit_Decl);
+
+ -- The compilation unit is a package instantiation. In this case the
+ -- anonymous master is associated with the package spec as both the
+ -- spec and body appear at the same level.
+
+ if Nkind (Unit_Decl) = N_Package_Body
+ and then Nkind (Original_Node (Unit_Decl)) = N_Package_Instantiation
+ then
+ Unit_Id := Corresponding_Spec (Unit_Decl);
+ Unit_Decl := Unit_Declaration_Node (Unit_Id);
+ end if;
+
+ -- Use the initial declaration of the designated type when it denotes
+ -- the full view of an incomplete or private type. This ensures that
+ -- types with one and two views are treated the same.
+
+ Desig_Typ := Directly_Designated_Type (Ptr_Typ);
+ Priv_View := Incomplete_Or_Partial_View (Desig_Typ);
+
+ if Present (Priv_View) then
+ Desig_Typ := Priv_View;
+ end if;
+
+ -- Determine whether the current semantic unit already has an anonymous
+ -- master which services the designated type.
+
+ FM_Id := Current_Anonymous_Master (Desig_Typ, Unit_Id);
+
+ -- If this is not the case, create a new master
+
+ if No (FM_Id) then
+ FM_Id := Create_Anonymous_Master (Desig_Typ, Unit_Id, Unit_Decl);
+ end if;
+
+ Set_Finalization_Master (Ptr_Typ, FM_Id);
+ end Build_Anonymous_Master;
+
----------------------------
-- Build_Array_Deep_Procs --
----------------------------
@@ -762,7 +1089,6 @@ package body Exp_Ch7 is
procedure Build_Finalization_Master
(Typ : Entity_Id;
- For_Anonymous : Boolean := False;
For_Lib_Level : Boolean := False;
For_Private : Boolean := False;
Context_Scope : Entity_Id := Empty;
@@ -773,10 +1099,6 @@ package body Exp_Ch7 is
Ptr_Typ : Entity_Id);
-- Add access type Ptr_Typ to the pending access type list for type Typ
- function In_Deallocation_Instance (E : Entity_Id) return Boolean;
- -- Determine whether entity E is inside a wrapper package created for
- -- an instance of Ada.Unchecked_Deallocation.
-
-----------------------------
-- Add_Pending_Access_Type --
-----------------------------
@@ -798,31 +1120,6 @@ package body Exp_Ch7 is
Prepend_Elmt (Ptr_Typ, List);
end Add_Pending_Access_Type;
- ------------------------------
- -- In_Deallocation_Instance --
- ------------------------------
-
- function In_Deallocation_Instance (E : Entity_Id) return Boolean is
- Pkg : constant Entity_Id := Scope (E);
- Par : Node_Id := Empty;
-
- begin
- if Ekind (Pkg) = E_Package
- and then Present (Related_Instance (Pkg))
- and then Ekind (Related_Instance (Pkg)) = E_Procedure
- then
- Par := Generic_Parent (Parent (Related_Instance (Pkg)));
-
- return
- Present (Par)
- and then Chars (Par) = Name_Unchecked_Deallocation
- and then Chars (Scope (Par)) = Name_Ada
- and then Scope (Scope (Par)) = Standard_Standard;
- end if;
-
- return False;
- end In_Deallocation_Instance;
-
-- Local variables
Desig_Typ : constant Entity_Id := Designated_Type (Typ);
@@ -836,18 +1133,10 @@ package body Exp_Ch7 is
-- Start of processing for Build_Finalization_Master
begin
- -- Certain run-time configurations and targets do not provide support
- -- for controlled types.
+ -- Nothing to do if the circumstances do not allow for a finalization
+ -- master.
- if Restriction_Active (No_Finalization) then
- return;
-
- -- Do not process C, C++ types since it is assumed that the non-Ada side
- -- will handle their clean up.
-
- elsif Convention (Desig_Typ) = Convention_C
- or else Convention (Desig_Typ) = Convention_CPP
- then
+ if not Allows_Finalization_Master (Typ) then
return;
-- Various machinery such as freezing may have already created a
@@ -855,48 +1144,6 @@ package body Exp_Ch7 is
elsif Present (Finalization_Master (Ptr_Typ)) then
return;
-
- -- Do not process types that return on the secondary stack
-
- elsif Present (Associated_Storage_Pool (Ptr_Typ))
- and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool)
- then
- return;
-
- -- Do not process types which may never allocate an object
-
- elsif No_Pool_Assigned (Ptr_Typ) then
- return;
-
- -- Do not process access types coming from Ada.Unchecked_Deallocation
- -- instances. Even though the designated type may be controlled, the
- -- access type will never participate in allocation.
-
- elsif In_Deallocation_Instance (Ptr_Typ) then
- return;
-
- -- Ignore the general use of anonymous access types unless the context
- -- requires a finalization master.
-
- elsif Ekind (Ptr_Typ) = E_Anonymous_Access_Type
- and then not For_Anonymous
- then
- return;
-
- -- Do not process non-library access types when restriction No_Nested_
- -- Finalization is in effect since masters are controlled objects.
-
- elsif Restriction_Active (No_Nested_Finalization)
- and then not Is_Library_Level_Entity (Ptr_Typ)
- then
- return;
-
- -- Do not create finalization masters in GNATprove mode because this
- -- unwanted extra expansion. A compilation in this mode keeps the tree
- -- as close as possible to the original sources.
-
- elsif GNATprove_Mode then
- return;
end if;
declare
@@ -1013,11 +1260,11 @@ package body Exp_Ch7 is
Add_Pending_Access_Type (Desig_Typ, Ptr_Typ);
end if;
- -- A finalization master created for an anonymous access type or an
- -- access designating a type with private components must be inserted
- -- before a context-dependent node.
+ -- A finalization master created for an access designating a type
+ -- with private components is inserted before a context-dependent
+ -- node.
- if For_Anonymous or For_Private then
+ if For_Private then
-- At this point both the scope of the context and the insertion
-- mode must be known.
@@ -1096,7 +1343,7 @@ package body Exp_Ch7 is
-- Jump_Alts
Counter_Id : Entity_Id := Empty;
- Counter_Val : Int := 0;
+ Counter_Val : Nat := 0;
-- Name and value of the state counter
Decls : List_Id := No_List;
@@ -1725,7 +1972,7 @@ package body Exp_Ch7 is
Spec : Node_Id;
Typ : Entity_Id;
- Old_Counter_Val : Int;
+ Old_Counter_Val : Nat;
-- This variable is used to determine whether a nested package or
-- instance contains at least one controlled object.
@@ -1828,11 +2075,19 @@ package body Exp_Ch7 is
if For_Package and then Finalize_Storage_Only (Obj_Typ) then
null;
- -- Transient variables are treated separately in order to
- -- minimize the size of the generated code. For details, see
- -- Process_Transient_Objects.
+ -- Finalization of transient objects are treated separately in
+ -- order to handle sensitive cases. These include:
+
+ -- * Aggregate expansion
+ -- * If, case, and expression with actions expansion
+ -- * Transient scopes
+
+ -- If one of those contexts has marked the transient object as
+ -- ignored, do not generate finalization actions for it.
- elsif Is_Processed_Transient (Obj_Id) then
+ elsif Is_Finalized_Transient (Obj_Id)
+ or else Is_Ignored_Transient (Obj_Id)
+ then
null;
-- Ignored Ghost objects do not need any cleanup actions
@@ -1851,16 +2106,21 @@ package body Exp_Ch7 is
null;
-- The object is of the form:
- -- Obj : Typ [:= Expr];
+ -- Obj : [constant] Typ [:= Expr];
- -- Do not process the incomplete view of a deferred constant.
- -- Do not consider tag-to-class-wide conversions.
+ -- Do not process tag-to-class-wide conversions because they do
+ -- not yield an object. Do not process the incomplete view of a
+ -- deferred constant. Note that an object initialized by means
+ -- of a build-in-place function call may appear as a deferred
+ -- constant after expansion activities. These kinds of objects
+ -- must be finalized.
elsif not Is_Imported (Obj_Id)
and then Needs_Finalization (Obj_Typ)
- and then not (Ekind (Obj_Id) = E_Constant
- and then not Has_Completion (Obj_Id))
and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
+ and then not (Ekind (Obj_Id) = E_Constant
+ and then not Has_Completion (Obj_Id)
+ and then No (BIP_Initialization_Call (Obj_Id)))
then
Processing_Actions;
@@ -1882,8 +2142,8 @@ package body Exp_Ch7 is
then
Processing_Actions (Has_No_Init => True);
- -- Processing for "hook" objects generated for controlled
- -- transients declared inside an Expression_With_Actions.
+ -- Processing for "hook" objects generated for transient
+ -- objects declared inside an Expression_With_Actions.
elsif Is_Access_Type (Obj_Typ)
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
@@ -2096,7 +2356,7 @@ package body Exp_Ch7 is
end if;
end if;
- -- Handle a rare case caused by a controlled transient variable
+ -- Handle a rare case caused by a controlled transient object
-- created as part of a record init proc. The variable is wrapped
-- in a block, but the block is not associated with a transient
-- scope.
@@ -2160,7 +2420,7 @@ package body Exp_Ch7 is
Init_Typ : Entity_Id;
-- The initialization type of the related object declaration. Note
- -- that this is not necessarely the same type as Obj_Typ because of
+ -- that this is not necessarily the same type as Obj_Typ because of
-- possible type derivations.
Obj_Typ : Entity_Id;
@@ -2508,48 +2768,9 @@ package body Exp_Ch7 is
Stmt := Next_Suitable_Statement (Decl);
- -- A limited controlled object initialized by a function call uses
- -- the build-in-place machinery to obtain its value.
-
- -- Obj : Lim_Controlled_Type := Func_Call;
-
- -- is expanded into
+ -- Nothing to do for an object with suppressed initialization
- -- Obj : Lim_Controlled_Type;
- -- type Ptr_Typ is access Lim_Controlled_Type;
- -- Temp : constant Ptr_Typ :=
- -- Func_Call
- -- (BIPalloc => 1,
- -- BIPaccess => Obj'Unrestricted_Access)'reference;
-
- -- In this scenario the declaration of the temporary acts as the
- -- last initialization statement.
-
- if Is_Limited_Type (Obj_Typ)
- and then Has_Init_Expression (Decl)
- and then No (Expression (Decl))
- then
- while Present (Stmt) loop
- if Nkind (Stmt) = N_Object_Declaration
- and then Present (Expression (Stmt))
- and then Is_Object_Access_BIP_Func_Call
- (Expr => Expression (Stmt),
- Obj_Id => Obj_Id)
- then
- Last_Init := Stmt;
- exit;
- end if;
-
- Next (Stmt);
- end loop;
-
- -- Nothing to do for an object with supporessed initialization.
- -- Note that this check is not performed at the beginning of the
- -- routine because a declaration marked with No_Initialization
- -- may still be initialized by a build-in-place call (the case
- -- above).
-
- elsif No_Initialization (Decl) then
+ if No_Initialization (Decl) then
return;
-- In all other cases the initialization calls follow the related
@@ -2688,18 +2909,33 @@ package body Exp_Ch7 is
Expression => Make_Integer_Literal (Loc, Counter_Val));
-- Insert the counter after all initialization has been done. The
- -- place of insertion depends on the context. If an object is being
- -- initialized via an aggregate, then the counter must be inserted
- -- after the last aggregate assignment.
+ -- place of insertion depends on the context.
- if Ekind_In (Obj_Id, E_Constant, E_Variable)
- and then Present (Last_Aggregate_Assignment (Obj_Id))
- then
- Count_Ins := Last_Aggregate_Assignment (Obj_Id);
- Body_Ins := Empty;
+ if Ekind_In (Obj_Id, E_Constant, E_Variable) then
+
+ -- The object is initialized by a build-in-place function call.
+ -- The counter insertion point is after the function call.
+
+ if Present (BIP_Initialization_Call (Obj_Id)) then
+ Count_Ins := BIP_Initialization_Call (Obj_Id);
+ Body_Ins := Empty;
+
+ -- The object is initialized by an aggregate. Insert the counter
+ -- after the last aggregate assignment.
+
+ elsif Present (Last_Aggregate_Assignment (Obj_Id)) then
+ Count_Ins := Last_Aggregate_Assignment (Obj_Id);
+ Body_Ins := Empty;
+
+ -- In all other cases the counter is inserted after the last call
+ -- to either [Deep_]Initialize or the type-specific init proc.
+
+ else
+ Find_Last_Init (Count_Ins, Body_Ins);
+ end if;
-- In all other cases the counter is inserted after the last call to
- -- either [Deep_]Initialize or the type specific init proc.
+ -- either [Deep_]Initialize or the type-specific init proc.
else
Find_Last_Init (Count_Ins, Body_Ins);
@@ -2826,6 +3062,13 @@ package body Exp_Ch7 is
Obj_Ref => Obj_Ref,
Typ => Obj_Typ);
+ -- Guard against a missing [Deep_]Finalize when the object type
+ -- was not properly frozen.
+
+ if No (Fin_Call) then
+ Fin_Call := Make_Null_Statement (Loc);
+ end if;
+
-- For CodePeer, the exception handlers normally generated here
-- generate complex flowgraphs which result in capacity problems.
-- Omitting these handlers for CodePeer is justified as follows:
@@ -2891,7 +3134,7 @@ package body Exp_Ch7 is
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
then
-- Temporaries created for the purpose of "exporting" a
- -- controlled transient out of an Expression_With_Actions (EWA)
+ -- transient object out of an Expression_With_Actions (EWA)
-- need guards. The following illustrates the usage of such
-- temporaries.
@@ -3208,6 +3451,1470 @@ package body Exp_Ch7 is
Expand_At_End_Handler (HSS, Empty);
end Build_Finalizer_Call;
+ ------------------------------------
+ -- Build_Invariant_Procedure_Body --
+ ------------------------------------
+
+ -- WARNING: This routine manages Ghost regions. Return statements must be
+ -- replaced by gotos which jump to the end of the routine and restore the
+ -- Ghost mode.
+
+ procedure Build_Invariant_Procedure_Body
+ (Typ : Entity_Id;
+ Partial_Invariant : Boolean := False)
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+
+ Pragmas_Seen : Elist_Id := No_Elist;
+ -- This list contains all invariant pragmas processed so far. The list
+ -- is used to avoid generating redundant invariant checks.
+
+ Produced_Check : Boolean := False;
+ -- This flag tracks whether the type has produced at least one invariant
+ -- check. The flag is used as a sanity check at the end of the routine.
+
+ -- NOTE: most of the routines in Build_Invariant_Procedure_Body are
+ -- intentionally unnested to avoid deep indentation of code.
+
+ -- NOTE: all Add_xxx_Invariants routines are reactive. In other words
+ -- they emit checks, loops (for arrays) and case statements (for record
+ -- variant parts) only when there are invariants to verify. This keeps
+ -- the body of the invariant procedure free from useless code.
+
+ procedure Add_Array_Component_Invariants
+ (T : Entity_Id;
+ Obj_Id : Entity_Id;
+ Checks : in out List_Id);
+ -- Generate an invariant check for each component of array type T.
+ -- Obj_Id denotes the entity of the _object formal parameter of the
+ -- invariant procedure. All created checks are added to list Checks.
+
+ procedure Add_Interface_Invariants
+ (T : Entity_Id;
+ Obj_Id : Entity_Id;
+ Checks : in out List_Id);
+ -- Generate an invariant check for each inherited class-wide invariant
+ -- coming from all interfaces implemented by type T. Obj_Id denotes the
+ -- entity of the _object formal parameter of the invariant procedure.
+ -- All created checks are added to list Checks.
+
+ procedure Add_Parent_Invariants
+ (T : Entity_Id;
+ Obj_Id : Entity_Id;
+ Checks : in out List_Id);
+ -- Generate an invariant check for each inherited class-wide invariant
+ -- coming from all parent types of type T. Obj_Id denotes the entity of
+ -- the _object formal parameter of the invariant procedure. All created
+ -- checks are added to list Checks.
+
+ procedure Add_Record_Component_Invariants
+ (T : Entity_Id;
+ Obj_Id : Entity_Id;
+ Checks : in out List_Id);
+ -- Generate an invariant check for each component of record type T.
+ -- Obj_Id denotes the entity of the _object formal parameter of the
+ -- invariant procedure. All created checks are added to list Checks.
+
+ procedure Add_Type_Invariants
+ (Priv_Typ : Entity_Id;
+ Full_Typ : Entity_Id;
+ CRec_Typ : Entity_Id;
+ Obj_Id : Entity_Id;
+ Checks : in out List_Id;
+ Inherit : Boolean := False;
+ Priv_Item : Node_Id := Empty);
+ -- Generate an invariant check for each invariant found in one of the
+ -- following types (if available):
+ --
+ -- Priv_Typ - the partial view of a type
+ -- Full_Typ - the full view of a type
+ -- CRec_Typ - the corresponding record of a protected or a task type
+ --
+ -- Obj_Id denotes the entity of the _object formal parameter of the
+ -- invariant procedure. All created checks are added to list Checks.
+ -- Flag Inherit should be set when generating invariant checks for
+ -- inherited class-wide invariants. Priv_Item denotes the first rep
+ -- item of the private type.
+
+ function Is_Untagged_Private_Derivation
+ (Priv_Typ : Entity_Id;
+ Full_Typ : Entity_Id) return Boolean;
+ -- Determine whether private type Priv_Typ and its full view Full_Typ
+ -- represent an untagged derivation from a private parent.
+
+ ------------------------------------
+ -- Add_Array_Component_Invariants --
+ ------------------------------------
+
+ procedure Add_Array_Component_Invariants
+ (T : Entity_Id;
+ Obj_Id : Entity_Id;
+ Checks : in out List_Id)
+ is
+ Comp_Typ : constant Entity_Id := Component_Type (T);
+ Dims : constant Pos := Number_Dimensions (T);
+
+ procedure Process_Array_Component
+ (Indices : List_Id;
+ Comp_Checks : in out List_Id);
+ -- Generate an invariant check for an array component identified by
+ -- the indices in list Indices. All created checks are added to list
+ -- Comp_Checks.
+
+ procedure Process_One_Dimension
+ (Dim : Pos;
+ Indices : List_Id;
+ Dim_Checks : in out List_Id);
+ -- Generate a loop over the Nth dimension Dim of an array type. List
+ -- Indices contains all array indices for the dimension. All created
+ -- checks are added to list Dim_Checks.
+
+ -----------------------------
+ -- Process_Array_Component --
+ -----------------------------
+
+ procedure Process_Array_Component
+ (Indices : List_Id;
+ Comp_Checks : in out List_Id)
+ is
+ Proc_Id : Entity_Id;
+
+ begin
+ if Has_Invariants (Comp_Typ) then
+
+ -- In GNATprove mode, the component invariants are checked by
+ -- other means. They should not be added to the array type
+ -- invariant procedure, so that the procedure can be used to
+ -- check the array type invariants if any.
+
+ if GNATprove_Mode then
+ null;
+
+ else
+ Proc_Id := Invariant_Procedure (Base_Type (Comp_Typ));
+
+ -- The component type should have an invariant procedure
+ -- if it has invariants of its own or inherits class-wide
+ -- invariants from parent or interface types.
+
+ pragma Assert (Present (Proc_Id));
+
+ -- Generate:
+ -- <Comp_Typ>Invariant (_object (<Indices>));
+
+ -- Note that the invariant procedure may have a null body if
+ -- assertions are disabled or Assertion_Policy Ignore is in
+ -- effect.
+
+ if not Has_Null_Body (Proc_Id) then
+ Append_New_To (Comp_Checks,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (Proc_Id, Loc),
+ Parameter_Associations => New_List (
+ Make_Indexed_Component (Loc,
+ Prefix => New_Occurrence_Of (Obj_Id, Loc),
+ Expressions => New_Copy_List (Indices)))));
+ end if;
+ end if;
+
+ Produced_Check := True;
+ end if;
+ end Process_Array_Component;
+
+ ---------------------------
+ -- Process_One_Dimension --
+ ---------------------------
+
+ procedure Process_One_Dimension
+ (Dim : Pos;
+ Indices : List_Id;
+ Dim_Checks : in out List_Id)
+ is
+ Comp_Checks : List_Id := No_List;
+ Index : Entity_Id;
+
+ begin
+ -- Generate the invariant checks for the array component after all
+ -- dimensions have produced their respective loops.
+
+ if Dim > Dims then
+ Process_Array_Component
+ (Indices => Indices,
+ Comp_Checks => Dim_Checks);
+
+ -- Otherwise create a loop for the current dimension
+
+ else
+ -- Create a new loop variable for each dimension
+
+ Index :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name ('I', Dim));
+ Append_To (Indices, New_Occurrence_Of (Index, Loc));
+
+ Process_One_Dimension
+ (Dim => Dim + 1,
+ Indices => Indices,
+ Dim_Checks => Comp_Checks);
+
+ -- Generate:
+ -- for I<Dim> in _object'Range (<Dim>) loop
+ -- <Comp_Checks>
+ -- end loop;
+
+ -- Note that the invariant procedure may have a null body if
+ -- assertions are disabled or Assertion_Policy Ignore is in
+ -- effect.
+
+ if Present (Comp_Checks) then
+ Append_New_To (Dim_Checks,
+ Make_Implicit_Loop_Statement (T,
+ Identifier => Empty,
+ Iteration_Scheme =>
+ Make_Iteration_Scheme (Loc,
+ Loop_Parameter_Specification =>
+ Make_Loop_Parameter_Specification (Loc,
+ Defining_Identifier => Index,
+ Discrete_Subtype_Definition =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Obj_Id, Loc),
+ Attribute_Name => Name_Range,
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, Dim))))),
+
+ Statements => Comp_Checks));
+ end if;
+ end if;
+ end Process_One_Dimension;
+
+ -- Start of processing for Add_Array_Component_Invariants
+
+ begin
+ Process_One_Dimension
+ (Dim => 1,
+ Indices => New_List,
+ Dim_Checks => Checks);
+ end Add_Array_Component_Invariants;
+
+ ------------------------------
+ -- Add_Interface_Invariants --
+ ------------------------------
+
+ procedure Add_Interface_Invariants
+ (T : Entity_Id;
+ Obj_Id : Entity_Id;
+ Checks : in out List_Id)
+ is
+ Iface_Elmt : Elmt_Id;
+ Ifaces : Elist_Id;
+
+ begin
+ if Is_Tagged_Type (T) then
+ Collect_Interfaces (T, Ifaces);
+
+ -- Process the class-wide invariants of all implemented interfaces
+
+ Iface_Elmt := First_Elmt (Ifaces);
+ while Present (Iface_Elmt) loop
+ Add_Type_Invariants
+ (Priv_Typ => Empty,
+ Full_Typ => Node (Iface_Elmt),
+ CRec_Typ => Empty,
+ Obj_Id => Obj_Id,
+ Checks => Checks,
+ Inherit => True);
+
+ Next_Elmt (Iface_Elmt);
+ end loop;
+ end if;
+ end Add_Interface_Invariants;
+
+ ---------------------------
+ -- Add_Parent_Invariants --
+ ---------------------------
+
+ procedure Add_Parent_Invariants
+ (T : Entity_Id;
+ Obj_Id : Entity_Id;
+ Checks : in out List_Id)
+ is
+ Dummy_1 : Entity_Id;
+ Dummy_2 : Entity_Id;
+
+ Curr_Typ : Entity_Id;
+ -- The entity of the current type being examined
+
+ Full_Typ : Entity_Id;
+ -- The full view of Par_Typ
+
+ Par_Typ : Entity_Id;
+ -- The entity of the parent type
+
+ Priv_Typ : Entity_Id;
+ -- The partial view of Par_Typ
+
+ begin
+ -- Do not process array types because they cannot have true parent
+ -- types. This also prevents the generation of a duplicate invariant
+ -- check when the input type is an array base type because its Etype
+ -- denotes the first subtype, both of which share the same component
+ -- type.
+
+ if Is_Array_Type (T) then
+ return;
+ end if;
+
+ -- Climb the parent type chain
+
+ Curr_Typ := T;
+ loop
+ -- Do not consider subtypes as they inherit the invariants from
+ -- their base types.
+
+ Par_Typ := Base_Type (Etype (Curr_Typ));
+
+ -- Stop the climb once the root of the parent chain is reached
+
+ exit when Curr_Typ = Par_Typ;
+
+ -- Process the class-wide invariants of the parent type
+
+ Get_Views (Par_Typ, Priv_Typ, Full_Typ, Dummy_1, Dummy_2);
+
+ Add_Type_Invariants
+ (Priv_Typ => Priv_Typ,
+ Full_Typ => Full_Typ,
+ CRec_Typ => Empty,
+ Obj_Id => Obj_Id,
+ Checks => Checks,
+ Inherit => True);
+
+ Curr_Typ := Par_Typ;
+ end loop;
+ end Add_Parent_Invariants;
+
+ -------------------------------------
+ -- Add_Record_Component_Invariants --
+ -------------------------------------
+
+ procedure Add_Record_Component_Invariants
+ (T : Entity_Id;
+ Obj_Id : Entity_Id;
+ Checks : in out List_Id)
+ is
+ procedure Process_Component_List
+ (Comp_List : Node_Id;
+ CL_Checks : in out List_Id);
+ -- Generate invariant checks for all record components found in
+ -- component list Comp_List, including variant parts. All created
+ -- checks are added to list CL_Checks.
+
+ procedure Process_Record_Component
+ (Comp_Id : Entity_Id;
+ Comp_Checks : in out List_Id);
+ -- Generate an invariant check for a record component identified by
+ -- Comp_Id. All created checks are added to list Comp_Checks.
+
+ ----------------------------
+ -- Process_Component_List --
+ ----------------------------
+
+ procedure Process_Component_List
+ (Comp_List : Node_Id;
+ CL_Checks : in out List_Id)
+ is
+ Comp : Node_Id;
+ Var : Node_Id;
+ Var_Alts : List_Id := No_List;
+ Var_Checks : List_Id := No_List;
+ Var_Stmts : List_Id;
+
+ Produced_Variant_Check : Boolean := False;
+ -- This flag tracks whether the component has produced at least
+ -- one invariant check.
+
+ begin
+ -- Traverse the component items
+
+ Comp := First (Component_Items (Comp_List));
+ while Present (Comp) loop
+ if Nkind (Comp) = N_Component_Declaration then
+
+ -- Generate the component invariant check
+
+ Process_Record_Component
+ (Comp_Id => Defining_Entity (Comp),
+ Comp_Checks => CL_Checks);
+ end if;
+
+ Next (Comp);
+ end loop;
+
+ -- Traverse the variant part
+
+ if Present (Variant_Part (Comp_List)) then
+ Var := First (Variants (Variant_Part (Comp_List)));
+ while Present (Var) loop
+ Var_Checks := No_List;
+
+ -- Generate invariant checks for all components and variant
+ -- parts that qualify.
+
+ Process_Component_List
+ (Comp_List => Component_List (Var),
+ CL_Checks => Var_Checks);
+
+ -- The components of the current variant produced at least
+ -- one invariant check.
+
+ if Present (Var_Checks) then
+ Var_Stmts := Var_Checks;
+ Produced_Variant_Check := True;
+
+ -- Otherwise there are either no components with invariants,
+ -- assertions are disabled, or Assertion_Policy Ignore is in
+ -- effect.
+
+ else
+ Var_Stmts := New_List (Make_Null_Statement (Loc));
+ end if;
+
+ Append_New_To (Var_Alts,
+ Make_Case_Statement_Alternative (Loc,
+ Discrete_Choices =>
+ New_Copy_List (Discrete_Choices (Var)),
+ Statements => Var_Stmts));
+
+ Next (Var);
+ end loop;
+
+ -- Create a case statement which verifies the invariant checks
+ -- of a particular component list depending on the discriminant
+ -- values only when there is at least one real invariant check.
+
+ if Produced_Variant_Check then
+ Append_New_To (CL_Checks,
+ Make_Case_Statement (Loc,
+ Expression =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Occurrence_Of (Obj_Id, Loc),
+ Selector_Name =>
+ New_Occurrence_Of
+ (Entity (Name (Variant_Part (Comp_List))), Loc)),
+ Alternatives => Var_Alts));
+ end if;
+ end if;
+ end Process_Component_List;
+
+ ------------------------------
+ -- Process_Record_Component --
+ ------------------------------
+
+ procedure Process_Record_Component
+ (Comp_Id : Entity_Id;
+ Comp_Checks : in out List_Id)
+ is
+ Comp_Typ : constant Entity_Id := Etype (Comp_Id);
+ Proc_Id : Entity_Id;
+
+ Produced_Component_Check : Boolean := False;
+ -- This flag tracks whether the component has produced at least
+ -- one invariant check.
+
+ begin
+ -- Nothing to do for internal component _parent. Note that it is
+ -- not desirable to check whether the component comes from source
+ -- because protected type components are relocated to an internal
+ -- corresponding record, but still need processing.
+
+ if Chars (Comp_Id) = Name_uParent then
+ return;
+ end if;
+
+ -- Verify the invariant of the component. Note that an access
+ -- type may have an invariant when it acts as the full view of a
+ -- private type and the invariant appears on the partial view. In
+ -- this case verify the access value itself.
+
+ if Has_Invariants (Comp_Typ) then
+
+ -- In GNATprove mode, the component invariants are checked by
+ -- other means. They should not be added to the record type
+ -- invariant procedure, so that the procedure can be used to
+ -- check the record type invariants if any.
+
+ if GNATprove_Mode then
+ null;
+
+ else
+ Proc_Id := Invariant_Procedure (Base_Type (Comp_Typ));
+
+ -- The component type should have an invariant procedure
+ -- if it has invariants of its own or inherits class-wide
+ -- invariants from parent or interface types.
+
+ pragma Assert (Present (Proc_Id));
+
+ -- Generate:
+ -- <Comp_Typ>Invariant (T (_object).<Comp_Id>);
+
+ -- Note that the invariant procedure may have a null body if
+ -- assertions are disabled or Assertion_Policy Ignore is in
+ -- effect.
+
+ if not Has_Null_Body (Proc_Id) then
+ Append_New_To (Comp_Checks,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (Proc_Id, Loc),
+ Parameter_Associations => New_List (
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To
+ (T, New_Occurrence_Of (Obj_Id, Loc)),
+ Selector_Name =>
+ New_Occurrence_Of (Comp_Id, Loc)))));
+ end if;
+ end if;
+
+ Produced_Check := True;
+ Produced_Component_Check := True;
+ end if;
+
+ if Produced_Component_Check and then Has_Unchecked_Union (T) then
+ Error_Msg_NE
+ ("invariants cannot be checked on components of "
+ & "unchecked_union type &?", Comp_Id, T);
+ end if;
+ end Process_Record_Component;
+
+ -- Local variables
+
+ Comps : Node_Id;
+ Def : Node_Id;
+
+ -- Start of processing for Add_Record_Component_Invariants
+
+ begin
+ -- An untagged derived type inherits the components of its parent
+ -- type. In order to avoid creating redundant invariant checks, do
+ -- not process the components now. Instead wait until the ultimate
+ -- parent of the untagged derivation chain is reached.
+
+ if not Is_Untagged_Derivation (T) then
+ Def := Type_Definition (Parent (T));
+
+ if Nkind (Def) = N_Derived_Type_Definition then
+ Def := Record_Extension_Part (Def);
+ end if;
+
+ pragma Assert (Nkind (Def) = N_Record_Definition);
+ Comps := Component_List (Def);
+
+ if Present (Comps) then
+ Process_Component_List
+ (Comp_List => Comps,
+ CL_Checks => Checks);
+ end if;
+ end if;
+ end Add_Record_Component_Invariants;
+
+ -------------------------
+ -- Add_Type_Invariants --
+ -------------------------
+
+ procedure Add_Type_Invariants
+ (Priv_Typ : Entity_Id;
+ Full_Typ : Entity_Id;
+ CRec_Typ : Entity_Id;
+ Obj_Id : Entity_Id;
+ Checks : in out List_Id;
+ Inherit : Boolean := False;
+ Priv_Item : Node_Id := Empty)
+ is
+ procedure Add_Invariant (Prag : Node_Id);
+ -- Create a runtime check to verify the invariant exression of pragma
+ -- Prag. All generated code is added to list Checks.
+
+ procedure Process_Type (T : Entity_Id; Stop_Item : Node_Id := Empty);
+ -- Generate invariant checks for type T by inspecting the rep item
+ -- chain of the type. Stop_Item denotes a rep item which once seen
+ -- will stop the inspection.
+
+ -------------------
+ -- Add_Invariant --
+ -------------------
+
+ procedure Add_Invariant (Prag : Node_Id) is
+ Rep_Typ : Entity_Id;
+ -- The replacement type used in the substitution of the current
+ -- instance of a type with the _object formal parameter.
+
+ procedure Replace_Type_Ref (N : Node_Id);
+ -- Substitute the occurrence of a type name denoted by N with a
+ -- reference to the _object formal parameter.
+
+ ----------------------
+ -- Replace_Type_Ref --
+ ----------------------
+
+ procedure Replace_Type_Ref (N : Node_Id) is
+ Nloc : constant Source_Ptr := Sloc (N);
+ Ref : Node_Id;
+
+ begin
+ -- Decorate the reference to Ref_Typ even though it may be
+ -- rewritten further down. This is done for two reasons:
+
+ -- 1) ASIS has all necessary semantic information in the
+ -- original tree.
+
+ -- 2) Routines which examine properties of the Original_Node
+ -- have some semantic information.
+
+ if Nkind (N) = N_Identifier then
+ Set_Entity (N, Rep_Typ);
+ Set_Etype (N, Rep_Typ);
+
+ elsif Nkind (N) = N_Selected_Component then
+ Analyze (Prefix (N));
+ Set_Entity (Selector_Name (N), Rep_Typ);
+ Set_Etype (Selector_Name (N), Rep_Typ);
+ end if;
+
+ -- Perform the following substitution:
+
+ -- Ref_Typ --> _object
+
+ Ref := Make_Identifier (Nloc, Chars (Obj_Id));
+ Set_Entity (Ref, Obj_Id);
+ Set_Etype (Ref, Rep_Typ);
+
+ -- When the pragma denotes a class-wide invariant, perform the
+ -- following substitution:
+
+ -- Rep_Typ --> Rep_Typ'Class (_object)
+
+ if Class_Present (Prag) then
+ Ref :=
+ Make_Type_Conversion (Nloc,
+ Subtype_Mark =>
+ Make_Attribute_Reference (Nloc,
+ Prefix =>
+ New_Occurrence_Of (Rep_Typ, Nloc),
+ Attribute_Name => Name_Class),
+ Expression => Ref);
+ end if;
+
+ Rewrite (N, Ref);
+ Set_Comes_From_Source (N, True);
+ end Replace_Type_Ref;
+
+ procedure Replace_Type_Refs is
+ new Replace_Type_References_Generic (Replace_Type_Ref);
+
+ -- Local variables
+
+ Asp : constant Node_Id := Corresponding_Aspect (Prag);
+ Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
+ Ploc : constant Source_Ptr := Sloc (Prag);
+
+ Arg1 : Node_Id;
+ Arg2 : Node_Id;
+ Arg3 : Node_Id;
+ ASIS_Expr : Node_Id;
+ Assoc : List_Id;
+ Expr : Node_Id;
+ Str : String_Id;
+
+ -- Start of processing for Add_Invariant
+
+ begin
+ -- Nothing to do if the pragma was already processed
+
+ if Contains (Pragmas_Seen, Prag) then
+ return;
+ end if;
+
+ -- Extract the arguments of the invariant pragma
+
+ Arg1 := First (Pragma_Argument_Associations (Prag));
+ Arg2 := Next (Arg1);
+ Arg3 := Next (Arg2);
+
+ Arg1 := Get_Pragma_Arg (Arg1);
+ Arg2 := Get_Pragma_Arg (Arg2);
+
+ -- The pragma applies to the partial view
+
+ if Present (Priv_Typ) and then Entity (Arg1) = Priv_Typ then
+ Rep_Typ := Priv_Typ;
+
+ -- The pragma applies to the full view
+
+ elsif Present (Full_Typ) and then Entity (Arg1) = Full_Typ then
+ Rep_Typ := Full_Typ;
+
+ -- Otherwise the pragma applies to a parent type in which case it
+ -- will be processed at a later stage by Add_Parent_Invariants or
+ -- Add_Interface_Invariants.
+
+ else
+ return;
+ end if;
+
+ -- Nothing to do when the caller requests the processing of all
+ -- inherited class-wide invariants, but the pragma does not fall
+ -- in this category.
+
+ if Inherit and then not Class_Present (Prag) then
+ return;
+ end if;
+
+ Expr := New_Copy_Tree (Arg2);
+
+ -- Substitute all references to type Rep_Typ with references to
+ -- the _object formal parameter.
+
+ Replace_Type_Refs (Expr, Rep_Typ);
+
+ -- Additional processing for non-class-wide invariants
+
+ if not Inherit then
+
+ -- Preanalyze the invariant expression to detect errors and at
+ -- the same time capture the visibility of the proper package
+ -- part.
+
+ -- Historical note: the old implementation of invariants used
+ -- node N as the parent, but a package specification as parent
+ -- of an expression is bizarre.
+
+ Set_Parent (Expr, Parent (Arg2));
+ Preanalyze_Assert_Expression (Expr, Any_Boolean);
+
+ -- If the pragma comes from an aspect specification, replace
+ -- the saved expression because all type references must be
+ -- substituted for the call to Preanalyze_Spec_Expression in
+ -- Check_Aspect_At_xxx routines.
+
+ if Present (Asp) then
+ Set_Entity (Identifier (Asp), New_Copy_Tree (Expr));
+ end if;
+
+ -- Analyze the original invariant expression for ASIS
+
+ if ASIS_Mode then
+ ASIS_Expr := Empty;
+
+ if Comes_From_Source (Prag) then
+ ASIS_Expr := Arg2;
+ elsif Present (Asp) then
+ ASIS_Expr := Expression (Asp);
+ end if;
+
+ if Present (ASIS_Expr) then
+ Replace_Type_Refs (ASIS_Expr, Rep_Typ);
+ Preanalyze_Assert_Expression (ASIS_Expr, Any_Boolean);
+ end if;
+ end if;
+
+ -- A class-wide invariant may be inherited in a separate unit,
+ -- where the corresponding expression cannot be resolved by
+ -- visibility, because it refers to a local function. Propagate
+ -- semantic information to the original representation item, to
+ -- be used when an invariant procedure for a derived type is
+ -- constructed.
+
+ -- ??? Unclear how to handle class-wide invariants that are not
+ -- function calls.
+
+ if Class_Present (Prag)
+ and then Nkind (Expr) = N_Function_Call
+ and then Nkind (Arg2) = N_Indexed_Component
+ then
+ Rewrite (Arg2,
+ Make_Function_Call (Ploc,
+ Name =>
+ New_Occurrence_Of (Entity (Name (Expr)), Ploc),
+ Parameter_Associations => Expressions (Arg2)));
+ end if;
+ end if;
+
+ -- The invariant is ignored, nothing left to do
+
+ if Is_Ignored (Prag) then
+ null;
+
+ -- Otherwise the invariant is checked. Build a Check pragma to
+ -- verify the expression at runtime.
+
+ else
+ Assoc := New_List (
+ Make_Pragma_Argument_Association (Ploc,
+ Expression => Make_Identifier (Ploc, Nam)),
+ Make_Pragma_Argument_Association (Ploc,
+ Expression => Expr));
+
+ -- Handle the String argument (if any)
+
+ if Present (Arg3) then
+ Str := Strval (Get_Pragma_Arg (Arg3));
+
+ -- When inheriting an invariant, modify the message from
+ -- "failed invariant" to "failed inherited invariant".
+
+ if Inherit then
+ String_To_Name_Buffer (Str);
+
+ if Name_Buffer (1 .. 16) = "failed invariant" then
+ Insert_Str_In_Name_Buffer ("inherited ", 8);
+ Str := String_From_Name_Buffer;
+ end if;
+ end if;
+
+ Append_To (Assoc,
+ Make_Pragma_Argument_Association (Ploc,
+ Expression => Make_String_Literal (Ploc, Str)));
+ end if;
+
+ -- Generate:
+ -- pragma Check (<Nam>, <Expr>, <Str>);
+
+ Append_New_To (Checks,
+ Make_Pragma (Ploc,
+ Chars => Name_Check,
+ Pragma_Argument_Associations => Assoc));
+ end if;
+
+ -- Output an info message when inheriting an invariant and the
+ -- listing option is enabled.
+
+ if Inherit and Opt.List_Inherited_Aspects then
+ Error_Msg_Sloc := Sloc (Prag);
+ Error_Msg_N
+ ("info: & inherits `Invariant''Class` aspect from #?L?", Typ);
+ end if;
+
+ -- Add the pragma to the list of processed pragmas
+
+ Append_New_Elmt (Prag, Pragmas_Seen);
+ Produced_Check := True;
+ end Add_Invariant;
+
+ ------------------
+ -- Process_Type --
+ ------------------
+
+ procedure Process_Type
+ (T : Entity_Id;
+ Stop_Item : Node_Id := Empty)
+ is
+ Rep_Item : Node_Id;
+
+ begin
+ Rep_Item := First_Rep_Item (T);
+ while Present (Rep_Item) loop
+ if Nkind (Rep_Item) = N_Pragma
+ and then Pragma_Name (Rep_Item) = Name_Invariant
+ then
+ -- Stop the traversal of the rep item chain once a specific
+ -- item is encountered.
+
+ if Present (Stop_Item) and then Rep_Item = Stop_Item then
+ exit;
+
+ -- Otherwise generate an invariant check
+
+ else
+ Add_Invariant (Rep_Item);
+ end if;
+ end if;
+
+ Next_Rep_Item (Rep_Item);
+ end loop;
+ end Process_Type;
+
+ -- Start of processing for Add_Type_Invariants
+
+ begin
+ -- Process the invariants of the partial view
+
+ if Present (Priv_Typ) then
+ Process_Type (Priv_Typ);
+ end if;
+
+ -- Process the invariants of the full view
+
+ if Present (Full_Typ) then
+ Process_Type (Full_Typ, Stop_Item => Priv_Item);
+
+ -- Process the elements of an array type
+
+ if Is_Array_Type (Full_Typ) then
+ Add_Array_Component_Invariants (Full_Typ, Obj_Id, Checks);
+
+ -- Process the components of a record type
+
+ elsif Ekind (Full_Typ) = E_Record_Type then
+ Add_Record_Component_Invariants (Full_Typ, Obj_Id, Checks);
+ end if;
+ end if;
+
+ -- Process the components of a corresponding record type
+
+ if Present (CRec_Typ) then
+ Add_Record_Component_Invariants (CRec_Typ, Obj_Id, Checks);
+ end if;
+ end Add_Type_Invariants;
+
+ ------------------------------------
+ -- Is_Untagged_Private_Derivation --
+ ------------------------------------
+
+ function Is_Untagged_Private_Derivation
+ (Priv_Typ : Entity_Id;
+ Full_Typ : Entity_Id) return Boolean
+ is
+ begin
+ return
+ Present (Priv_Typ)
+ and then Is_Untagged_Derivation (Priv_Typ)
+ and then Is_Private_Type (Etype (Priv_Typ))
+ and then Present (Full_Typ)
+ and then Is_Itype (Full_Typ);
+ end Is_Untagged_Private_Derivation;
+
+ -- Local variables
+
+ Dummy : Entity_Id;
+ Mode : Ghost_Mode_Type;
+ Priv_Item : Node_Id;
+ Proc_Body : Node_Id;
+ Proc_Body_Id : Entity_Id;
+ Proc_Decl : Node_Id;
+ Proc_Id : Entity_Id;
+ Stmts : List_Id := No_List;
+
+ CRec_Typ : Entity_Id;
+ -- The corresponding record type of Full_Typ
+
+ Full_Proc : Entity_Id;
+ -- The entity of the "full" invariant procedure
+
+ Full_Typ : Entity_Id;
+ -- The full view of the working type
+
+ Obj_Id : Entity_Id;
+ -- The _object formal parameter of the invariant procedure
+
+ Part_Proc : Entity_Id;
+ -- The entity of the "partial" invariant procedure
+
+ Priv_Typ : Entity_Id;
+ -- The partial view of the working type
+
+ Work_Typ : Entity_Id;
+ -- The working type
+
+ -- Start of processing for Build_Invariant_Procedure_Body
+
+ begin
+ Work_Typ := Typ;
+
+ -- The input type denotes the implementation base type of a constrained
+ -- array type. Work with the first subtype as all invariant pragmas are
+ -- on its rep item chain.
+
+ if Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then
+ Work_Typ := First_Subtype (Work_Typ);
+
+ -- The input type denotes the corresponding record type of a protected
+ -- or task type. Work with the concurrent type because the corresponding
+ -- record type may not be visible to clients of the type.
+
+ elsif Ekind (Work_Typ) = E_Record_Type
+ and then Is_Concurrent_Record_Type (Work_Typ)
+ then
+ Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
+ end if;
+
+ -- The working type may be subject to pragma Ghost. Set the mode now to
+ -- ensure that the invariant procedure is properly marked as Ghost.
+
+ Set_Ghost_Mode (Work_Typ, Mode);
+
+ -- The type must either have invariants of its own, inherit class-wide
+ -- invariants from parent types or interfaces, or be an array or record
+ -- type whose components have invariants.
+
+ pragma Assert (Has_Invariants (Work_Typ));
+
+ -- Nothing to do for interface types as their class-wide invariants are
+ -- inherited by implementing types.
+
+ if Is_Interface (Work_Typ) then
+ goto Leave;
+ end if;
+
+ -- Obtain both views of the type
+
+ Get_Views (Work_Typ, Priv_Typ, Full_Typ, Dummy, CRec_Typ);
+
+ -- The caller requests a body for the partial invariant procedure
+
+ if Partial_Invariant then
+ Full_Proc := Invariant_Procedure (Work_Typ);
+ Proc_Id := Partial_Invariant_Procedure (Work_Typ);
+
+ -- The "full" invariant procedure body was already created
+
+ if Present (Full_Proc)
+ and then Present
+ (Corresponding_Body (Unit_Declaration_Node (Full_Proc)))
+ then
+ -- This scenario happens only when the type is an untagged
+ -- derivation from a private parent and the underlying full
+ -- view was processed before the partial view.
+
+ pragma Assert
+ (Is_Untagged_Private_Derivation (Priv_Typ, Full_Typ));
+
+ -- Nothing to do because the processing of the underlying full
+ -- view already checked the invariants of the partial view.
+
+ goto Leave;
+ end if;
+
+ -- Create a declaration for the "partial" invariant procedure if it
+ -- is not available.
+
+ if No (Proc_Id) then
+ Build_Invariant_Procedure_Declaration
+ (Typ => Work_Typ,
+ Partial_Invariant => True);
+
+ Proc_Id := Partial_Invariant_Procedure (Work_Typ);
+ end if;
+
+ -- The caller requests a body for the "full" invariant procedure
+
+ else
+ Proc_Id := Invariant_Procedure (Work_Typ);
+ Part_Proc := Partial_Invariant_Procedure (Work_Typ);
+
+ -- Create a declaration for the "full" invariant procedure if it is
+ -- not available.
+
+ if No (Proc_Id) then
+ Build_Invariant_Procedure_Declaration (Work_Typ);
+ Proc_Id := Invariant_Procedure (Work_Typ);
+ end if;
+ end if;
+
+ -- At this point there should be an invariant procedure declaration
+
+ pragma Assert (Present (Proc_Id));
+ Proc_Decl := Unit_Declaration_Node (Proc_Id);
+
+ -- Nothing to do if the invariant procedure already has a body
+
+ if Present (Corresponding_Body (Proc_Decl)) then
+ goto Leave;
+ end if;
+
+ -- Emulate the environment of the invariant procedure by installing
+ -- its scope and formal parameters. Note that this is not needed, but
+ -- having the scope of the invariant procedure installed helps with
+ -- the detection of invariant-related errors.
+
+ Push_Scope (Proc_Id);
+ Install_Formals (Proc_Id);
+
+ Obj_Id := First_Formal (Proc_Id);
+ pragma Assert (Present (Obj_Id));
+
+ -- The "partial" invariant procedure verifies the invariants of the
+ -- partial view only.
+
+ if Partial_Invariant then
+ pragma Assert (Present (Priv_Typ));
+
+ Add_Type_Invariants
+ (Priv_Typ => Priv_Typ,
+ Full_Typ => Empty,
+ CRec_Typ => Empty,
+ Obj_Id => Obj_Id,
+ Checks => Stmts);
+
+ -- Otherwise the "full" invariant procedure verifies the invariants of
+ -- the full view, all array or record components, as well as class-wide
+ -- invariants inherited from parent types or interfaces. In addition, it
+ -- indirectly verifies the invariants of the partial view by calling the
+ -- "partial" invariant procedure.
+
+ else
+ pragma Assert (Present (Full_Typ));
+
+ -- Check the invariants of the partial view by calling the "partial"
+ -- invariant procedure. Generate:
+
+ -- <Work_Typ>Partial_Invariant (_object);
+
+ if Present (Part_Proc) then
+ Append_New_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Part_Proc, Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Obj_Id, Loc))));
+
+ Produced_Check := True;
+ end if;
+
+ Priv_Item := Empty;
+
+ -- Derived subtypes do not have a partial view
+
+ if Present (Priv_Typ) then
+
+ -- The processing of the "full" invariant 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 invariants 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_Invariant => ...;
+ -- <underlying full view of Child>
+ -- end Pack_2;
+
+ -- As a result, the processing of the full view must also consider
+ -- all invariants of the partial view.
+
+ if Is_Untagged_Private_Derivation (Priv_Typ, Full_Typ) then
+ null;
+
+ -- Otherwise the invariants of the partial view are ignored
+
+ else
+ -- Note that the rep item chain is shared between the partial
+ -- and full views of a type. To avoid processing the invariants
+ -- of the partial view, signal the logic to stop when the first
+ -- rep item of the partial view has been reached.
+
+ Priv_Item := First_Rep_Item (Priv_Typ);
+
+ -- Ignore the invariants of the partial view by eliminating the
+ -- view.
+
+ Priv_Typ := Empty;
+ end if;
+ end if;
+
+ -- Process the invariants of the full view and in certain cases those
+ -- of the partial view. This also handles any invariants on array or
+ -- record components.
+
+ Add_Type_Invariants
+ (Priv_Typ => Priv_Typ,
+ Full_Typ => Full_Typ,
+ CRec_Typ => CRec_Typ,
+ Obj_Id => Obj_Id,
+ Checks => Stmts,
+ Priv_Item => Priv_Item);
+
+ -- Process the inherited class-wide invariants of all parent types.
+ -- This also handles any invariants on record components.
+
+ Add_Parent_Invariants (Full_Typ, Obj_Id, Stmts);
+
+ -- Process the inherited class-wide invariants of all implemented
+ -- interface types.
+
+ Add_Interface_Invariants (Full_Typ, Obj_Id, Stmts);
+ end if;
+
+ End_Scope;
+
+ -- At this point there should be at least one invariant check. If this
+ -- is not the case, then the invariant-related flags were not properly
+ -- set, or there is a missing invariant procedure on one of the array
+ -- or record components.
+
+ pragma Assert (Produced_Check);
+
+ -- Account for the case where assertions are disabled or all invariant
+ -- checks are subject to Assertion_Policy Ignore. Produce a completing
+ -- empty body.
+
+ if No (Stmts) then
+ Stmts := New_List (Make_Null_Statement (Loc));
+ end if;
+
+ -- Generate:
+ -- procedure <Work_Typ>[Partial_]Invariant (_object : <Work_Typ>) is
+ -- begin
+ -- <Stmts>
+ -- end <Work_Typ>[Partial_]Invariant;
+
+ Proc_Body :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Copy_Subprogram_Spec (Parent (Proc_Id)),
+ Declarations => Empty_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stmts));
+ Proc_Body_Id := Defining_Entity (Proc_Body);
+
+ -- Perform minor decoration in case the body is not analyzed
+
+ Set_Ekind (Proc_Body_Id, E_Subprogram_Body);
+ Set_Etype (Proc_Body_Id, Standard_Void_Type);
+ Set_Scope (Proc_Body_Id, Current_Scope);
+
+ -- Link both spec and body to avoid generating duplicates
+
+ Set_Corresponding_Body (Proc_Decl, Proc_Body_Id);
+ Set_Corresponding_Spec (Proc_Body, Proc_Id);
+
+ -- The body should not be inserted into the tree when the context is
+ -- ASIS or a generic unit because it is not part of the template. Note
+ -- that the body must still be generated in order to resolve the
+ -- invariants.
+
+ if ASIS_Mode or Inside_A_Generic then
+ null;
+
+ -- Semi-insert the body into the tree for GNATprove by setting its
+ -- Parent field. This allows for proper upstream tree traversals.
+
+ elsif GNATprove_Mode then
+ Set_Parent (Proc_Body, Parent (Declaration_Node (Work_Typ)));
+
+ -- Otherwise the body is part of the freezing actions of the type
+
+ else
+ Append_Freeze_Action (Work_Typ, Proc_Body);
+ end if;
+
+ <<Leave>>
+ Restore_Ghost_Mode (Mode);
+ end Build_Invariant_Procedure_Body;
+
+ -------------------------------------------
+ -- Build_Invariant_Procedure_Declaration --
+ -------------------------------------------
+
+ -- WARNING: This routine manages Ghost regions. Return statements must be
+ -- replaced by gotos which jump to the end of the routine and restore the
+ -- Ghost mode.
+
+ procedure Build_Invariant_Procedure_Declaration
+ (Typ : Entity_Id;
+ Partial_Invariant : Boolean := False)
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+
+ Mode : Ghost_Mode_Type;
+ Proc_Decl : Node_Id;
+ Proc_Id : Entity_Id;
+ Proc_Nam : Name_Id;
+ Typ_Decl : Node_Id;
+
+ CRec_Typ : Entity_Id;
+ -- The corresponding record type of Full_Typ
+
+ Full_Base : Entity_Id;
+ -- The base type of Full_Typ
+
+ Full_Typ : Entity_Id;
+ -- The full view of working type
+
+ Obj_Id : Entity_Id;
+ -- The _object formal parameter of the invariant procedure
+
+ Priv_Typ : Entity_Id;
+ -- The partial view of working type
+
+ Work_Typ : Entity_Id;
+ -- The working type
+
+ begin
+ Work_Typ := Typ;
+
+ -- The input type denotes the implementation base type of a constrained
+ -- array type. Work with the first subtype as all invariant pragmas are
+ -- on its rep item chain.
+
+ if Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then
+ Work_Typ := First_Subtype (Work_Typ);
+
+ -- The input denotes the corresponding record type of a protected or a
+ -- task type. Work with the concurrent type because the corresponding
+ -- record type may not be visible to clients of the type.
+
+ elsif Ekind (Work_Typ) = E_Record_Type
+ and then Is_Concurrent_Record_Type (Work_Typ)
+ then
+ Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
+ end if;
+
+ -- The working type may be subject to pragma Ghost. Set the mode now to
+ -- ensure that the invariant procedure is properly marked as Ghost.
+
+ Set_Ghost_Mode (Work_Typ, Mode);
+
+ -- The type must either have invariants of its own, inherit class-wide
+ -- invariants from parent or interface types, or be an array or record
+ -- type whose components have invariants.
+
+ pragma Assert (Has_Invariants (Work_Typ));
+
+ -- Nothing to do for interface types as their class-wide invariants are
+ -- inherited by implementing types.
+
+ if Is_Interface (Work_Typ) then
+ goto Leave;
+
+ -- Nothing to do if the type already has a "partial" invariant procedure
+
+ elsif Partial_Invariant then
+ if Present (Partial_Invariant_Procedure (Work_Typ)) then
+ goto Leave;
+ end if;
+
+ -- Nothing to do if the type already has a "full" invariant procedure
+
+ elsif Present (Invariant_Procedure (Work_Typ)) then
+ goto Leave;
+ end if;
+
+ -- The caller requests the declaration of the "partial" invariant
+ -- procedure.
+
+ if Partial_Invariant then
+ Proc_Nam := New_External_Name (Chars (Work_Typ), "Partial_Invariant");
+
+ -- Otherwise the caller requests the declaration of the "full" invariant
+ -- procedure.
+
+ else
+ Proc_Nam := New_External_Name (Chars (Work_Typ), "Invariant");
+ end if;
+
+ Proc_Id := Make_Defining_Identifier (Loc, Chars => Proc_Nam);
+
+ -- Perform minor decoration in case the declaration is not analyzed
+
+ Set_Ekind (Proc_Id, E_Procedure);
+ Set_Etype (Proc_Id, Standard_Void_Type);
+ Set_Scope (Proc_Id, Current_Scope);
+
+ if Partial_Invariant then
+ Set_Is_Partial_Invariant_Procedure (Proc_Id);
+ Set_Partial_Invariant_Procedure (Work_Typ, Proc_Id);
+ else
+ Set_Is_Invariant_Procedure (Proc_Id);
+ Set_Invariant_Procedure (Work_Typ, Proc_Id);
+ end if;
+
+ -- The invariant procedure requires debug info when the invariants are
+ -- subject to Source Coverage Obligations.
+
+ if Opt.Generate_SCO then
+ Set_Needs_Debug_Info (Proc_Id);
+ end if;
+
+ -- Obtain all views of the input type
+
+ Get_Views (Work_Typ, Priv_Typ, Full_Typ, Full_Base, CRec_Typ);
+
+ -- Associate the invariant procedure with all views
+
+ Propagate_Invariant_Attributes (Priv_Typ, From_Typ => Work_Typ);
+ Propagate_Invariant_Attributes (Full_Typ, From_Typ => Work_Typ);
+ Propagate_Invariant_Attributes (Full_Base, From_Typ => Work_Typ);
+ Propagate_Invariant_Attributes (CRec_Typ, From_Typ => Work_Typ);
+
+ -- The declaration of the invariant procedure is inserted after the
+ -- declaration of the partial view as this allows for proper external
+ -- visibility.
+
+ if Present (Priv_Typ) then
+ Typ_Decl := Declaration_Node (Priv_Typ);
+
+ -- Derived types with the full view as parent do not have a partial
+ -- view. Insert the invariant procedure after the derived type.
+
+ else
+ Typ_Decl := Declaration_Node (Full_Typ);
+ end if;
+
+ -- The type should have a declarative node
+
+ pragma Assert (Present (Typ_Decl));
+
+ -- Create the formal parameter which emulates the variable-like behavior
+ -- of the current type instance.
+
+ Obj_Id := Make_Defining_Identifier (Loc, Chars => Name_uObject);
+
+ -- Perform minor decoration in case the declaration is not analyzed
+
+ Set_Ekind (Obj_Id, E_In_Parameter);
+ Set_Etype (Obj_Id, Work_Typ);
+ Set_Scope (Obj_Id, Proc_Id);
+
+ Set_First_Entity (Proc_Id, Obj_Id);
+
+ -- Generate:
+ -- procedure <Work_Typ>[Partial_]Invariant (_object : <Work_Typ>);
+
+ Proc_Decl :=
+ Make_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Proc_Id,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Obj_Id,
+ Parameter_Type =>
+ New_Occurrence_Of (Work_Typ, Loc)))));
+
+ -- The declaration should not be inserted into the tree when the context
+ -- is ASIS or a generic unit because it is not part of the template.
+
+ if ASIS_Mode or Inside_A_Generic then
+ null;
+
+ -- Semi-insert the declaration into the tree for GNATprove by setting
+ -- its Parent field. This allows for proper upstream tree traversals.
+
+ elsif GNATprove_Mode then
+ Set_Parent (Proc_Decl, Parent (Typ_Decl));
+
+ -- Otherwise insert the declaration
+
+ else
+ pragma Assert (Present (Typ_Decl));
+ Insert_After_And_Analyze (Typ_Decl, Proc_Decl);
+ end if;
+
+ <<Leave>>
+ Restore_Ghost_Mode (Mode);
+ end Build_Invariant_Procedure_Declaration;
+
---------------------
-- Build_Late_Proc --
---------------------
@@ -3693,15 +5400,6 @@ package body Exp_Ch7 is
end if;
end Check_Visibly_Controlled;
- -------------------------------
- -- CW_Or_Has_Controlled_Part --
- -------------------------------
-
- function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is
- begin
- return Is_Class_Wide_Type (T) or else Needs_Finalization (T);
- end CW_Or_Has_Controlled_Part;
-
------------------
-- Convert_View --
------------------
@@ -3764,6 +5462,15 @@ package body Exp_Ch7 is
end if;
end Convert_View;
+ -------------------------------
+ -- CW_Or_Has_Controlled_Part --
+ -------------------------------
+
+ function CW_Or_Has_Controlled_Part (T : Entity_Id) return Boolean is
+ begin
+ return Is_Class_Wide_Type (T) or else Needs_Finalization (T);
+ end CW_Or_Has_Controlled_Part;
+
------------------------
-- Enclosing_Function --
------------------------
@@ -4172,15 +5879,7 @@ package body Exp_Ch7 is
Spec_Id : constant Entity_Id := Corresponding_Spec (N);
Fin_Id : Entity_Id;
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
-
begin
- -- The package body is Ghost when the corresponding spec is Ghost. Set
- -- the mode now to ensure that any nodes generated during expansion are
- -- properly marked as Ghost.
-
- Set_Ghost_Mode (N, Spec_Id);
-
-- This is done only for non-generic packages
if Ekind (Spec_Id) = E_Package then
@@ -4236,8 +5935,6 @@ package body Exp_Ch7 is
end;
end if;
end if;
-
- Ghost_Mode := Save_Ghost_Mode;
end Expand_N_Package_Body;
----------------------------------
@@ -4407,8 +6104,9 @@ package body Exp_Ch7 is
-- context of a Timed_Entry_Call. In this case we wrap the entire
-- timed entry call.
- when N_Entry_Call_Statement |
- N_Procedure_Call_Statement =>
+ when N_Entry_Call_Statement
+ | N_Procedure_Call_Statement
+ =>
if Nkind (Parent (The_Parent)) = N_Entry_Call_Alternative
and then Nkind_In (Parent (Parent (The_Parent)),
N_Timed_Entry_Call,
@@ -4423,34 +6121,35 @@ package body Exp_Ch7 is
-- even if they are not really wrapped. For further details, see
-- Wrap_Transient_Declaration.
- when N_Object_Declaration |
- N_Object_Renaming_Declaration |
- N_Subtype_Declaration =>
+ when N_Object_Declaration
+ | N_Object_Renaming_Declaration
+ | N_Subtype_Declaration
+ =>
return The_Parent;
-- The expression itself is to be wrapped if its parent is a
-- compound statement or any other statement where the expression
-- is known to be scalar.
- when N_Accept_Alternative |
- N_Attribute_Definition_Clause |
- N_Case_Statement |
- N_Code_Statement |
- N_Delay_Alternative |
- N_Delay_Until_Statement |
- N_Delay_Relative_Statement |
- N_Discriminant_Association |
- N_Elsif_Part |
- N_Entry_Body_Formal_Part |
- N_Exit_Statement |
- N_If_Statement |
- N_Iteration_Scheme |
- N_Terminate_Alternative =>
+ when N_Accept_Alternative
+ | N_Attribute_Definition_Clause
+ | N_Case_Statement
+ | N_Code_Statement
+ | N_Delay_Alternative
+ | N_Delay_Until_Statement
+ | N_Delay_Relative_Statement
+ | N_Discriminant_Association
+ | N_Elsif_Part
+ | N_Entry_Body_Formal_Part
+ | N_Exit_Statement
+ | N_If_Statement
+ | N_Iteration_Scheme
+ | N_Terminate_Alternative
+ =>
pragma Assert (Present (P));
return P;
when N_Attribute_Reference =>
-
if Is_Procedure_Attribute_Name
(Attribute_Name (The_Parent))
then
@@ -4474,9 +6173,10 @@ package body Exp_Ch7 is
-- The following nodes contains "dummy calls" which don't need to
-- be wrapped.
- when N_Parameter_Specification |
- N_Discriminant_Specification |
- N_Component_Declaration =>
+ when N_Component_Declaration
+ | N_Discriminant_Specification
+ | N_Parameter_Specification
+ =>
return Empty;
-- The return statement is not to be wrapped when the function
@@ -4501,10 +6201,11 @@ package body Exp_Ch7 is
-- situation that are not detected yet (such as a dynamic string
-- in a pragma export)
- when N_Subprogram_Body |
- N_Package_Declaration |
- N_Package_Body |
- N_Block_Statement =>
+ when N_Block_Statement
+ | N_Package_Body
+ | N_Package_Declaration
+ | N_Subprogram_Body
+ =>
return Empty;
-- Otherwise continue the search
@@ -4602,30 +6303,31 @@ package body Exp_Ch7 is
Act_Cleanup : constant List_Id :=
Scope_Stack.Table (Scope_Stack.Last).Actions_To_Be_Wrapped (Cleanup);
-- Note: We used to use renamings of Scope_Stack.Table (Scope_Stack.
- -- Last), but this was incorrect as Process_Transient_Object may
+ -- Last), but this was incorrect as Process_Transients_In_Scope may
-- introduce new scopes and cause a reallocation of Scope_Stack.Table.
- procedure Process_Transient_Objects
+ procedure Process_Transients_In_Scope
(First_Object : Node_Id;
Last_Object : Node_Id;
Related_Node : Node_Id);
- -- First_Object and Last_Object define a list which contains potential
- -- controlled transient objects. Finalization flags are inserted before
- -- First_Object and finalization calls are inserted after Last_Object.
- -- Related_Node is the node for which transient objects have been
- -- created.
+ -- Find all transient objects in the list First_Object .. Last_Object
+ -- and generate finalization actions for them. Related_Node denotes the
+ -- node which created all transient objects.
- -------------------------------
- -- Process_Transient_Objects --
- -------------------------------
+ ---------------------------------
+ -- Process_Transients_In_Scope --
+ ---------------------------------
- procedure Process_Transient_Objects
+ procedure Process_Transients_In_Scope
(First_Object : Node_Id;
Last_Object : Node_Id;
Related_Node : Node_Id)
is
+ Exceptions_OK : constant Boolean :=
+ not Restriction_Active (No_Exception_Propagation);
+
Must_Hook : Boolean := False;
- -- Flag denoting whether the context requires transient variable
+ -- Flag denoting whether the context requires transient object
-- export to the outer finalizer.
function Is_Subprogram_Call (N : Node_Id) return Traverse_Result;
@@ -4634,25 +6336,35 @@ package body Exp_Ch7 is
procedure Detect_Subprogram_Call is
new Traverse_Proc (Is_Subprogram_Call);
+ procedure Process_Transient_In_Scope
+ (Obj_Decl : Node_Id;
+ Blk_Data : Finalization_Exception_Data;
+ Blk_Stmts : List_Id);
+ -- Generate finalization actions for a single transient object
+ -- denoted by object declaration Obj_Decl. Blk_Data is the
+ -- exception data of the enclosing block. Blk_Stmts denotes the
+ -- statements of the enclosing block.
+
------------------------
-- Is_Subprogram_Call --
------------------------
function Is_Subprogram_Call (N : Node_Id) return Traverse_Result is
begin
- -- Complex constructs are factored out by the expander and their
- -- occurrences are replaced with references to temporaries or
- -- object renamings. Due to this expansion activity, inspect the
- -- original tree to detect subprogram calls.
-
- if Nkind_In (N, N_Identifier,
- N_Object_Renaming_Declaration)
- and then Original_Node (N) /= N
- then
- Detect_Subprogram_Call (Original_Node (N));
+ -- A regular procedure or function call
+
+ if Nkind (N) in N_Subprogram_Call then
+ Must_Hook := True;
+ return Abandon;
+
+ -- Special cases
- -- The original construct contains a subprogram call, there is
- -- no point in continuing the tree traversal.
+ -- Heavy expansion may relocate function calls outside the related
+ -- node. Inspect the original node to detect the initial placement
+ -- of the call.
+
+ elsif Original_Node (N) /= N then
+ Detect_Subprogram_Call (Original_Node (N));
if Must_Hook then
return Abandon;
@@ -4660,22 +6372,14 @@ package body Exp_Ch7 is
return OK;
end if;
- -- The original construct contains a subprogram call, there is no
- -- point in continuing the tree traversal.
+ -- Generalized indexing always involves a function call
- elsif Nkind (N) = N_Object_Declaration
- and then Present (Expression (N))
- and then Nkind (Original_Node (Expression (N))) = N_Function_Call
+ elsif Nkind (N) = N_Indexed_Component
+ and then Present (Generalized_Indexing (N))
then
Must_Hook := True;
return Abandon;
- -- A regular procedure or function call
-
- elsif Nkind (N) in N_Subprogram_Call then
- Must_Hook := True;
- return Abandon;
-
-- Keep searching
else
@@ -4683,32 +6387,149 @@ package body Exp_Ch7 is
end if;
end Is_Subprogram_Call;
- -- Local variables
+ --------------------------------
+ -- Process_Transient_In_Scope --
+ --------------------------------
- Exceptions_OK : constant Boolean :=
- not Restriction_Active (No_Exception_Propagation);
+ procedure Process_Transient_In_Scope
+ (Obj_Decl : Node_Id;
+ Blk_Data : Finalization_Exception_Data;
+ Blk_Stmts : List_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Obj_Decl);
+ Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
+ Fin_Call : Node_Id;
+ Fin_Stmts : List_Id;
+ Hook_Assign : Node_Id;
+ Hook_Clear : Node_Id;
+ Hook_Decl : Node_Id;
+ Hook_Insert : Node_Id;
+ Ptr_Decl : Node_Id;
+
+ begin
+ -- Mark the transient object as successfully processed to avoid
+ -- double finalization.
+
+ Set_Is_Finalized_Transient (Obj_Id);
+
+ -- Construct all the pieces necessary to hook and finalize the
+ -- transient object.
+
+ Build_Transient_Object_Statements
+ (Obj_Decl => Obj_Decl,
+ Fin_Call => Fin_Call,
+ Hook_Assign => Hook_Assign,
+ Hook_Clear => Hook_Clear,
+ Hook_Decl => Hook_Decl,
+ Ptr_Decl => Ptr_Decl);
+
+ -- The context contains at least one subprogram call which may
+ -- raise an exception. This scenario employs "hooking" to pass
+ -- transient objects to the enclosing finalizer in case of an
+ -- exception.
+
+ if Must_Hook then
+
+ -- Add the access type which provides a reference to the
+ -- transient object. Generate:
+
+ -- type Ptr_Typ is access all Desig_Typ;
+
+ Insert_Action (Obj_Decl, Ptr_Decl);
+
+ -- Add the temporary which acts as a hook to the transient
+ -- object. Generate:
+
+ -- Hook : Ptr_Typ := null;
+
+ Insert_Action (Obj_Decl, Hook_Decl);
+
+ -- When the transient object is initialized by an aggregate,
+ -- the hook must capture the object after the last aggregate
+ -- assignment takes place. Only then is the object considered
+ -- fully initialized. Generate:
+
+ -- Hook := Ptr_Typ (Obj_Id);
+ -- <or>
+ -- Hook := Obj_Id'Unrestricted_Access;
+
+ if Ekind_In (Obj_Id, E_Constant, E_Variable)
+ and then Present (Last_Aggregate_Assignment (Obj_Id))
+ then
+ Hook_Insert := Last_Aggregate_Assignment (Obj_Id);
+
+ -- Otherwise the hook seizes the related object immediately
+
+ else
+ Hook_Insert := Obj_Decl;
+ end if;
+
+ Insert_After_And_Analyze (Hook_Insert, Hook_Assign);
+ end if;
+
+ -- When exception propagation is enabled wrap the hook clear
+ -- statement and the finalization call into a block to catch
+ -- potential exceptions raised during finalization. Generate:
+
+ -- begin
+ -- [Hook := null;]
+ -- [Deep_]Finalize (Obj_Ref);
+
+ -- exception
+ -- when others =>
+ -- if not Raised then
+ -- Raised := True;
+ -- Save_Occurrence
+ -- (Enn, Get_Current_Excep.all.all);
+ -- end if;
+ -- end;
+
+ if Exceptions_OK then
+ Fin_Stmts := New_List;
+
+ if Must_Hook then
+ Append_To (Fin_Stmts, Hook_Clear);
+ end if;
+
+ Append_To (Fin_Stmts, Fin_Call);
+
+ Prepend_To (Blk_Stmts,
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Fin_Stmts,
+ Exception_Handlers => New_List (
+ Build_Exception_Handler (Blk_Data)))));
+
+ -- Otherwise generate:
+
+ -- [Hook := null;]
+ -- [Deep_]Finalize (Obj_Ref);
+
+ -- Note that the statements are inserted in reverse order to
+ -- achieve the desired final order outlined above.
+
+ else
+ Prepend_To (Blk_Stmts, Fin_Call);
+
+ if Must_Hook then
+ Prepend_To (Blk_Stmts, Hook_Clear);
+ end if;
+ end if;
+ end Process_Transient_In_Scope;
+
+ -- Local variables
Built : Boolean := False;
+ Blk_Data : Finalization_Exception_Data;
Blk_Decl : Node_Id := Empty;
Blk_Decls : List_Id := No_List;
Blk_Ins : Node_Id;
Blk_Stmts : List_Id;
- Desig_Typ : Entity_Id;
- Fin_Call : Node_Id;
- Fin_Data : Finalization_Exception_Data;
- Fin_Stmts : List_Id;
- Hook_Clr : Node_Id := Empty;
- Hook_Id : Entity_Id;
- Hook_Ins : Node_Id;
- Init_Expr : Node_Id;
Loc : Source_Ptr;
Obj_Decl : Node_Id;
- Obj_Id : Entity_Id;
- Obj_Ref : Node_Id;
- Obj_Typ : Entity_Id;
- Ptr_Typ : Entity_Id;
- -- Start of processing for Process_Transient_Objects
+ -- Start of processing for Process_Transients_In_Scope
begin
-- The expansion performed by this routine is as follows:
@@ -4753,11 +6574,11 @@ package body Exp_Ch7 is
-- Save_Occurrence (Ex, Get_Current_Excep.all.all);
-- end;
+ -- Abort_Undefer;
+
-- if Raised and not Abrt then
-- Raise_From_Controlled_Operation (Ex);
-- end if;
-
- -- Abort_Undefer_Direct;
-- end;
-- Recognize a scenario where the transient context is an object
@@ -4771,8 +6592,8 @@ package body Exp_Ch7 is
-- Obj : ...;
-- Res : ... := BIP_Func_Call (..., Obj, ...);
- -- The finalization of any controlled transient must happen after
- -- the build-in-place function call is executed.
+ -- The finalization of any transient object must happen after the
+ -- build-in-place function call is executed.
if Nkind (N) = N_Object_Declaration
and then Present (BIP_Initialization_Call (Defining_Identifier (N)))
@@ -4806,114 +6627,7 @@ package body Exp_Ch7 is
and then Obj_Decl /= Related_Node
then
- Loc := Sloc (Obj_Decl);
- Obj_Id := Defining_Identifier (Obj_Decl);
- Obj_Typ := Base_Type (Etype (Obj_Id));
- Desig_Typ := Obj_Typ;
-
- Set_Is_Processed_Transient (Obj_Id);
-
- -- Handle access types
-
- if Is_Access_Type (Desig_Typ) then
- Desig_Typ := Available_View (Designated_Type (Desig_Typ));
- end if;
-
- -- Transient objects associated with subprogram calls need
- -- extra processing. These objects are usually created right
- -- before the call and finalized immediately after the call.
- -- If an exception occurs during the call, the clean up code
- -- is skipped due to the sudden change in control and the
- -- transient is never finalized.
-
- -- To handle this case, such variables are "exported" to the
- -- enclosing sequence of statements where their corresponding
- -- "hooks" are picked up by the finalization machinery.
-
- if Must_Hook then
-
- -- Create an access type which provides a reference to the
- -- transient object. Generate:
- -- type Ptr_Typ is access [all] Desig_Typ;
-
- Ptr_Typ := Make_Temporary (Loc, 'A');
-
- Insert_Action (Obj_Decl,
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Ptr_Typ,
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- All_Present =>
- Ekind (Obj_Typ) = E_General_Access_Type,
- Subtype_Indication =>
- New_Occurrence_Of (Desig_Typ, Loc))));
-
- -- Create a temporary which acts as a hook to the transient
- -- object. Generate:
- -- Hook : Ptr_Typ := null;
-
- Hook_Id := Make_Temporary (Loc, 'T');
-
- Insert_Action (Obj_Decl,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Hook_Id,
- Object_Definition =>
- New_Occurrence_Of (Ptr_Typ, Loc)));
-
- -- Mark the temporary as a hook. This signals the machinery
- -- in Build_Finalizer to recognize this special case.
-
- Set_Status_Flag_Or_Transient_Decl (Hook_Id, Obj_Decl);
-
- -- Hook the transient object to the temporary. Generate:
- -- Hook := Ptr_Typ (Obj_Id);
- -- <or>
- -- Hook := Obj_Id'Unrestricted_Access;
-
- if Is_Access_Type (Obj_Typ) then
- Init_Expr :=
- Convert_To (Ptr_Typ, New_Occurrence_Of (Obj_Id, Loc));
-
- else
- Init_Expr :=
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Obj_Id, Loc),
- Attribute_Name => Name_Unrestricted_Access);
- end if;
-
- -- When the transient object is initialized by an aggregate,
- -- the hook must capture the object after the last component
- -- assignment takes place. Only then is the object fully
- -- initialized.
-
- if Ekind (Obj_Id) = E_Variable
- and then Present (Last_Aggregate_Assignment (Obj_Id))
- then
- Hook_Ins := Last_Aggregate_Assignment (Obj_Id);
-
- -- Otherwise the hook seizes the related object immediately
-
- else
- Hook_Ins := Obj_Decl;
- end if;
-
- Insert_After_And_Analyze (Hook_Ins,
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Hook_Id, Loc),
- Expression => Init_Expr));
-
- -- The transient object is about to be finalized by the
- -- clean up code following the subprogram call. In order
- -- to avoid double finalization, clear the hook.
-
- -- Generate:
- -- Hook := null;
-
- Hook_Clr :=
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Hook_Id, Loc),
- Expression => Make_Null (Loc));
- end if;
+ Loc := Sloc (Obj_Decl);
-- Before generating the clean up code for the first transient
-- object, create a wrapper block which houses all hook clear
@@ -4924,25 +6638,14 @@ package body Exp_Ch7 is
Built := True;
Blk_Stmts := New_List;
- -- Create the declarations of all entities that participate
- -- in exception detection and propagation.
+ -- Generate:
+ -- Abrt : constant Boolean := ...;
+ -- Ex : Exception_Occurrence;
+ -- Raised : Boolean := False;
if Exceptions_OK then
Blk_Decls := New_List;
-
- -- Generate:
- -- Abrt : constant Boolean := ...;
- -- Ex : Exception_Occurrence;
- -- Raised : Boolean := False;
-
- Build_Object_Declarations (Fin_Data, Blk_Decls, Loc);
-
- -- Generate:
- -- if Raised and then not Abrt then
- -- Raise_From_Controlled_Operation (Ex);
- -- end if;
-
- Append_To (Blk_Stmts, Build_Raise_Statement (Fin_Data));
+ Build_Object_Declarations (Blk_Data, Blk_Decls, Loc);
end if;
Blk_Decl :=
@@ -4953,64 +6656,13 @@ package body Exp_Ch7 is
Statements => Blk_Stmts));
end if;
- -- Generate:
- -- [Deep_]Finalize (Obj_Ref);
-
- Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
-
- if Is_Access_Type (Obj_Typ) then
- Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
- Set_Etype (Obj_Ref, Desig_Typ);
- end if;
-
- Fin_Call :=
- Make_Final_Call (Obj_Ref => Obj_Ref, Typ => Desig_Typ);
-
- -- When exception propagation is enabled wrap the hook clear
- -- statement and the finalization call into a block to catch
- -- potential exceptions raised during finalization. Generate:
-
- -- begin
- -- [Temp := null;]
- -- [Deep_]Finalize (Obj_Ref);
-
- -- exception
- -- when others =>
- -- if not Raised then
- -- Raised := True;
- -- Save_Occurrence
- -- (Enn, Get_Current_Excep.all.all);
- -- end if;
- -- end;
-
- if Exceptions_OK then
- Fin_Stmts := New_List;
-
- if Present (Hook_Clr) then
- Append_To (Fin_Stmts, Hook_Clr);
- end if;
-
- Append_To (Fin_Stmts, Fin_Call);
-
- Prepend_To (Blk_Stmts,
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Fin_Stmts,
- Exception_Handlers => New_List (
- Build_Exception_Handler (Fin_Data)))));
+ -- Construct all necessary circuitry to hook and finalize a
+ -- single transient object.
- -- Otherwise generate:
- -- [Temp := null;]
- -- [Deep_]Finalize (Obj_Ref);
-
- else
- Prepend_To (Blk_Stmts, Fin_Call);
-
- if Present (Hook_Clr) then
- Prepend_To (Blk_Stmts, Hook_Clr);
- end if;
- end if;
+ Process_Transient_In_Scope
+ (Obj_Decl => Obj_Decl,
+ Blk_Data => Blk_Data,
+ Blk_Stmts => Blk_Stmts);
end if;
-- Terminate the scan after the last object has been processed to
@@ -5023,12 +6675,15 @@ package body Exp_Ch7 is
Next (Obj_Decl);
end loop;
+ -- Complete the decoration of the enclosing finalization block and
+ -- insert it into the tree.
+
if Present (Blk_Decl) then
- -- Note that the abort defer / undefer pair does not require an
- -- extra block because each finalization exception is caught in
- -- its corresponding finalization block. As a result, the call to
- -- Abort_Defer always takes place.
+ -- Note that this Abort_Undefer does not require a extra block or
+ -- an AT_END handler because each finalization exception is caught
+ -- in its own corresponding finalization block. As a result, the
+ -- call to Abort_Defer always takes place.
if Abort_Allowed then
Prepend_To (Blk_Stmts,
@@ -5038,9 +6693,18 @@ package body Exp_Ch7 is
Build_Runtime_Call (Loc, RE_Abort_Undefer));
end if;
+ -- Generate:
+ -- if Raised and then not Abrt then
+ -- Raise_From_Controlled_Operation (Ex);
+ -- end if;
+
+ if Exceptions_OK then
+ Append_To (Blk_Stmts, Build_Raise_Statement (Blk_Data));
+ end if;
+
Insert_After_And_Analyze (Blk_Ins, Blk_Decl);
end if;
- end Process_Transient_Objects;
+ end Process_Transients_In_Scope;
-- Local variables
@@ -5118,10 +6782,10 @@ package body Exp_Ch7 is
(Last_Obj, Build_SS_Release_Call (Loc, Mark_Id));
end if;
- -- Check for transient controlled objects associated with Target and
- -- generate the appropriate finalization actions for them.
+ -- Check for transient objects associated with Target and generate the
+ -- appropriate finalization actions for them.
- Process_Transient_Objects
+ Process_Transients_In_Scope
(First_Object => First_Obj,
Last_Object => Last_Obj,
Related_Node => Target);
@@ -5163,10 +6827,12 @@ package body Exp_Ch7 is
is
Loc : constant Source_Ptr := Sloc (Obj_Ref);
Adj_Id : Entity_Id := Empty;
- Ref : Node_Id := Obj_Ref;
+ Ref : Node_Id;
Utyp : Entity_Id;
begin
+ Ref := Obj_Ref;
+
-- Recover the proper type which contains Deep_Adjust
if Is_Class_Wide_Type (Typ) then
@@ -5180,7 +6846,7 @@ package body Exp_Ch7 is
-- Deal with untagged derivation of private views
- if Is_Untagged_Derivation (Typ) then
+ if Present (Utyp) and then Is_Untagged_Derivation (Typ) then
Utyp := Underlying_Type (Root_Type (Base_Type (Typ)));
Ref := Unchecked_Convert_To (Utyp, Ref);
Set_Assignment_OK (Ref);
@@ -5189,14 +6855,21 @@ package body Exp_Ch7 is
-- When dealing with the completion of a private type, use the base
-- type instead.
- if Utyp /= Base_Type (Utyp) then
+ if Present (Utyp) and then Utyp /= Base_Type (Utyp) then
pragma Assert (Is_Private_Type (Typ));
Utyp := Base_Type (Utyp);
Ref := Unchecked_Convert_To (Utyp, Ref);
end if;
- if Skip_Self then
+ -- The underlying type may not be present due to a missing full view. In
+ -- this case freezing did not take place and there is no [Deep_]Adjust
+ -- primitive to call.
+
+ if No (Utyp) then
+ return Empty;
+
+ elsif Skip_Self then
if Has_Controlled_Component (Utyp) then
if Is_Tagged_Type (Utyp) then
Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust);
@@ -5256,7 +6929,7 @@ package body Exp_Ch7 is
return
Make_Call (Loc,
Proc_Id => Adj_Id,
- Param => New_Copy_Tree (Ref),
+ Param => Ref,
Skip_Self => Skip_Self);
else
return Empty;
@@ -5429,22 +7102,12 @@ package body Exp_Ch7 is
function Build_Adjust_Or_Finalize_Statements
(Typ : Entity_Id) return List_Id
is
- Comp_Typ : constant Entity_Id := Component_Type (Typ);
- Exceptions_OK : constant Boolean :=
- not Restriction_Active (No_Exception_Propagation);
- Index_List : constant List_Id := New_List;
- Loc : constant Source_Ptr := Sloc (Typ);
- Num_Dims : constant Int := Number_Dimensions (Typ);
-
- Finalizer_Decls : List_Id := No_List;
- Finalizer_Data : Finalization_Exception_Data;
- Call : Node_Id;
- Comp_Ref : Node_Id;
- Core_Loop : Node_Id;
- Dim : Int;
- J : Entity_Id;
- Loop_Id : Entity_Id;
- Stmts : List_Id;
+ Comp_Typ : constant Entity_Id := Component_Type (Typ);
+ Exceptions_OK : constant Boolean :=
+ not Restriction_Active (No_Exception_Propagation);
+ Index_List : constant List_Id := New_List;
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Num_Dims : constant Int := Number_Dimensions (Typ);
procedure Build_Indexes;
-- Generate the indexes used in the dimension loops
@@ -5464,13 +7127,26 @@ package body Exp_Ch7 is
end loop;
end Build_Indexes;
+ -- Local variables
+
+ Final_Decls : List_Id := No_List;
+ Final_Data : Finalization_Exception_Data;
+ Block : Node_Id;
+ Call : Node_Id;
+ Comp_Ref : Node_Id;
+ Core_Loop : Node_Id;
+ Dim : Int;
+ J : Entity_Id;
+ Loop_Id : Entity_Id;
+ Stmts : List_Id;
+
-- Start of processing for Build_Adjust_Or_Finalize_Statements
begin
- Finalizer_Decls := New_List;
+ Final_Decls := New_List;
Build_Indexes;
- Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
+ Build_Object_Declarations (Final_Data, Final_Decls, Loc);
Comp_Ref :=
Make_Indexed_Component (Loc,
@@ -5491,99 +7167,111 @@ package body Exp_Ch7 is
Call := Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
end if;
- -- Generate the block which houses the adjust or finalize call:
+ if Present (Call) then
- -- begin
- -- <adjust or finalize call>
-
- -- exception
- -- when others =>
- -- if not Raised then
- -- Raised := True;
- -- Save_Occurrence (E, Get_Current_Excep.all.all);
- -- end if;
- -- end;
-
- if Exceptions_OK then
- Core_Loop :=
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Call),
- Exception_Handlers => New_List (
- Build_Exception_Handler (Finalizer_Data))));
- else
- Core_Loop := Call;
- end if;
+ -- Generate the block which houses the adjust or finalize call:
- -- Generate the dimension loops starting from the innermost one
+ -- begin
+ -- <adjust or finalize call>
- -- for Jnn in [reverse] V'Range (Dim) loop
- -- <core loop>
- -- end loop;
+ -- exception
+ -- when others =>
+ -- if not Raised then
+ -- Raised := True;
+ -- Save_Occurrence (E, Get_Current_Excep.all.all);
+ -- end if;
+ -- end;
- J := Last (Index_List);
- Dim := Num_Dims;
- while Present (J) and then Dim > 0 loop
- Loop_Id := J;
- Prev (J);
- Remove (Loop_Id);
+ if Exceptions_OK then
+ Core_Loop :=
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Call),
+ Exception_Handlers => New_List (
+ Build_Exception_Handler (Final_Data))));
+ else
+ Core_Loop := Call;
+ end if;
- Core_Loop :=
- Make_Loop_Statement (Loc,
- Iteration_Scheme =>
- Make_Iteration_Scheme (Loc,
- Loop_Parameter_Specification =>
- Make_Loop_Parameter_Specification (Loc,
- Defining_Identifier => Loop_Id,
- Discrete_Subtype_Definition =>
- Make_Attribute_Reference (Loc,
- Prefix => Make_Identifier (Loc, Name_V),
- Attribute_Name => Name_Range,
- Expressions => New_List (
- Make_Integer_Literal (Loc, Dim))),
+ -- Generate the dimension loops starting from the innermost one
+
+ -- for Jnn in [reverse] V'Range (Dim) loop
+ -- <core loop>
+ -- end loop;
+
+ J := Last (Index_List);
+ Dim := Num_Dims;
+ while Present (J) and then Dim > 0 loop
+ Loop_Id := J;
+ Prev (J);
+ Remove (Loop_Id);
+
+ Core_Loop :=
+ Make_Loop_Statement (Loc,
+ Iteration_Scheme =>
+ Make_Iteration_Scheme (Loc,
+ Loop_Parameter_Specification =>
+ Make_Loop_Parameter_Specification (Loc,
+ Defining_Identifier => Loop_Id,
+ Discrete_Subtype_Definition =>
+ Make_Attribute_Reference (Loc,
+ Prefix => Make_Identifier (Loc, Name_V),
+ Attribute_Name => Name_Range,
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, Dim))),
+
+ Reverse_Present =>
+ Prim = Finalize_Case)),
+
+ Statements => New_List (Core_Loop),
+ End_Label => Empty);
+
+ Dim := Dim - 1;
+ end loop;
- Reverse_Present => Prim = Finalize_Case)),
+ -- Generate the block which contains the core loop, declarations
+ -- of the abort flag, the exception occurrence, the raised flag
+ -- and the conditional raise:
- Statements => New_List (Core_Loop),
- End_Label => Empty);
+ -- declare
+ -- Abort : constant Boolean := Triggered_By_Abort;
+ -- <or>
+ -- Abort : constant Boolean := False; -- no abort
- Dim := Dim - 1;
- end loop;
+ -- E : Exception_Occurrence;
+ -- Raised : Boolean := False;
- -- Generate the block which contains the core loop, the declarations
- -- of the abort flag, the exception occurrence, the raised flag and
- -- the conditional raise:
+ -- begin
+ -- <core loop>
- -- declare
- -- Abort : constant Boolean := Triggered_By_Abort;
- -- <or>
- -- Abort : constant Boolean := False; -- no abort
+ -- if Raised and then not Abort then
+ -- Raise_From_Controlled_Operation (E);
+ -- end if;
+ -- end;
- -- E : Exception_Occurrence;
- -- Raised : Boolean := False;
+ Stmts := New_List (Core_Loop);
- -- begin
- -- <core loop>
+ if Exceptions_OK then
+ Append_To (Stmts, Build_Raise_Statement (Final_Data));
+ end if;
- -- if Raised and then not Abort then
- -- Raise_From_Controlled_Operation (E);
- -- end if;
- -- end;
+ Block :=
+ Make_Block_Statement (Loc,
+ Declarations => Final_Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stmts));
- Stmts := New_List (Core_Loop);
+ -- Otherwise previous errors or a missing full view may prevent the
+ -- proper freezing of the component type. If this is the case, there
+ -- is no [Deep_]Adjust or [Deep_]Finalize primitive to call.
- if Exceptions_OK then
- Append_To (Stmts, Build_Raise_Statement (Finalizer_Data));
+ else
+ Block := Make_Null_Statement (Loc);
end if;
- return
- New_List (
- Make_Block_Statement (Loc,
- Declarations =>
- Finalizer_Decls,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc, Stmts)));
+ return New_List (Block);
end Build_Adjust_Or_Finalize_Statements;
---------------------------------
@@ -5591,32 +7279,21 @@ package body Exp_Ch7 is
---------------------------------
function Build_Initialize_Statements (Typ : Entity_Id) return List_Id is
- Comp_Typ : constant Entity_Id := Component_Type (Typ);
- Exceptions_OK : constant Boolean :=
- not Restriction_Active (No_Exception_Propagation);
- Final_List : constant List_Id := New_List;
- Index_List : constant List_Id := New_List;
- Loc : constant Source_Ptr := Sloc (Typ);
- Num_Dims : constant Int := Number_Dimensions (Typ);
-
- Counter_Id : Entity_Id;
- Dim : Int;
- F : Node_Id;
- Fin_Stmt : Node_Id;
- Final_Block : Node_Id;
- Final_Loop : Node_Id;
- Finalizer_Data : Finalization_Exception_Data;
- Finalizer_Decls : List_Id := No_List;
- Init_Loop : Node_Id;
- J : Node_Id;
- Loop_Id : Node_Id;
- Stmts : List_Id;
+ Comp_Typ : constant Entity_Id := Component_Type (Typ);
+ Exceptions_OK : constant Boolean :=
+ not Restriction_Active (No_Exception_Propagation);
+ Final_List : constant List_Id := New_List;
+ Index_List : constant List_Id := New_List;
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Num_Dims : constant Int := Number_Dimensions (Typ);
- function Build_Counter_Assignment return Node_Id;
+ function Build_Assignment (Counter_Id : Entity_Id) return Node_Id;
-- Generate the following assignment:
-- Counter := V'Length (1) *
-- ...
-- V'Length (N) - Counter;
+ --
+ -- Counter_Id denotes the entity of the counter.
function Build_Finalization_Call return Node_Id;
-- Generate a deep finalization call for an array element
@@ -5628,11 +7305,11 @@ package body Exp_Ch7 is
function Build_Initialization_Call return Node_Id;
-- Generate a deep initialization call for an array element
- ------------------------------
- -- Build_Counter_Assignment --
- ------------------------------
+ ----------------------
+ -- Build_Assignment --
+ ----------------------
- function Build_Counter_Assignment return Node_Id is
+ function Build_Assignment (Counter_Id : Entity_Id) return Node_Id is
Dim : Int;
Expr : Node_Id;
@@ -5675,7 +7352,7 @@ package body Exp_Ch7 is
Make_Op_Subtract (Loc,
Left_Opnd => Expr,
Right_Opnd => New_Occurrence_Of (Counter_Id, Loc)));
- end Build_Counter_Assignment;
+ end Build_Assignment;
-----------------------------
-- Build_Finalization_Call --
@@ -5734,14 +7411,31 @@ package body Exp_Ch7 is
return Make_Init_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ);
end Build_Initialization_Call;
+ -- Local variables
+
+ Counter_Id : Entity_Id;
+ Dim : Int;
+ F : Node_Id;
+ Fin_Stmt : Node_Id;
+ Final_Block : Node_Id;
+ Final_Data : Finalization_Exception_Data;
+ Final_Decls : List_Id := No_List;
+ Final_Loop : Node_Id;
+ Init_Block : Node_Id;
+ Init_Call : Node_Id;
+ Init_Loop : Node_Id;
+ J : Node_Id;
+ Loop_Id : Node_Id;
+ Stmts : List_Id;
+
-- Start of processing for Build_Initialize_Statements
begin
- Counter_Id := Make_Temporary (Loc, 'C');
- Finalizer_Decls := New_List;
+ Counter_Id := Make_Temporary (Loc, 'C');
+ Final_Decls := New_List;
Build_Indexes;
- Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc);
+ Build_Object_Declarations (Final_Data, Final_Decls, Loc);
-- Generate the block which houses the finalization call, the index
-- guard and the handler which triggers Program_Error later on.
@@ -5760,115 +7454,124 @@ package body Exp_Ch7 is
-- end;
-- end if;
- if Exceptions_OK then
- Fin_Stmt :=
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Build_Finalization_Call),
- Exception_Handlers => New_List (
- Build_Exception_Handler (Finalizer_Data))));
- else
- Fin_Stmt := Build_Finalization_Call;
- end if;
-
- -- This is the core of the loop, the dimension iterators are added
- -- one by one in reverse.
-
- Final_Loop :=
- Make_If_Statement (Loc,
- Condition =>
- Make_Op_Gt (Loc,
- Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
- Right_Opnd => Make_Integer_Literal (Loc, 0)),
+ Fin_Stmt := Build_Finalization_Call;
- Then_Statements => New_List (
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Counter_Id, Loc),
- Expression =>
- Make_Op_Subtract (Loc,
- Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
- Right_Opnd => Make_Integer_Literal (Loc, 1)))),
-
- Else_Statements => New_List (Fin_Stmt));
-
- -- Generate all finalization loops starting from the innermost
- -- dimension.
-
- -- for Fnn in reverse V'Range (Dim) loop
- -- <final loop>
- -- end loop;
+ if Present (Fin_Stmt) then
+ if Exceptions_OK then
+ Fin_Stmt :=
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Fin_Stmt),
+ Exception_Handlers => New_List (
+ Build_Exception_Handler (Final_Data))));
+ end if;
- F := Last (Final_List);
- Dim := Num_Dims;
- while Present (F) and then Dim > 0 loop
- Loop_Id := F;
- Prev (F);
- Remove (Loop_Id);
+ -- This is the core of the loop, the dimension iterators are added
+ -- one by one in reverse.
Final_Loop :=
- Make_Loop_Statement (Loc,
- Iteration_Scheme =>
- Make_Iteration_Scheme (Loc,
- Loop_Parameter_Specification =>
- Make_Loop_Parameter_Specification (Loc,
- Defining_Identifier => Loop_Id,
- Discrete_Subtype_Definition =>
- Make_Attribute_Reference (Loc,
- Prefix => Make_Identifier (Loc, Name_V),
- Attribute_Name => Name_Range,
- Expressions => New_List (
- Make_Integer_Literal (Loc, Dim))),
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Gt (Loc,
+ Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
+ Right_Opnd => Make_Integer_Literal (Loc, 0)),
+
+ Then_Statements => New_List (
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Counter_Id, Loc),
+ Expression =>
+ Make_Op_Subtract (Loc,
+ Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
+ Right_Opnd => Make_Integer_Literal (Loc, 1)))),
+
+ Else_Statements => New_List (Fin_Stmt));
+
+ -- Generate all finalization loops starting from the innermost
+ -- dimension.
+
+ -- for Fnn in reverse V'Range (Dim) loop
+ -- <final loop>
+ -- end loop;
+
+ F := Last (Final_List);
+ Dim := Num_Dims;
+ while Present (F) and then Dim > 0 loop
+ Loop_Id := F;
+ Prev (F);
+ Remove (Loop_Id);
+
+ Final_Loop :=
+ Make_Loop_Statement (Loc,
+ Iteration_Scheme =>
+ Make_Iteration_Scheme (Loc,
+ Loop_Parameter_Specification =>
+ Make_Loop_Parameter_Specification (Loc,
+ Defining_Identifier => Loop_Id,
+ Discrete_Subtype_Definition =>
+ Make_Attribute_Reference (Loc,
+ Prefix => Make_Identifier (Loc, Name_V),
+ Attribute_Name => Name_Range,
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, Dim))),
+
+ Reverse_Present => True)),
+
+ Statements => New_List (Final_Loop),
+ End_Label => Empty);
+
+ Dim := Dim - 1;
+ end loop;
- Reverse_Present => True)),
+ -- Generate the block which contains the finalization loops, the
+ -- declarations of the abort flag, the exception occurrence, the
+ -- raised flag and the conditional raise.
- Statements => New_List (Final_Loop),
- End_Label => Empty);
+ -- declare
+ -- Abort : constant Boolean := Triggered_By_Abort;
+ -- <or>
+ -- Abort : constant Boolean := False; -- no abort
- Dim := Dim - 1;
- end loop;
+ -- E : Exception_Occurrence;
+ -- Raised : Boolean := False;
- -- Generate the block which contains the finalization loops, the
- -- declarations of the abort flag, the exception occurrence, the
- -- raised flag and the conditional raise.
+ -- begin
+ -- Counter :=
+ -- V'Length (1) *
+ -- ...
+ -- V'Length (N) - Counter;
- -- declare
- -- Abort : constant Boolean := Triggered_By_Abort;
- -- <or>
- -- Abort : constant Boolean := False; -- no abort
+ -- <final loop>
- -- E : Exception_Occurrence;
- -- Raised : Boolean := False;
+ -- if Raised and then not Abort then
+ -- Raise_From_Controlled_Operation (E);
+ -- end if;
- -- begin
- -- Counter :=
- -- V'Length (1) *
- -- ...
- -- V'Length (N) - Counter;
+ -- raise;
+ -- end;
- -- <final loop>
+ Stmts := New_List (Build_Assignment (Counter_Id), Final_Loop);
- -- if Raised and then not Abort then
- -- Raise_From_Controlled_Operation (E);
- -- end if;
+ if Exceptions_OK then
+ Append_To (Stmts, Build_Raise_Statement (Final_Data));
+ Append_To (Stmts, Make_Raise_Statement (Loc));
+ end if;
- -- raise;
- -- end;
+ Final_Block :=
+ Make_Block_Statement (Loc,
+ Declarations => Final_Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stmts));
- Stmts := New_List (Build_Counter_Assignment, Final_Loop);
+ -- Otherwise previous errors or a missing full view may prevent the
+ -- proper freezing of the component type. If this is the case, there
+ -- is no [Deep_]Finalize primitive to call.
- if Exceptions_OK then
- Append_To (Stmts, Build_Raise_Statement (Finalizer_Data));
- Append_To (Stmts, Make_Raise_Statement (Loc));
+ else
+ Final_Block := Make_Null_Statement (Loc);
end if;
- Final_Block :=
- Make_Block_Statement (Loc,
- Declarations =>
- Finalizer_Decls,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts));
-
-- Generate the block which contains the initialization call and
-- the partial finalization code.
@@ -5882,70 +7585,73 @@ package body Exp_Ch7 is
-- <finalization code>
-- end;
- Init_Loop :=
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Build_Initialization_Call),
- Exception_Handlers => New_List (
- Make_Exception_Handler (Loc,
- Exception_Choices => New_List (Make_Others_Choice (Loc)),
- Statements => New_List (Final_Block)))));
-
- Append_To (Statements (Handled_Statement_Sequence (Init_Loop)),
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Counter_Id, Loc),
- Expression =>
- Make_Op_Add (Loc,
- Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
- Right_Opnd => Make_Integer_Literal (Loc, 1))));
-
- -- Generate all initialization loops starting from the innermost
- -- dimension.
-
- -- for Jnn in V'Range (Dim) loop
- -- <init loop>
- -- end loop;
-
- J := Last (Index_List);
- Dim := Num_Dims;
- while Present (J) and then Dim > 0 loop
- Loop_Id := J;
- Prev (J);
- Remove (Loop_Id);
+ Init_Call := Build_Initialization_Call;
+ if Present (Init_Call) then
Init_Loop :=
- Make_Loop_Statement (Loc,
- Iteration_Scheme =>
- Make_Iteration_Scheme (Loc,
- Loop_Parameter_Specification =>
- Make_Loop_Parameter_Specification (Loc,
- Defining_Identifier => Loop_Id,
- Discrete_Subtype_Definition =>
- Make_Attribute_Reference (Loc,
- Prefix => Make_Identifier (Loc, Name_V),
- Attribute_Name => Name_Range,
- Expressions => New_List (
- Make_Integer_Literal (Loc, Dim))))),
-
- Statements => New_List (Init_Loop),
- End_Label => Empty);
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Init_Call),
+ Exception_Handlers => New_List (
+ Make_Exception_Handler (Loc,
+ Exception_Choices => New_List (
+ Make_Others_Choice (Loc)),
+ Statements => New_List (Final_Block)))));
- Dim := Dim - 1;
- end loop;
+ Append_To (Statements (Handled_Statement_Sequence (Init_Loop)),
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Counter_Id, Loc),
+ Expression =>
+ Make_Op_Add (Loc,
+ Left_Opnd => New_Occurrence_Of (Counter_Id, Loc),
+ Right_Opnd => Make_Integer_Literal (Loc, 1))));
+
+ -- Generate all initialization loops starting from the innermost
+ -- dimension.
+
+ -- for Jnn in V'Range (Dim) loop
+ -- <init loop>
+ -- end loop;
+
+ J := Last (Index_List);
+ Dim := Num_Dims;
+ while Present (J) and then Dim > 0 loop
+ Loop_Id := J;
+ Prev (J);
+ Remove (Loop_Id);
+
+ Init_Loop :=
+ Make_Loop_Statement (Loc,
+ Iteration_Scheme =>
+ Make_Iteration_Scheme (Loc,
+ Loop_Parameter_Specification =>
+ Make_Loop_Parameter_Specification (Loc,
+ Defining_Identifier => Loop_Id,
+ Discrete_Subtype_Definition =>
+ Make_Attribute_Reference (Loc,
+ Prefix => Make_Identifier (Loc, Name_V),
+ Attribute_Name => Name_Range,
+ Expressions => New_List (
+ Make_Integer_Literal (Loc, Dim))))),
+
+ Statements => New_List (Init_Loop),
+ End_Label => Empty);
+
+ Dim := Dim - 1;
+ end loop;
- -- Generate the block which contains the counter variable and the
- -- initialization loops.
+ -- Generate the block which contains the counter variable and the
+ -- initialization loops.
- -- declare
- -- Counter : Integer := 0;
- -- begin
- -- <init loop>
- -- end;
+ -- declare
+ -- Counter : Integer := 0;
+ -- begin
+ -- <init loop>
+ -- end;
- return
- New_List (
- Make_Block_Statement (Loc,
+ Init_Block :=
+ Make_Block_Statement (Loc,
Declarations => New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Counter_Id,
@@ -5955,7 +7661,17 @@ package body Exp_Ch7 is
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Init_Loop))));
+ Statements => New_List (Init_Loop)));
+
+ -- Otherwise previous errors or a missing full view may prevent the
+ -- proper freezing of the component type. If this is the case, there
+ -- is no [Deep_]Initialize primitive to call.
+
+ else
+ Init_Block := Make_Null_Statement (Loc);
+ end if;
+
+ return New_List (Init_Block);
end Build_Initialize_Statements;
-----------------------
@@ -5986,8 +7702,9 @@ package body Exp_Ch7 is
when Address_Case =>
return Make_Finalize_Address_Stmts (Typ);
- when Adjust_Case |
- Finalize_Case =>
+ when Adjust_Case
+ | Finalize_Case
+ =>
return Build_Adjust_Or_Finalize_Statements (Typ);
when Initialize_Case =>
@@ -6227,7 +7944,7 @@ package body Exp_Ch7 is
procedure Preprocess_Components
(Comps : Node_Id;
- Num_Comps : out Int;
+ Num_Comps : out Nat;
Has_POC : out Boolean);
-- Examine all components in component list Comps, count all controlled
-- components and determine whether at least one of them is per-object
@@ -6241,7 +7958,8 @@ package body Exp_Ch7 is
Exceptions_OK : constant Boolean :=
not Restriction_Active (No_Exception_Propagation);
Loc : constant Source_Ptr := Sloc (Typ);
- Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
+ Typ_Def : constant Node_Id :=
+ Type_Definition (Parent (Typ));
Bod_Stmts : List_Id;
Finalizer_Data : Finalization_Exception_Data;
@@ -6260,12 +7978,7 @@ package body Exp_Ch7 is
function Process_Component_List_For_Adjust
(Comps : Node_Id) return List_Id
is
- Stmts : constant List_Id := New_List;
- Decl : Node_Id;
- Decl_Id : Entity_Id;
- Decl_Typ : Entity_Id;
- Has_POC : Boolean;
- Num_Comps : Int;
+ Stmts : constant List_Id := New_List;
procedure Process_Component_For_Adjust (Decl : Node_Id);
-- Process the declaration of a single controlled component
@@ -6275,9 +7988,10 @@ package body Exp_Ch7 is
----------------------------------
procedure Process_Component_For_Adjust (Decl : Node_Id) is
- Id : constant Entity_Id := Defining_Identifier (Decl);
- Typ : constant Entity_Id := Etype (Id);
- Adj_Stmt : Node_Id;
+ Id : constant Entity_Id := Defining_Identifier (Decl);
+ Typ : constant Entity_Id := Etype (Id);
+
+ Adj_Call : Node_Id;
begin
-- begin
@@ -6291,7 +8005,7 @@ package body Exp_Ch7 is
-- end if;
-- end;
- Adj_Stmt :=
+ Adj_Call :=
Make_Adjust_Call (
Obj_Ref =>
Make_Selected_Component (Loc,
@@ -6299,19 +8013,32 @@ package body Exp_Ch7 is
Selector_Name => Make_Identifier (Loc, Chars (Id))),
Typ => Typ);
- if Exceptions_OK then
- Adj_Stmt :=
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Adj_Stmt),
- Exception_Handlers => New_List (
- Build_Exception_Handler (Finalizer_Data))));
- end if;
+ -- Guard against a missing [Deep_]Adjust when the component
+ -- type was not properly frozen.
+
+ if Present (Adj_Call) then
+ if Exceptions_OK then
+ Adj_Call :=
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Adj_Call),
+ Exception_Handlers => New_List (
+ Build_Exception_Handler (Finalizer_Data))));
+ end if;
- Append_To (Stmts, Adj_Stmt);
+ Append_To (Stmts, Adj_Call);
+ end if;
end Process_Component_For_Adjust;
+ -- Local variables
+
+ Decl : Node_Id;
+ Decl_Id : Entity_Id;
+ Decl_Typ : Entity_Id;
+ Has_POC : Boolean;
+ Num_Comps : Nat;
+
-- Start of processing for Process_Component_List_For_Adjust
begin
@@ -6647,7 +8374,8 @@ package body Exp_Ch7 is
Exceptions_OK : constant Boolean :=
not Restriction_Active (No_Exception_Propagation);
Loc : constant Source_Ptr := Sloc (Typ);
- Typ_Def : constant Node_Id := Type_Definition (Parent (Typ));
+ Typ_Def : constant Node_Id :=
+ Type_Definition (Parent (Typ));
Bod_Stmts : List_Id;
Counter : Int := 0;
@@ -6679,7 +8407,7 @@ package body Exp_Ch7 is
Jump_Block : Node_Id;
Label : Node_Id;
Label_Id : Entity_Id;
- Num_Comps : Int;
+ Num_Comps : Nat;
Stmts : List_Id;
procedure Process_Component_For_Finalize
@@ -6705,7 +8433,7 @@ package body Exp_Ch7 is
is
Id : constant Entity_Id := Defining_Identifier (Decl);
Typ : constant Entity_Id := Etype (Id);
- Fin_Stmt : Node_Id;
+ Fin_Call : Node_Id;
begin
if Is_Local then
@@ -6769,7 +8497,7 @@ package body Exp_Ch7 is
-- end if;
-- end;
- Fin_Stmt :=
+ Fin_Call :=
Make_Final_Call
(Obj_Ref =>
Make_Selected_Component (Loc,
@@ -6777,17 +8505,22 @@ package body Exp_Ch7 is
Selector_Name => Make_Identifier (Loc, Chars (Id))),
Typ => Typ);
- if not Restriction_Active (No_Exception_Propagation) then
- Fin_Stmt :=
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Fin_Stmt),
- Exception_Handlers => New_List (
- Build_Exception_Handler (Finalizer_Data))));
- end if;
+ -- Guard against a missing [Deep_]Finalize when the component
+ -- type was not properly frozen.
+
+ if Present (Fin_Call) then
+ if Exceptions_OK then
+ Fin_Call :=
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Fin_Call),
+ Exception_Handlers => New_List (
+ Build_Exception_Handler (Finalizer_Data))));
+ end if;
- Append_To (Stmts, Fin_Stmt);
+ Append_To (Stmts, Fin_Call);
+ end if;
end Process_Component_For_Finalize;
-- Start of processing for Process_Component_List_For_Finalize
@@ -7236,7 +8969,7 @@ package body Exp_Ch7 is
procedure Preprocess_Components
(Comps : Node_Id;
- Num_Comps : out Int;
+ Num_Comps : out Nat;
Has_POC : out Boolean)
is
Decl : Node_Id;
@@ -7319,17 +9052,18 @@ package body Exp_Ch7 is
Utyp : Entity_Id;
begin
+ Ref := Obj_Ref;
+
-- Recover the proper type which contains [Deep_]Finalize
if Is_Class_Wide_Type (Typ) then
Utyp := Root_Type (Typ);
Atyp := Utyp;
- Ref := Obj_Ref;
elsif Is_Concurrent_Type (Typ) then
Utyp := Corresponding_Record_Type (Typ);
Atyp := Empty;
- Ref := Convert_Concurrent (Obj_Ref, Typ);
+ Ref := Convert_Concurrent (Ref, Typ);
elsif Is_Private_Type (Typ)
and then Present (Full_View (Typ))
@@ -7337,12 +9071,11 @@ package body Exp_Ch7 is
then
Utyp := Corresponding_Record_Type (Full_View (Typ));
Atyp := Typ;
- Ref := Convert_Concurrent (Obj_Ref, Full_View (Typ));
+ Ref := Convert_Concurrent (Ref, Full_View (Typ));
else
Utyp := Typ;
Atyp := Typ;
- Ref := Obj_Ref;
end if;
Utyp := Underlying_Type (Base_Type (Utyp));
@@ -7371,7 +9104,8 @@ package body Exp_Ch7 is
-- their parents. In this case, [Deep_]Finalize can be found in the full
-- view of the parent type.
- if Is_Tagged_Type (Utyp)
+ if Present (Utyp)
+ and then Is_Tagged_Type (Utyp)
and then Is_Derived_Type (Utyp)
and then Is_Empty_Elmt_List (Primitive_Operations (Utyp))
and then Is_Private_Type (Etype (Utyp))
@@ -7385,7 +9119,7 @@ package body Exp_Ch7 is
-- When dealing with the completion of a private type, use the base type
-- instead.
- if Utyp /= Base_Type (Utyp) then
+ if Present (Utyp) and then Utyp /= Base_Type (Utyp) then
pragma Assert (Present (Atyp) and then Is_Private_Type (Atyp));
Utyp := Base_Type (Utyp);
@@ -7393,7 +9127,14 @@ package body Exp_Ch7 is
Set_Assignment_OK (Ref);
end if;
- if Skip_Self then
+ -- The underlying type may not be present due to a missing full view. In
+ -- this case freezing did not take place and there is no [Deep_]Finalize
+ -- primitive to call.
+
+ if No (Utyp) then
+ return Empty;
+
+ elsif Skip_Self then
if Has_Controlled_Component (Utyp) then
if Is_Tagged_Type (Utyp) then
Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize);
@@ -7473,7 +9214,7 @@ package body Exp_Ch7 is
return
Make_Call (Loc,
Proc_Id => Fin_Id,
- Param => New_Copy_Tree (Ref),
+ Param => Ref,
Skip_Self => Skip_Self);
else
return Empty;
@@ -7568,18 +9309,21 @@ package body Exp_Ch7 is
---------------------------------
function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id is
- Loc : constant Source_Ptr := Sloc (Typ);
- Ptr_Typ : constant Entity_Id := Make_Temporary (Loc, 'P');
- Decls : List_Id;
- Desg_Typ : Entity_Id;
- Obj_Expr : Node_Id;
+ Loc : constant Source_Ptr := Sloc (Typ);
+
+ Decls : List_Id;
+ Desig_Typ : Entity_Id;
+ Fin_Block : Node_Id;
+ Fin_Call : Node_Id;
+ Obj_Expr : Node_Id;
+ Ptr_Typ : Entity_Id;
begin
if Is_Array_Type (Typ) then
if Is_Constrained (First_Subtype (Typ)) then
- Desg_Typ := First_Subtype (Typ);
+ Desig_Typ := First_Subtype (Typ);
else
- Desg_Typ := Base_Type (Typ);
+ Desig_Typ := Base_Type (Typ);
end if;
-- Class-wide types of constrained root types
@@ -7611,26 +9355,28 @@ package body Exp_Ch7 is
Parent_Typ := Underlying_Record_View (Parent_Typ);
end if;
- Desg_Typ := Class_Wide_Type (Underlying_Type (Parent_Typ));
+ Desig_Typ := Class_Wide_Type (Underlying_Type (Parent_Typ));
end;
-- General case
else
- Desg_Typ := Typ;
+ Desig_Typ := Typ;
end if;
-- Generate:
-- type Ptr_Typ is access all Typ;
-- for Ptr_Typ'Storage_Size use 0;
+ Ptr_Typ := Make_Temporary (Loc, 'P');
+
Decls := New_List (
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Ptr_Typ,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
All_Present => True,
- Subtype_Indication => New_Occurrence_Of (Desg_Typ, Loc))),
+ Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc))),
Make_Attribute_Definition_Clause (Loc,
Name => New_Occurrence_Of (Ptr_Typ, Loc),
@@ -7663,7 +9409,7 @@ package body Exp_Ch7 is
-- Generate:
-- Dnn : constant Storage_Offset :=
- -- Desg_Typ'Descriptor_Size / Storage_Unit;
+ -- Desig_Typ'Descriptor_Size / Storage_Unit;
Dope_Id := Make_Temporary (Loc, 'D');
@@ -7677,7 +9423,7 @@ package body Exp_Ch7 is
Make_Op_Divide (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Desg_Typ, Loc),
+ Prefix => New_Occurrence_Of (Desig_Typ, Loc),
Attribute_Name => Name_Descriptor_Size),
Right_Opnd =>
Make_Integer_Literal (Loc, System_Storage_Unit))));
@@ -7700,20 +9446,30 @@ package body Exp_Ch7 is
end;
end if;
- -- Create the block and the finalization call
+ Fin_Call :=
+ Make_Final_Call (
+ Obj_Ref =>
+ Make_Explicit_Dereference (Loc,
+ Prefix => Unchecked_Convert_To (Ptr_Typ, Obj_Expr)),
+ Typ => Desig_Typ);
- return New_List (
- Make_Block_Statement (Loc,
- Declarations => Decls,
+ if Present (Fin_Call) then
+ Fin_Block :=
+ Make_Block_Statement (Loc,
+ Declarations => Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Fin_Call)));
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Final_Call (
- Obj_Ref =>
- Make_Explicit_Dereference (Loc,
- Prefix => Unchecked_Convert_To (Ptr_Typ, Obj_Expr)),
- Typ => Desg_Typ)))));
+ -- Otherwise previous errors or a missing full view may prevent the
+ -- proper freezing of the designated type. If this is the case, there
+ -- is no [Deep_]Finalize primitive to call.
+
+ else
+ Fin_Block := Make_Null_Statement (Loc);
+ end if;
+
+ return New_List (Fin_Block);
end Make_Finalize_Address_Stmts;
-------------------------------------
@@ -7788,13 +9544,15 @@ package body Exp_Ch7 is
Utyp : Entity_Id;
begin
+ Ref := Obj_Ref;
+
-- Deal with the type and object reference. Depending on the context, an
-- object reference may need several conversions.
if Is_Concurrent_Type (Typ) then
Is_Conc := True;
Utyp := Corresponding_Record_Type (Typ);
- Ref := Convert_Concurrent (Obj_Ref, Typ);
+ Ref := Convert_Concurrent (Ref, Typ);
elsif Is_Private_Type (Typ)
and then Present (Full_View (Typ))
@@ -7802,17 +9560,15 @@ package body Exp_Ch7 is
then
Is_Conc := True;
Utyp := Corresponding_Record_Type (Underlying_Type (Typ));
- Ref := Convert_Concurrent (Obj_Ref, Underlying_Type (Typ));
+ Ref := Convert_Concurrent (Ref, Underlying_Type (Typ));
else
Is_Conc := False;
Utyp := Typ;
- Ref := Obj_Ref;
end if;
- Set_Assignment_OK (Ref);
-
Utyp := Underlying_Type (Base_Type (Utyp));
+ Set_Assignment_OK (Ref);
-- Deal with untagged derivation of private views
@@ -7829,12 +9585,20 @@ package body Exp_Ch7 is
-- completion of a private type. We need to access the base type and
-- generate a conversion to it.
- if Utyp /= Base_Type (Utyp) then
+ if Present (Utyp) and then Utyp /= Base_Type (Utyp) then
pragma Assert (Is_Private_Type (Typ));
Utyp := Base_Type (Utyp);
Ref := Unchecked_Convert_To (Utyp, Ref);
end if;
+ -- The underlying type may not be present due to a missing full view.
+ -- In this case freezing did not take place and there is no suitable
+ -- [Deep_]Initialize primitive to call.
+
+ if No (Utyp) then
+ return Empty;
+ end if;
+
-- Select the appropriate version of initialize
if Has_Controlled_Component (Utyp) then
@@ -7854,8 +9618,7 @@ package body Exp_Ch7 is
return
Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (Proc, Loc),
+ Name => New_Occurrence_Of (Proc, Loc),
Parameter_Associations => New_List (Ref));
end Make_Init_Call;
@@ -8000,14 +9763,22 @@ package body Exp_Ch7 is
elsif Ekind_In (S, E_Entry, E_Loop) then
exit;
- -- In a procedure or a block, we release on exit of the
- -- procedure or block. ??? memory leak can be created by
- -- recursive calls.
+ -- In a procedure or a block, release the sec stack on exit
+ -- from the construct. Note that an exception handler with a
+ -- choice parameter requires a declarative region in the form
+ -- of a block. The block does not physically manifest in the
+ -- tree as it only serves as a scope. Do not consider such a
+ -- block because it will never release the sec stack.
- elsif Ekind_In (S, E_Block, E_Procedure) then
+ -- ??? Memory leak can be created by recursive calls
+
+ elsif Ekind (S) = E_Procedure
+ or else (Ekind (S) = E_Block
+ and then not Is_Exception_Handler (S))
+ then
+ Set_Uses_Sec_Stack (Current_Scope, False);
Set_Uses_Sec_Stack (S, True);
Check_Restriction (No_Secondary_Stack, Action);
- Set_Uses_Sec_Stack (Current_Scope, False);
exit;
else
diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads
index 3f90f31580..0db3df5f07 100644
--- a/gcc/ada/exp_ch7.ads
+++ b/gcc/ada/exp_ch7.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -35,6 +35,11 @@ package Exp_Ch7 is
-- Finalization Management --
-----------------------------
+ procedure Build_Anonymous_Master (Ptr_Typ : Entity_Id);
+ -- Build a finalization master for an anonymous access-to-controlled type
+ -- denoted by Ptr_Typ. The master is inserted in the declarations of the
+ -- current unit.
+
procedure Build_Controlling_Procs (Typ : Entity_Id);
-- Typ is a record, and array type having controlled components.
-- Create the procedures Deep_Initialize, Deep_Adjust and Deep_Finalize
@@ -99,26 +104,38 @@ package Exp_Ch7 is
procedure Build_Finalization_Master
(Typ : Entity_Id;
- For_Anonymous : Boolean := False;
For_Lib_Level : Boolean := False;
For_Private : Boolean := False;
Context_Scope : Entity_Id := Empty;
Insertion_Node : Node_Id := Empty);
-- Build a finalization master for an access type. The designated type may
- -- not necessarely be controlled or need finalization actions depending on
- -- the context. Flag For_Anonymous must be set when creating a master for
- -- an anonymous access type. Flag For_Lib_Level must be set when creating
- -- a master for a build-in-place function call access result type. Flag
- -- For_Private must be set when the designated type contains a private
- -- component. Parameters Context_Scope and Insertion_Node must be used in
- -- conjunction with flags For_Anonymous and For_Private. Context_Scope is
- -- the scope of the context where the finalization master must be analyzed.
- -- Insertion_Node is the insertion point before which the master is to be
- -- inserted.
+ -- not necessarily be controlled or need finalization actions depending on
+ -- the context. Flag For_Lib_Level must be set when creating a master for a
+ -- build-in-place function call access result type. Flag For_Private must
+ -- be set when the designated type contains a private component. Parameters
+ -- Context_Scope and Insertion_Node must be used in conjunction with flag
+ -- For_Private. Context_Scope is the scope of the context where the
+ -- finalization master must be analyzed. Insertion_Node is the insertion
+ -- point before which the master is to be inserted.
+
+ procedure Build_Invariant_Procedure_Body
+ (Typ : Entity_Id;
+ Partial_Invariant : Boolean := False);
+ -- Create the body of the procedure which verifies the invariants of type
+ -- Typ at runtime. Flag Partial_Invariant should be set when Typ denotes a
+ -- private type, otherwise it is assumed that Typ denotes the full view of
+ -- a private type.
+
+ procedure Build_Invariant_Procedure_Declaration
+ (Typ : Entity_Id;
+ Partial_Invariant : Boolean := False);
+ -- Create the declaration of the procedure which verifies the invariants of
+ -- type Typ at runtime. Flag Partial_Invariant should be set when building
+ -- the invariant procedure for a private type.
procedure Build_Late_Proc (Typ : Entity_Id; Nam : Name_Id);
- -- Build one controlling procedure when a late body overrides one of
- -- the controlling operations.
+ -- Build one controlling procedure when a late body overrides one of the
+ -- controlling operations.
procedure Build_Object_Declarations
(Data : out Finalization_Exception_Data;
@@ -167,10 +184,11 @@ package Exp_Ch7 is
Typ : Entity_Id;
Skip_Self : Boolean := False) return Node_Id;
-- Create a call to either Adjust or Deep_Adjust depending on the structure
- -- of type Typ. Obj_Ref is an expression with no-side effect (not required
+ -- of type Typ. Obj_Ref is an expression with no side effects (not required
-- to have been previously analyzed) that references the object to be
-- adjusted. Typ is the expected type of Obj_Ref. When Skip_Self is set,
- -- only the components (if any) are adjusted.
+ -- only the components (if any) are adjusted. Return Empty if Adjust or
+ -- Deep_Adjust is not available, possibly due to previous errors.
function Make_Detach_Call (Obj_Ref : Node_Id) return Node_Id;
-- Create a call to unhook an object from an arbitrary list. Obj_Ref is the
@@ -183,11 +201,13 @@ package Exp_Ch7 is
(Obj_Ref : Node_Id;
Typ : Entity_Id;
Skip_Self : Boolean := False) return Node_Id;
- -- Create a call to either Finalize or Deep_Finalize depending on the
- -- structure of type Typ. Obj_Ref is an expression (with no-side effect
+ -- Create a call to either Finalize or Deep_Finalize, depending on the
+ -- structure of type Typ. Obj_Ref is an expression (with no side effects
-- and is not required to have been previously analyzed) that references
-- the object to be finalized. Typ is the expected type of Obj_Ref. When
- -- Skip_Self is set, only the components (if any) are finalized.
+ -- Skip_Self is set, only the components (if any) are finalized. Return
+ -- Empty if Finalize or Deep_Finalize is not available, possibly due to
+ -- previous errors.
procedure Make_Finalize_Address_Body (Typ : Entity_Id);
-- Create the body of TSS routine Finalize_Address if Typ is controlled and
@@ -198,11 +218,12 @@ package Exp_Ch7 is
function Make_Init_Call
(Obj_Ref : Node_Id;
Typ : Entity_Id) return Node_Id;
- -- Obj_Ref is an expression with no-side effect (not required to have been
- -- previously analyzed) that references the object to be initialized. Typ
- -- is the expected type of Obj_Ref, which is either a controlled type
- -- (Is_Controlled) or a type with controlled components (Has_Controlled_
- -- Components).
+ -- Create a call to either Initialize or Deep_Initialize, depending on the
+ -- structure of type Typ. Obj_Ref is an expression with no side effects
+ -- (not required to have been previously analyzed) that references the
+ -- object to be initialized. Typ is the expected type of Obj_Ref. Return
+ -- Empty if Initialize or Deep_Initialize is not available, possibly due to
+ -- previous errors.
function Make_Handler_For_Ctrl_Operation (Loc : Source_Ptr) return Node_Id;
-- Generate an implicit exception handler with an 'others' choice,
diff --git a/gcc/ada/exp_ch8.adb b/gcc/ada/exp_ch8.adb
index dfd1796ac7..9a4e5e53d1 100644
--- a/gcc/ada/exp_ch8.adb
+++ b/gcc/ada/exp_ch8.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -30,7 +30,6 @@ with Exp_Ch6; use Exp_Ch6;
with Exp_Dbug; use Exp_Dbug;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
-with Ghost; use Ghost;
with Namet; use Namet;
with Nmake; use Nmake;
with Nlists; use Nlists;
@@ -50,25 +49,14 @@ package body Exp_Ch8 is
---------------------------------------------
procedure Expand_N_Exception_Renaming_Declaration (N : Node_Id) is
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
-
Decl : Node_Id;
begin
- -- The exception renaming declaration is Ghost when it is subject to
- -- pragma Ghost or renames a Ghost entity. To accomodate both cases, set
- -- the mode now to ensure that any nodes generated during expansion are
- -- properly marked as Ghost.
-
- Set_Ghost_Mode (N);
-
Decl := Debug_Renaming_Declaration (N);
if Present (Decl) then
Insert_Action (N, Decl);
end if;
-
- Ghost_Mode := Save_Ghost_Mode;
end Expand_N_Exception_Renaming_Declaration;
------------------------------------------
@@ -116,6 +104,8 @@ package body Exp_Ch8 is
-- interested in these operations if they occur as part of the name
-- itself, subscripts are just values that are computed as part of the
-- evaluation, so their form is unimportant.
+ -- In addition, always return True for Modify_Tree_For_C since the
+ -- code generator doesn't know how to handle renamings.
-------------------------
-- Evaluation_Required --
@@ -123,7 +113,10 @@ package body Exp_Ch8 is
function Evaluation_Required (Nam : Node_Id) return Boolean is
begin
- if Nkind_In (Nam, N_Indexed_Component, N_Slice) then
+ if Modify_Tree_For_C then
+ return True;
+
+ elsif Nkind_In (Nam, N_Indexed_Component, N_Slice) then
if Is_Packed (Etype (Prefix (Nam))) then
return True;
else
@@ -156,20 +149,9 @@ package body Exp_Ch8 is
end if;
end Evaluation_Required;
- -- Local variables
-
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
-
-- Start of processing for Expand_N_Object_Renaming_Declaration
begin
- -- The object renaming declaration is Ghost when it is subject to pragma
- -- Ghost or renames a Ghost entity. To accomodate both cases, set the
- -- mode now to ensure that any nodes generated during expansion are
- -- properly marked as Ghost.
-
- Set_Ghost_Mode (N);
-
-- Perform name evaluation if required
if Evaluation_Required (Nam) then
@@ -212,8 +194,6 @@ package body Exp_Ch8 is
if Present (Decl) then
Insert_Action (N, Decl);
end if;
-
- Ghost_Mode := Save_Ghost_Mode;
end Expand_N_Object_Renaming_Declaration;
-------------------------------------------
@@ -221,18 +201,9 @@ package body Exp_Ch8 is
-------------------------------------------
procedure Expand_N_Package_Renaming_Declaration (N : Node_Id) is
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
-
Decl : Node_Id;
begin
- -- The package renaming declaration is Ghost when it is subject to
- -- pragma Ghost or renames a Ghost entity. To accomodate both cases,
- -- set the mode now to ensure that any nodes generated during expansion
- -- are properly marked as Ghost.
-
- Set_Ghost_Mode (N);
-
Decl := Debug_Renaming_Declaration (N);
if Present (Decl) then
@@ -271,8 +242,6 @@ package body Exp_Ch8 is
Insert_Action (N, Decl);
end if;
end if;
-
- Ghost_Mode := Save_Ghost_Mode;
end Expand_N_Package_Renaming_Declaration;
----------------------------------------------
@@ -322,19 +291,11 @@ package body Exp_Ch8 is
-- Local variables
- Nam : constant Node_Id := Name (N);
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
+ Nam : constant Node_Id := Name (N);
-- Start of processing for Expand_N_Subprogram_Renaming_Declaration
begin
- -- The subprogram renaming declaration is Ghost when it is subject to
- -- pragma Ghost or renames a Ghost entity. To accomodate both cases, set
- -- the mode now to ensure that any nodes created during expansion are
- -- properly flagged as ignored Ghost.
-
- Set_Ghost_Mode (N);
-
-- When the prefix of the name is a function call, we must force the
-- call to be made by removing side effects from the call, since we
-- must only call the function once.
@@ -398,8 +359,6 @@ package body Exp_Ch8 is
end if;
end;
end if;
-
- Ghost_Mode := Save_Ghost_Mode;
end Expand_N_Subprogram_Renaming_Declaration;
end Exp_Ch8;
diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb
index 11294ed532..b38aed3eaf 100644
--- a/gcc/ada/exp_ch9.adb
+++ b/gcc/ada/exp_ch9.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -60,7 +60,6 @@ with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
-with Stringt; use Stringt;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
@@ -74,7 +73,7 @@ package body Exp_Ch9 is
-- families of 128K should be reasonable in all cases, and is a documented
-- implementation restriction.
- Entry_Family_Bound : constant Int := 2**16;
+ Entry_Family_Bound : constant Pos := 2**16;
-----------------------
-- Local Subprograms --
@@ -689,11 +688,11 @@ package body Exp_Ch9 is
-- The name of the formal that holds the address of the parameter block
-- for the call.
- Comp : Entity_Id;
- Decl : Node_Id;
- Formal : Entity_Id;
- New_F : Entity_Id;
- Renamed_Formal : Node_Id;
+ Comp : Entity_Id;
+ Decl : Node_Id;
+ Formal : Entity_Id;
+ New_F : Entity_Id;
+ Renamed_Formal : Node_Id;
begin
Formal := First_Formal (Ent);
@@ -1106,6 +1105,7 @@ package body Exp_Ch9 is
procedure Build_Class_Wide_Master (Typ : Entity_Id) is
Loc : constant Source_Ptr := Sloc (Typ);
+ Master_Decl : Node_Id;
Master_Id : Entity_Id;
Master_Scope : Entity_Id;
Name_Id : Node_Id;
@@ -1146,13 +1146,12 @@ package body Exp_Ch9 is
-- the second transient scope requires a _master, it cannot use the one
-- already declared because the entity is not visible.
- Name_Id := Make_Identifier (Loc, Name_uMaster);
+ Name_Id := Make_Identifier (Loc, Name_uMaster);
+ Master_Decl := Empty;
if not Has_Master_Entity (Master_Scope)
or else No (Current_Entity_In_Scope (Name_Id))
then
- declare
- Master_Decl : Node_Id;
begin
Set_Has_Master_Entity (Master_Scope);
@@ -1214,7 +1213,17 @@ package body Exp_Ch9 is
Subtype_Mark => New_Occurrence_Of (Standard_Integer, Loc),
Name => Name_Id);
- Insert_Action (Related_Node, Ren_Decl);
+ -- If the master is declared locally, add the renaming declaration
+ -- immediately after it, to prevent access-before-elaboration in the
+ -- back-end.
+
+ if Present (Master_Decl) then
+ Insert_After (Master_Decl, Ren_Decl);
+ Analyze (Ren_Decl);
+
+ else
+ Insert_Action (Related_Node, Ren_Decl);
+ end if;
Set_Master_Id (Typ, Master_Id);
end Build_Class_Wide_Master;
@@ -1391,8 +1400,8 @@ package body Exp_Ch9 is
Prag := Pre_Post_Conditions (Items);
while Present (Prag) loop
- if Nam_In (Pragma_Name (Prag), Name_Postcondition,
- Name_Precondition)
+ if Nam_In (Pragma_Name_Unmapped (Prag),
+ Name_Postcondition, Name_Precondition)
and then Is_Checked (Prag)
then
Has_Pragma := True;
@@ -1485,6 +1494,7 @@ package body Exp_Ch9 is
Wrapper_Id :=
Make_Defining_Identifier (Loc, New_External_Name (Chars (E), 'E'));
Set_Contract_Wrapper (E, Wrapper_Id);
+ Set_Is_Entry_Wrapper (Wrapper_Id);
-- The wrapper body is analyzed when the enclosing type is frozen
@@ -1526,12 +1536,6 @@ package body Exp_Ch9 is
Set_Stored_Constraint (Rec_Ent, No_Elist);
Cdecls := New_List;
- -- Propagate type invariants to the corresponding record type
-
- Set_Has_Invariants (Rec_Ent, Has_Invariants (Ctyp));
- Set_Has_Inheritable_Invariants (Rec_Ent,
- Has_Inheritable_Invariants (Ctyp));
-
-- Use discriminals to create list of discriminants for record, and
-- create new discriminals for use in default expressions, etc. It is
-- worth noting that a task discriminant gives rise to 5 entities;
@@ -1677,395 +1681,6 @@ package body Exp_Ch9 is
return Ecount;
end Build_Entry_Count_Expression;
- -----------------------
- -- Build_Entry_Names --
- -----------------------
-
- procedure Build_Entry_Names
- (Obj_Ref : Node_Id;
- Obj_Typ : Entity_Id;
- Stmts : List_Id)
- is
- Loc : constant Source_Ptr := Sloc (Obj_Ref);
- Data : Entity_Id := Empty;
- Index : Entity_Id := Empty;
- Typ : Entity_Id := Obj_Typ;
-
- procedure Build_Entry_Name (Comp_Id : Entity_Id);
- -- Given an entry [family], create a static string which denotes the
- -- name of Comp_Id and assign it to the underlying data structure which
- -- contains the entry names of a concurrent object.
-
- function Object_Reference return Node_Id;
- -- Return a reference to field _object or _task_id depending on the
- -- concurrent object being processed.
-
- ----------------------
- -- Build_Entry_Name --
- ----------------------
-
- procedure Build_Entry_Name (Comp_Id : Entity_Id) is
- function Build_Range (Def : Node_Id) return Node_Id;
- -- Given a discrete subtype definition of an entry family, generate a
- -- range node which covers the range of Def's type.
-
- procedure Create_Index_And_Data;
- -- Generate the declarations of variables Index and Data. Subsequent
- -- calls do nothing.
-
- function Increment_Index return Node_Id;
- -- Increment the index used in the assignment of string names to the
- -- Data array.
-
- function Name_Declaration (Def_Id : Entity_Id) return Node_Id;
- -- Given the name of a temporary variable, create the following
- -- declaration for it:
- --
- -- Def_Id : aliased constant String := <String_Name_From_Buffer>;
-
- function Set_Entry_Name (Def_Id : Entity_Id) return Node_Id;
- -- Given the name of a temporary variable, place it in the array of
- -- string names. Generate:
- --
- -- Data (Index) := Def_Id'Unchecked_Access;
-
- -----------------
- -- Build_Range --
- -----------------
-
- function Build_Range (Def : Node_Id) return Node_Id is
- High : Node_Id := Type_High_Bound (Etype (Def));
- Low : Node_Id := Type_Low_Bound (Etype (Def));
-
- begin
- -- If a bound references a discriminant, generate an identifier
- -- with the same name. Resolution will map it to the formals of
- -- the init proc.
-
- if Is_Entity_Name (Low)
- and then Ekind (Entity (Low)) = E_Discriminant
- then
- Low :=
- Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Obj_Ref),
- Selector_Name => Make_Identifier (Loc, Chars (Low)));
- else
- Low := New_Copy_Tree (Low);
- end if;
-
- if Is_Entity_Name (High)
- and then Ekind (Entity (High)) = E_Discriminant
- then
- High :=
- Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Obj_Ref),
- Selector_Name => Make_Identifier (Loc, Chars (High)));
- else
- High := New_Copy_Tree (High);
- end if;
-
- return
- Make_Range (Loc,
- Low_Bound => Low,
- High_Bound => High);
- end Build_Range;
-
- ---------------------------
- -- Create_Index_And_Data --
- ---------------------------
-
- procedure Create_Index_And_Data is
- begin
- if No (Index) and then No (Data) then
- declare
- Count : RE_Id;
- Data_Typ : RE_Id;
- Size : Entity_Id;
-
- begin
- if Is_Protected_Type (Typ) then
- Count := RO_PE_Number_Of_Entries;
- Data_Typ := RE_Protected_Entry_Names_Array;
- else
- Count := RO_ST_Number_Of_Entries;
- Data_Typ := RE_Task_Entry_Names_Array;
- end if;
-
- -- Step 1: Generate the declaration of the index variable:
-
- -- Index : Entry_Index := 1;
-
- Index := Make_Temporary (Loc, 'I');
-
- Append_To (Stmts,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Index,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Entry_Index), Loc),
- Expression => Make_Integer_Literal (Loc, 1)));
-
- -- Step 2: Generate the declaration of an array to house all
- -- names:
-
- -- Size : constant Entry_Index := <Count> (Obj_Ref);
- -- Data : aliased <Data_Typ> := (1 .. Size => null);
-
- Size := Make_Temporary (Loc, 'S');
-
- Append_To (Stmts,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Size,
- Constant_Present => True,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Entry_Index), Loc),
- Expression =>
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (RTE (Count), Loc),
- Parameter_Associations =>
- New_List (Object_Reference))));
-
- Data := Make_Temporary (Loc, 'A');
-
- Append_To (Stmts,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Data,
- Aliased_Present => True,
- Object_Definition =>
- New_Occurrence_Of (RTE (Data_Typ), Loc),
- Expression =>
- Make_Aggregate (Loc,
- Component_Associations => New_List (
- Make_Component_Association (Loc,
- Choices => New_List (
- Make_Range (Loc,
- Low_Bound =>
- Make_Integer_Literal (Loc, 1),
- High_Bound =>
- New_Occurrence_Of (Size, Loc))),
- Expression => Make_Null (Loc))))));
- end;
- end if;
- end Create_Index_And_Data;
-
- ---------------------
- -- Increment_Index --
- ---------------------
-
- function Increment_Index return Node_Id is
- begin
- return
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Index, Loc),
- Expression =>
- Make_Op_Add (Loc,
- Left_Opnd => New_Occurrence_Of (Index, Loc),
- Right_Opnd => Make_Integer_Literal (Loc, 1)));
- end Increment_Index;
-
- ----------------------
- -- Name_Declaration --
- ----------------------
-
- function Name_Declaration (Def_Id : Entity_Id) return Node_Id is
- begin
- return
- Make_Object_Declaration (Loc,
- Defining_Identifier => Def_Id,
- Aliased_Present => True,
- Constant_Present => True,
- Object_Definition =>
- New_Occurrence_Of (Standard_String, Loc),
- Expression =>
- Make_String_Literal (Loc, String_From_Name_Buffer));
- end Name_Declaration;
-
- --------------------
- -- Set_Entry_Name --
- --------------------
-
- function Set_Entry_Name (Def_Id : Entity_Id) return Node_Id is
- begin
- return
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Indexed_Component (Loc,
- Prefix => New_Occurrence_Of (Data, Loc),
- Expressions => New_List (New_Occurrence_Of (Index, Loc))),
-
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Def_Id, Loc),
- Attribute_Name => Name_Unchecked_Access));
- end Set_Entry_Name;
-
- -- Local variables
-
- Temp_Id : Entity_Id;
- Subt_Def : Node_Id;
-
- -- Start of processing for Build_Entry_Name
-
- begin
- if Ekind (Comp_Id) = E_Entry_Family then
- Subt_Def := Discrete_Subtype_Definition (Parent (Comp_Id));
-
- Create_Index_And_Data;
-
- -- Step 1: Create the string name of the entry family.
- -- Generate:
- -- Temp : aliased constant String := "name ()";
-
- Temp_Id := Make_Temporary (Loc, 'S');
- Get_Name_String (Chars (Comp_Id));
- Add_Char_To_Name_Buffer (' ');
- Add_Char_To_Name_Buffer ('(');
- Add_Char_To_Name_Buffer (')');
-
- Append_To (Stmts, Name_Declaration (Temp_Id));
-
- -- Generate:
- -- for Member in Family_Low .. Family_High loop
- -- Set_Entry_Name (...);
- -- Index := Index + 1;
- -- end loop;
-
- Append_To (Stmts,
- Make_Loop_Statement (Loc,
- Iteration_Scheme =>
- Make_Iteration_Scheme (Loc,
- Loop_Parameter_Specification =>
- Make_Loop_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Temporary (Loc, 'L'),
- Discrete_Subtype_Definition =>
- Build_Range (Subt_Def))),
-
- Statements => New_List (
- Set_Entry_Name (Temp_Id),
- Increment_Index),
- End_Label => Empty));
-
- -- Entry
-
- else
- Create_Index_And_Data;
-
- -- Step 1: Create the string name of the entry. Generate:
- -- Temp : aliased constant String := "name";
-
- Temp_Id := Make_Temporary (Loc, 'S');
- Get_Name_String (Chars (Comp_Id));
-
- Append_To (Stmts, Name_Declaration (Temp_Id));
-
- -- Step 2: Associate the string name with the underlying data
- -- structure.
-
- Append_To (Stmts, Set_Entry_Name (Temp_Id));
- Append_To (Stmts, Increment_Index);
- end if;
- end Build_Entry_Name;
-
- ----------------------
- -- Object_Reference --
- ----------------------
-
- function Object_Reference return Node_Id is
- Conc_Typ : constant Entity_Id := Corresponding_Record_Type (Typ);
- Field : Name_Id;
- Ref : Node_Id;
-
- begin
- if Is_Protected_Type (Typ) then
- Field := Name_uObject;
- else
- Field := Name_uTask_Id;
- end if;
-
- Ref :=
- Make_Selected_Component (Loc,
- Prefix =>
- Unchecked_Convert_To (Conc_Typ, New_Copy_Tree (Obj_Ref)),
- Selector_Name => Make_Identifier (Loc, Field));
-
- if Is_Protected_Type (Typ) then
- Ref :=
- Make_Attribute_Reference (Loc,
- Prefix => Ref,
- Attribute_Name => Name_Unchecked_Access);
- end if;
-
- return Ref;
- end Object_Reference;
-
- -- Local variables
-
- Comp : Node_Id;
- Proc : RE_Id;
-
- -- Start of processing for Build_Entry_Names
-
- begin
- -- Retrieve the original concurrent type
-
- if Is_Concurrent_Record_Type (Typ) then
- Typ := Corresponding_Concurrent_Type (Typ);
- end if;
-
- pragma Assert (Is_Concurrent_Type (Typ));
-
- -- Nothing to do if the type has no entries
-
- if not Has_Entries (Typ) then
- return;
- end if;
-
- -- Avoid generating entry names for a protected type with only one entry
-
- if Is_Protected_Type (Typ)
- and then Find_Protection_Type (Base_Type (Typ)) /=
- RTE (RE_Protection_Entries)
- then
- return;
- end if;
-
- -- Step 1: Populate the array with statically generated strings denoting
- -- entries and entry family names.
-
- Comp := First_Entity (Typ);
- while Present (Comp) loop
- if Comes_From_Source (Comp)
- and then Ekind_In (Comp, E_Entry, E_Entry_Family)
- then
- Build_Entry_Name (Comp);
- end if;
-
- Next_Entity (Comp);
- end loop;
-
- -- Step 2: Associate the array with the related concurrent object:
-
- -- Set_Entry_Names (Obj_Ref, <Data>'Unchecked_Access);
-
- if Present (Data) then
- if Is_Protected_Type (Typ) then
- Proc := RO_PE_Set_Entry_Names;
- else
- Proc := RO_ST_Set_Entry_Names;
- end if;
-
- Append_To (Stmts,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (RTE (Proc), Loc),
- Parameter_Associations => New_List (
- Object_Reference,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Data, Loc),
- Attribute_Name => Name_Unchecked_Access))));
- end if;
- end Build_Entry_Names;
-
---------------------------
-- Build_Parameter_Block --
---------------------------
@@ -2443,13 +2058,6 @@ package body Exp_Ch9 is
Obj_Typ : Entity_Id;
Formals : List_Id) return Node_Id
is
- Loc : constant Source_Ptr := Sloc (Subp_Id);
- First_Param : Node_Id;
- Iface : Entity_Id;
- Iface_Elmt : Elmt_Id;
- Iface_Op : Entity_Id;
- Iface_Op_Elmt : Elmt_Id;
-
function Overriding_Possible
(Iface_Op : Entity_Id;
Wrapper : Entity_Id) return Boolean;
@@ -2509,7 +2117,7 @@ package body Exp_Ch9 is
Iface_Op_Param := Next (Iface_Op_Param);
end if;
- Wrapper_Param := First (Wrapper_Params);
+ Wrapper_Param := First (Wrapper_Params);
while Present (Iface_Op_Param)
and then Present (Wrapper_Param)
loop
@@ -2565,9 +2173,9 @@ package body Exp_Ch9 is
end if;
return
- Type_Conformant_Parameters (
- Parameter_Specifications (Iface_Op_Spec),
- Parameter_Specifications (Wrapper_Spec));
+ Type_Conformant_Parameters
+ (Parameter_Specifications (Iface_Op_Spec),
+ Parameter_Specifications (Wrapper_Spec));
end Overriding_Possible;
-----------------------
@@ -2616,14 +2224,13 @@ package body Exp_Ch9 is
Append_To (New_Formals,
Make_Parameter_Specification (Loc,
- Defining_Identifier =>
+ Defining_Identifier =>
Make_Defining_Identifier (Loc,
- Chars => Chars
- (Defining_Identifier (Formal))),
- In_Present => In_Present (Formal),
- Out_Present => Out_Present (Formal),
- Null_Exclusion_Present => Null_Exclusion_Present (Formal),
- Parameter_Type => Param_Type));
+ Chars => Chars (Defining_Identifier (Formal))),
+ In_Present => In_Present (Formal),
+ Out_Present => Out_Present (Formal),
+ Null_Exclusion_Present => Null_Exclusion_Present (Formal),
+ Parameter_Type => Param_Type));
Next (Formal);
end loop;
@@ -2631,6 +2238,16 @@ package body Exp_Ch9 is
return New_Formals;
end Replicate_Formals;
+ -- Local variables
+
+ Loc : constant Source_Ptr := Sloc (Subp_Id);
+ First_Param : Node_Id := Empty;
+ Iface : Entity_Id;
+ Iface_Elmt : Elmt_Id;
+ Iface_Op : Entity_Id;
+ Iface_Op_Elmt : Elmt_Id;
+ Overridden_Subp : Entity_Id;
+
-- Start of processing for Build_Wrapper_Spec
begin
@@ -2638,17 +2255,24 @@ package body Exp_Ch9 is
pragma Assert (Is_Tagged_Type (Obj_Typ));
+ -- Check if this subprogram has a profile that matches some interface
+ -- primitive.
+
+ Check_Synchronized_Overriding (Subp_Id, Overridden_Subp);
+
+ if Present (Overridden_Subp) then
+ First_Param :=
+ First (Parameter_Specifications (Parent (Overridden_Subp)));
+
-- An entry or a protected procedure can override a routine where the
-- controlling formal is either IN OUT, OUT or is of access-to-variable
-- type. Since the wrapper must have the exact same signature as that of
-- the overridden subprogram, we try to find the overriding candidate
-- and use its controlling formal.
- First_Param := Empty;
-
-- Check every implemented interface
- if Present (Interfaces (Obj_Typ)) then
+ elsif Present (Interfaces (Obj_Typ)) then
Iface_Elmt := First_Elmt (Interfaces (Obj_Typ));
Search : while Present (Iface_Elmt) loop
Iface := Node (Iface_Elmt);
@@ -2684,40 +2308,14 @@ package body Exp_Ch9 is
end loop Search;
end if;
- -- Ada 2012 (AI05-0090-1): If no interface primitive is covered by
- -- this subprogram and this is not a primitive declared between two
- -- views then force the generation of a wrapper. As an optimization,
- -- previous versions of the frontend avoid generating the wrapper;
- -- however, the wrapper facilitates locating and reporting an error
- -- when a duplicate declaration is found later. See example in
- -- AI05-0090-1.
+ -- Do not generate the wrapper if no interface primitive is covered by
+ -- the subprogram and it is not a primitive declared between two views
+ -- (see Process_Full_View).
if No (First_Param)
and then not Is_Private_Primitive_Subprogram (Subp_Id)
then
- if Is_Task_Type
- (Corresponding_Concurrent_Type (Obj_Typ))
- then
- First_Param :=
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Make_Defining_Identifier (Loc, Name_uO),
- In_Present => True,
- Out_Present => False,
- Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc));
-
- -- For entries and procedures of protected types the mode of
- -- the controlling argument must be in-out.
-
- else
- First_Param :=
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Chars => Name_uO),
- In_Present => True,
- Out_Present => (Ekind (Subp_Id) /= E_Function),
- Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc));
- end if;
+ return Empty;
end if;
declare
@@ -2792,13 +2390,16 @@ package body Exp_Ch9 is
else
pragma Assert (Is_Private_Primitive_Subprogram (Subp_Id));
+
Obj_Param :=
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uO),
- In_Present => In_Present (Parent (First_Entity (Subp_Id))),
- Out_Present => Ekind (Subp_Id) /= E_Function,
- Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc));
+ In_Present =>
+ In_Present (Parent (First_Entity (Subp_Id))),
+ Out_Present => Ekind (Subp_Id) /= E_Function,
+ Parameter_Type => New_Occurrence_Of (Obj_Typ, Loc));
+
Prepend_To (New_Formals, Obj_Param);
end if;
@@ -2998,7 +2599,7 @@ package body Exp_Ch9 is
------------------------------
function Convert_Discriminant_Ref (Bound : Node_Id) return Node_Id is
- B : Node_Id;
+ B : Node_Id;
begin
if Is_Entity_Name (Bound)
@@ -3748,10 +3349,14 @@ package body Exp_Ch9 is
Find_Enclosing_Context (Par, Context, Context_Id, Decls);
end if;
- -- Do not create a master if one already exists or there is no task
- -- hierarchy.
+ -- Nothing to do if the context already has a master
+
+ if Has_Master_Entity (Context_Id) then
+ return;
+
+ -- Nothing to do if tasks or tasking hierarchies are prohibited
- if Has_Master_Entity (Context_Id)
+ elsif Restriction_Active (No_Tasking)
or else Restriction_Active (No_Task_Hierarchy)
then
return;
@@ -3824,9 +3429,11 @@ package body Exp_Ch9 is
Master_Id : Entity_Id;
begin
- -- Nothing to do if there is no task hierarchy
+ -- Nothing to do if tasks or tasking hierarchies are prohibited
- if Restriction_Active (No_Task_Hierarchy) then
+ if Restriction_Active (No_Tasking)
+ or else Restriction_Active (No_Task_Hierarchy)
+ then
return;
end if;
@@ -4211,8 +3818,7 @@ package body Exp_Ch9 is
Unprotected_Mode => 'N');
begin
- if Ekind (Defining_Unit_Name (Specification (N))) =
- E_Subprogram_Body
+ if Ekind (Defining_Unit_Name (Specification (N))) = E_Subprogram_Body
then
Decl := Unit_Declaration_Node (Corresponding_Spec (N));
else
@@ -4229,6 +3835,15 @@ package body Exp_Ch9 is
Make_Defining_Identifier (Loc,
Chars => Build_Selected_Name (Prot_Typ, Def_Id, Append_Chr (Mode)));
+ -- Reference the original nondispatching subprogram since the analysis
+ -- of the object.operation notation may need its original name (see
+ -- Sem_Ch4.Names_Match).
+
+ if Mode = Dispatching_Mode then
+ Set_Ekind (New_Id, Ekind (Def_Id));
+ Set_Original_Protected_Subprogram (New_Id, Def_Id);
+ end if;
+
-- The unprotected operation carries the user code, and debugging
-- information must be generated for it, even though this spec does
-- not come from source. It is also convenient to allow gdb to step
@@ -4245,7 +3860,7 @@ package body Exp_Ch9 is
if Nkind (Specification (Decl)) = N_Procedure_Specification then
New_Spec :=
Make_Procedure_Specification (Loc,
- Defining_Unit_Name => New_Id,
+ Defining_Unit_Name => New_Id,
Parameter_Specifications => New_Plist);
-- Create a new specification for the anonymous subprogram type
@@ -4253,9 +3868,9 @@ package body Exp_Ch9 is
else
New_Spec :=
Make_Function_Specification (Loc,
- Defining_Unit_Name => New_Id,
+ Defining_Unit_Name => New_Id,
Parameter_Specifications => New_Plist,
- Result_Definition =>
+ Result_Definition =>
Copy_Result_Type (Result_Definition (Specification (Decl))));
Set_Return_Present (Defining_Unit_Name (New_Spec));
@@ -4273,22 +3888,22 @@ package body Exp_Ch9 is
Pid : Node_Id;
N_Op_Spec : Node_Id) return Node_Id
is
- Loc : constant Source_Ptr := Sloc (N);
- Op_Spec : Node_Id;
- P_Op_Spec : Node_Id;
- Uactuals : List_Id;
- Pformal : Node_Id;
- Unprot_Call : Node_Id;
- Sub_Body : Node_Id;
- Lock_Name : Node_Id;
- Lock_Stmt : Node_Id;
- R : Node_Id;
- Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning
- Pre_Stmts : List_Id := No_List; -- init to avoid gcc 3 warning
- Stmts : List_Id;
- Object_Parm : Node_Id;
- Exc_Safe : Boolean;
- Lock_Kind : RE_Id;
+ Loc : constant Source_Ptr := Sloc (N);
+ Op_Spec : Node_Id;
+ P_Op_Spec : Node_Id;
+ Uactuals : List_Id;
+ Pformal : Node_Id;
+ Unprot_Call : Node_Id;
+ Sub_Body : Node_Id;
+ Lock_Name : Node_Id;
+ Lock_Stmt : Node_Id;
+ R : Node_Id;
+ Return_Stmt : Node_Id := Empty; -- init to avoid gcc 3 warning
+ Pre_Stmts : List_Id := No_List; -- init to avoid gcc 3 warning
+ Stmts : List_Id;
+ Object_Parm : Node_Id;
+ Exc_Safe : Boolean;
+ Lock_Kind : RE_Id;
begin
Op_Spec := Specification (N);
@@ -4528,12 +4143,12 @@ package body Exp_Ch9 is
---------------------------------------------
procedure Build_Protected_Subprogram_Call_Cleanup
- (Op_Spec : Node_Id;
- Conc_Typ : Node_Id;
- Loc : Source_Ptr;
- Stmts : List_Id)
+ (Op_Spec : Node_Id;
+ Conc_Typ : Node_Id;
+ Loc : Source_Ptr;
+ Stmts : List_Id)
is
- Nam : Node_Id;
+ Nam : Node_Id;
begin
-- If the associated protected object has entries, a protected
@@ -4909,7 +4524,7 @@ package body Exp_Ch9 is
-- If actual is an out parameter of a null-excluding
-- access type, there is access check on entry, so set
-- Suppress_Assignment_Checks on the generated statement
- -- that assigns the actual to the parameter block
+ -- that assigns the actual to the parameter block.
Set_Suppress_Assignment_Checks (Last (Stats));
end if;
@@ -5011,12 +4626,12 @@ package body Exp_Ch9 is
-- Some additional statements for protected entry calls
- -- Protected_Entry_Call (
- -- Object => po._object'Access,
- -- E => <entry index>;
- -- Uninterpreted_Data => P'Address;
- -- Mode => Simple_Call;
- -- Block => Bnn);
+ -- Protected_Entry_Call
+ -- (Object => po._object'Access,
+ -- E => <entry index>;
+ -- Uninterpreted_Data => P'Address;
+ -- Mode => Simple_Call;
+ -- Block => Bnn);
Call :=
Make_Procedure_Call_Statement (Loc,
@@ -5033,9 +4648,10 @@ package body Exp_Ch9 is
New_Occurrence_Of (Comm_Name, Loc)));
when System_Tasking_Protected_Objects_Single_Entry =>
- -- Protected_Single_Entry_Call (
- -- Object => po._object'Access,
- -- Uninterpreted_Data => P'Address);
+
+ -- Protected_Single_Entry_Call
+ -- (Object => po._object'Access,
+ -- Uninterpreted_Data => P'Address);
Call :=
Make_Procedure_Call_Statement (Loc,
@@ -5276,7 +4892,7 @@ package body Exp_Ch9 is
Identifier => New_Occurrence_Of (Blkent, Loc),
Declarations => New_List (
- -- _Chain : Activation_Chain;
+ -- _Chain : Activation_Chain;
Make_Object_Declaration (Loc,
Defining_Identifier => Chain,
@@ -5346,7 +4962,7 @@ package body Exp_Ch9 is
Identifier => New_Occurrence_Of (Blkent, Loc),
Declarations => New_List (
- -- _Chain : Activation_Chain;
+ -- _Chain : Activation_Chain;
Make_Object_Declaration (Loc,
Defining_Identifier => Chain,
@@ -6231,16 +5847,17 @@ package body Exp_Ch9 is
procedure Expand_Access_Protected_Subprogram_Type (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Comps : List_Id;
T : constant Entity_Id := Defining_Identifier (N);
D_T : constant Entity_Id := Designated_Type (T);
D_T2 : constant Entity_Id := Make_Temporary (Loc, 'D');
E_T : constant Entity_Id := Make_Temporary (Loc, 'E');
- P_List : constant List_Id := Build_Protected_Spec
- (N, RTE (RE_Address), D_T, False);
- Decl1 : Node_Id;
- Decl2 : Node_Id;
- Def1 : Node_Id;
+ P_List : constant List_Id :=
+ Build_Protected_Spec (N, RTE (RE_Address), D_T, False);
+
+ Comps : List_Id;
+ Decl1 : Node_Id;
+ Decl2 : Node_Id;
+ Def1 : Node_Id;
begin
-- Create access to subprogram with full signature
@@ -6263,7 +5880,10 @@ package body Exp_Ch9 is
Defining_Identifier => D_T2,
Type_Definition => Def1);
- Insert_After_And_Analyze (N, Decl1);
+ -- Declare the new types before the original one since the latter will
+ -- refer to them through the Equivalent_Type slot.
+
+ Insert_Before_And_Analyze (N, Decl1);
-- Associate the access to subprogram with its original access to
-- protected subprogram type. Needed by the backend to know that this
@@ -6298,7 +5918,7 @@ package body Exp_Ch9 is
Component_List =>
Make_Component_List (Loc, Component_Items => Comps)));
- Insert_After_And_Analyze (Decl1, Decl2);
+ Insert_Before_And_Analyze (N, Decl2);
Set_Equivalent_Type (T, E_T);
end Expand_Access_Protected_Subprogram_Type;
@@ -6405,25 +6025,52 @@ package body Exp_Ch9 is
---------------------
function Is_Pure_Barrier (N : Node_Id) return Traverse_Result is
+ function Is_Count_Attribute (N : Node_Id) return Boolean;
+ -- Check whether N is part of an expansion of the Count attribute.
+ -- Return True if N represents the expanded function call.
+
+ ------------------------
+ -- Is_Count_Attribute --
+ ------------------------
+
+ function Is_Count_Attribute (N : Node_Id) return Boolean is
+ begin
+ return
+ Nkind (N) = N_Function_Call
+ and then Present (Original_Node (N))
+ and then Nkind (Original_Node (N)) = N_Attribute_Reference
+ and then Attribute_Name (Original_Node (N)) = Name_Count;
+ end Is_Count_Attribute;
+
+ -- Start of processing for Is_Pure_Barrier
+
begin
case Nkind (N) is
- when N_Expanded_Name |
- N_Identifier =>
+ when N_Expanded_Name
+ | N_Identifier
+ =>
if No (Entity (N)) then
return Abandon;
end if;
+ if Present (Parent (N))
+ and then Is_Count_Attribute (Parent (N))
+ then
+ return OK;
+ end if;
+
case Ekind (Entity (N)) is
- when E_Constant |
- E_Discriminant |
- E_Named_Integer |
- E_Named_Real |
- E_Enumeration_Literal =>
+ when E_Constant
+ | E_Discriminant
+ | E_Enumeration_Literal
+ | E_Named_Integer
+ | E_Named_Real
+ =>
return OK;
- when E_Component |
- E_Variable =>
-
+ when E_Component
+ | E_Variable
+ =>
-- A variable in the protected type is expanded as a
-- component.
@@ -6435,13 +6082,20 @@ package body Exp_Ch9 is
null;
end case;
- when N_Integer_Literal |
- N_Real_Literal |
- N_Character_Literal =>
+ when N_Function_Call =>
+ if Is_Count_Attribute (N) then
+ return OK;
+ end if;
+
+ when N_Character_Literal
+ | N_Integer_Literal
+ | N_Real_Literal
+ =>
return OK;
- when N_Op_Boolean |
- N_Op_Not =>
+ when N_Op_Boolean
+ | N_Op_Not
+ =>
if Ekind (Entity (N)) = E_Operator then
return OK;
end if;
@@ -7163,7 +6817,7 @@ package body Exp_Ch9 is
Insert_Before (N, Decl);
Analyze (Decl);
- -- Rewrite abortable part into a call to this procedure.
+ -- Rewrite abortable part into a call to this procedure
Astats :=
New_List (
@@ -7174,6 +6828,13 @@ package body Exp_Ch9 is
-- Start of processing for Expand_N_Asynchronous_Select
begin
+ -- Asynchronous select is not supported on restricted runtimes. Don't
+ -- try to expand.
+
+ if Restricted_Profile then
+ return;
+ end if;
+
Process_Statements_For_Controlled_Objects (Trig);
Process_Statements_For_Controlled_Objects (Abrt);
@@ -8386,11 +8047,27 @@ package body Exp_Ch9 is
-- simple delays imposed by the use of Protected Objects.
procedure Expand_N_Delay_Relative_Statement (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ Proc : Entity_Id;
+
begin
+ -- Try to use System.Relative_Delays.Delay_For only if available. This
+ -- is the implementation used on restricted platforms when Ada.Calendar
+ -- is not available.
+
+ if RTE_Available (RO_RD_Delay_For) then
+ Proc := RTE (RO_RD_Delay_For);
+
+ -- Otherwise, use Ada.Calendar.Delays.Delay_For and emit an error
+ -- message if not available.
+
+ else
+ Proc := RTE (RO_CA_Delay_For);
+ end if;
+
Rewrite (N,
Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (RTE (RO_CA_Delay_For), Loc),
+ Name => New_Occurrence_Of (Proc, Loc),
Parameter_Associations => New_List (Expression (N))));
Analyze (N);
end Expand_N_Delay_Relative_Statement;
@@ -8792,9 +8469,9 @@ package body Exp_Ch9 is
Op_Body := First (Declarations (N));
- -- The protected body is replaced with the bodies of its
- -- protected operations, and the declarations for internal objects
- -- that may have been created for entry family bounds.
+ -- The protected body is replaced with the bodies of its protected
+ -- operations, and the declarations for internal objects that may
+ -- have been created for entry family bounds.
Rewrite (N, Make_Null_Statement (Sloc (N)));
Analyze (N);
@@ -8915,7 +8592,6 @@ package body Exp_Ch9 is
when others =>
raise Program_Error;
-
end case;
Next (Op_Body);
@@ -8954,7 +8630,7 @@ package body Exp_Ch9 is
-- type poV (discriminants) is record
-- _Object : aliased <kind>Protection
-- [(<entry count> [, <handler count>])];
- -- [entry_family : array (bounds) of Void;]
+ -- [entry_family : array (bounds) of Void;]
-- <private data fields>
-- end record;
@@ -9020,7 +8696,7 @@ package body Exp_Ch9 is
-- the specs refer to this type.
procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is
- Discr_Map : constant Elist_Id := New_Elmt_List;
+ Discr_Map : constant Elist_Id := New_Elmt_List;
Loc : constant Source_Ptr := Sloc (N);
Prot_Typ : constant Entity_Id := Defining_Identifier (N);
@@ -9030,17 +8706,9 @@ package body Exp_Ch9 is
Pdef : constant Node_Id := Protected_Definition (N);
-- This contains two lists; one for visible and one for private decls
- Body_Arr : Node_Id;
- Body_Id : Entity_Id;
- Cdecls : List_Id;
- Comp : Node_Id;
Current_Node : Node_Id := N;
E_Count : Int;
Entries_Aggr : Node_Id;
- New_Priv : Node_Id;
- Object_Comp : Node_Id;
- Priv : Node_Id;
- Rec_Decl : Node_Id;
procedure Check_Inlining (Subp : Entity_Id);
-- If the original operation has a pragma Inline, propagate the flag
@@ -9059,7 +8727,7 @@ package body Exp_Ch9 is
function Static_Component_Size (Comp : Entity_Id) return Boolean;
-- When compiling under the Ravenscar profile, private components must
- -- have a static size, or else a protected object will require heap
+ -- have a static size, or else a protected object will require heap
-- allocation, violating the corresponding restriction. It is preferable
-- to make this check here, because it provides a better error message
-- than the back-end, which refers to the object as a whole.
@@ -9270,7 +8938,17 @@ package body Exp_Ch9 is
-- Local variables
- Sub : Node_Id;
+ Body_Arr : Node_Id;
+ Body_Id : Entity_Id;
+ Cdecls : List_Id;
+ Comp : Node_Id;
+ Expr : Node_Id;
+ New_Priv : Node_Id;
+ Obj_Def : Node_Id;
+ Object_Comp : Node_Id;
+ Priv : Node_Id;
+ Rec_Decl : Node_Id;
+ Sub : Node_Id;
-- Start of processing for Expand_N_Protected_Type_Declaration
@@ -9322,6 +9000,9 @@ package body Exp_Ch9 is
pragma Assert (Present (Pdef));
+ Insert_After (Current_Node, Rec_Decl);
+ Current_Node := Rec_Decl;
+
-- Add private field components
if Present (Private_Declarations (Pdef)) then
@@ -9349,7 +9030,7 @@ package body Exp_Ch9 is
elsif Restriction_Active (No_Implicit_Heap_Allocations) then
if not Discriminated_Size (Defining_Identifier (Priv))
then
- -- Any object of the type will be non-static.
+ -- Any object of the type will be non-static
Error_Msg_N ("component has non-static size??", Priv);
Error_Msg_NE
@@ -9357,13 +9038,12 @@ package body Exp_Ch9 is
& "violate restriction "
& "No_Implicit_Heap_Allocations??", Priv, Prot_Typ);
else
-
- -- Object will be non-static if discriminants are.
+ -- Object will be non-static if discriminants are
Error_Msg_NE
("creation of protected object of type& with "
- & "non-static discriminants will violate"
- & " restriction No_Implicit_Heap_Allocations??",
+ & "non-static discriminants will violate "
+ & "restriction No_Implicit_Heap_Allocations??",
Priv, Prot_Typ);
end if;
@@ -9374,7 +9054,7 @@ package body Exp_Ch9 is
then
if not Discriminated_Size (Defining_Identifier (Priv))
then
- -- Any object of the type will be non-static.
+ -- Any object of the type will be non-static
Error_Msg_N ("component has non-static size??", Priv);
Error_Msg_NE
@@ -9383,11 +9063,11 @@ package body Exp_Ch9 is
& "No_Implicit_Protected_Object_Allocations??",
Priv, Prot_Typ);
else
- -- Object will be non-static if discriminants are.
+ -- Object will be non-static if discriminants are
Error_Msg_NE
("creation of protected object of type& with "
- & "non-static discriminants will violate "
+ & "non-static discriminants will violate "
& "restriction "
& "No_Implicit_Protected_Object_Allocations??",
Priv, Prot_Typ);
@@ -9492,7 +9172,7 @@ package body Exp_Ch9 is
Entry_Count_Expr : constant Node_Id :=
Build_Entry_Count_Expression
(Prot_Typ, Cdecls, Loc);
- Num_Attach_Handler : Int := 0;
+ Num_Attach_Handler : Nat := 0;
Protection_Subtype : Node_Id;
Ritem : Node_Id;
@@ -9582,9 +9262,6 @@ package body Exp_Ch9 is
Append_To (Cdecls, Object_Comp);
end if;
- Insert_After (Current_Node, Rec_Decl);
- Current_Node := Rec_Decl;
-
-- Analyze the record declaration immediately after construction,
-- because the initialization procedure is needed for single object
-- declarations before the next entity is analyzed (the freeze call
@@ -9653,22 +9330,51 @@ package body Exp_Ch9 is
Current_Node := Sub;
-- Generate an overriding primitive operation specification for
- -- this subprogram if the protected type implements an interface.
+ -- this subprogram if the protected type implements an interface
+ -- and Build_Wrapper_Spec did not generate its wrapper.
if Ada_Version >= Ada_2005
and then
Present (Interfaces (Corresponding_Record_Type (Prot_Typ)))
then
- Sub :=
- Make_Subprogram_Declaration (Loc,
- Specification =>
- Build_Protected_Sub_Specification
- (Comp, Prot_Typ, Dispatching_Mode));
+ declare
+ Found : Boolean := False;
+ Prim_Elmt : Elmt_Id;
+ Prim_Op : Node_Id;
- Insert_After (Current_Node, Sub);
- Analyze (Sub);
+ begin
+ Prim_Elmt :=
+ First_Elmt
+ (Primitive_Operations
+ (Corresponding_Record_Type (Prot_Typ)));
- Current_Node := Sub;
+ while Present (Prim_Elmt) loop
+ Prim_Op := Node (Prim_Elmt);
+
+ if Is_Primitive_Wrapper (Prim_Op)
+ and then Wrapped_Entity (Prim_Op) =
+ Defining_Entity (Specification (Comp))
+ then
+ Found := True;
+ exit;
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+
+ if not Found then
+ Sub :=
+ Make_Subprogram_Declaration (Loc,
+ Specification =>
+ Build_Protected_Sub_Specification
+ (Comp, Prot_Typ, Dispatching_Mode));
+
+ Insert_After (Current_Node, Sub);
+ Analyze (Sub);
+
+ Current_Node := Sub;
+ end if;
+ end;
end if;
-- If a pragma Interrupt_Handler applies, build and add a call to
@@ -9706,6 +9412,96 @@ package body Exp_Ch9 is
end loop;
end if;
+ -- Create the declaration of an array object which contains the values
+ -- of aspect/pragma Max_Queue_Length for all entries of the protected
+ -- type. This object is later passed to the appropriate protected object
+ -- initialization routine.
+
+ if Has_Entries (Prot_Typ)
+ and then Corresponding_Runtime_Package (Prot_Typ) =
+ System_Tasking_Protected_Objects_Entries
+ then
+ declare
+ Count : Int;
+ Item : Entity_Id;
+ Max_Vals : Node_Id;
+ Maxes : List_Id;
+ Maxes_Id : Entity_Id;
+ Need_Array : Boolean := False;
+
+ begin
+ -- First check if there is any Max_Queue_Length pragma
+
+ Item := First_Entity (Prot_Typ);
+ while Present (Item) loop
+ if Is_Entry (Item) and then Has_Max_Queue_Length (Item) then
+ Need_Array := True;
+ exit;
+ end if;
+
+ Next_Entity (Item);
+ end loop;
+
+ -- Gather the Max_Queue_Length values of all entries in a list. A
+ -- value of zero indicates that the entry has no limitation on its
+ -- queue length.
+
+ if Need_Array then
+ Count := 0;
+ Item := First_Entity (Prot_Typ);
+ Maxes := New_List;
+ while Present (Item) loop
+ if Is_Entry (Item) then
+ Count := Count + 1;
+ Append_To (Maxes,
+ Make_Integer_Literal
+ (Loc, Get_Max_Queue_Length (Item)));
+ end if;
+
+ Next_Entity (Item);
+ end loop;
+
+ -- Create the declaration of the array object. Generate:
+
+ -- Maxes_Id : aliased constant
+ -- Protected_Entry_Queue_Max_Array
+ -- (1 .. Count) := (..., ...);
+
+ Maxes_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Prot_Typ), 'B'));
+
+ Max_Vals :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Maxes_Id,
+ Aliased_Present => True,
+ Constant_Present => True,
+ Object_Definition =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of
+ (RTE (RE_Protected_Entry_Queue_Max_Array), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => New_List (
+ Make_Range (Loc,
+ Make_Integer_Literal (Loc, 1),
+ Make_Integer_Literal (Loc, Count))))),
+ Expression => Make_Aggregate (Loc, Maxes));
+
+ -- A pointer to this array will be placed in the corresponding
+ -- record by its initialization procedure so this needs to be
+ -- analyzed here.
+
+ Insert_After (Current_Node, Max_Vals);
+ Current_Node := Max_Vals;
+ Analyze (Max_Vals);
+
+ Set_Entry_Max_Queue_Lengths_Array (Prot_Typ, Maxes_Id);
+ end if;
+ end;
+ end if;
+
-- Emit declaration for Entry_Bodies_Array, now that the addresses of
-- all protected subprograms have been collected.
@@ -9716,36 +9512,35 @@ package body Exp_Ch9 is
case Corresponding_Runtime_Package (Prot_Typ) is
when System_Tasking_Protected_Objects_Entries =>
- Body_Arr :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Body_Id,
- Aliased_Present => True,
- Object_Definition =>
- Make_Subtype_Indication (Loc,
- Subtype_Mark =>
- New_Occurrence_Of
- (RTE (RE_Protected_Entry_Body_Array), Loc),
- Constraint =>
- Make_Index_Or_Discriminant_Constraint (Loc,
- Constraints => New_List (
- Make_Range (Loc,
- Make_Integer_Literal (Loc, 1),
- Make_Integer_Literal (Loc, E_Count))))),
- Expression => Entries_Aggr);
+ Expr := Entries_Aggr;
+ Obj_Def :=
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of
+ (RTE (RE_Protected_Entry_Body_Array), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => New_List (
+ Make_Range (Loc,
+ Make_Integer_Literal (Loc, 1),
+ Make_Integer_Literal (Loc, E_Count)))));
when System_Tasking_Protected_Objects_Single_Entry =>
- Body_Arr :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Body_Id,
- Aliased_Present => True,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Entry_Body), Loc),
- Expression => Remove_Head (Expressions (Entries_Aggr)));
+ Expr := Remove_Head (Expressions (Entries_Aggr));
+ Obj_Def := New_Occurrence_Of (RTE (RE_Entry_Body), Loc);
when others =>
raise Program_Error;
end case;
+ Body_Arr :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Body_Id,
+ Aliased_Present => True,
+ Constant_Present => True,
+ Object_Definition => Obj_Def,
+ Expression => Expr);
+
-- A pointer to this array will be placed in the corresponding record
-- by its initialization procedure so this needs to be analyzed here.
@@ -9766,6 +9561,7 @@ package body Exp_Ch9 is
Sub :=
Make_Subprogram_Declaration (Loc,
Specification => Build_Find_Body_Index_Spec (Prot_Typ));
+
Insert_After (Current_Node, Sub);
Analyze (Sub);
end if;
@@ -9776,7 +9572,7 @@ package body Exp_Ch9 is
-- Expand_N_Requeue_Statement --
--------------------------------
- -- A non-dispatching requeue statement is expanded into one of four GNARLI
+ -- A nondispatching requeue statement is expanded into one of four GNARLI
-- operations, depending on the source and destination (task or protected
-- object). A dispatching requeue statement is expanded into a call to the
-- predefined primitive _Disp_Requeue. In addition, code is generated to
@@ -9980,7 +9776,7 @@ package body Exp_Ch9 is
-- and perform the appropriate kind of dispatching select.
function Build_Normal_Requeue return Node_Id;
- -- N denotes a non-dispatching requeue statement to either a task or a
+ -- N denotes a nondispatching requeue statement to either a task or a
-- protected entry. Build the appropriate runtime call to perform the
-- action.
@@ -10532,7 +10328,7 @@ package body Exp_Ch9 is
end if;
end;
- -- Processing for regular (non-dispatching) requeues
+ -- Processing for regular (nondispatching) requeues
else
Rewrite (N, Build_Normal_Requeue);
@@ -10578,7 +10374,7 @@ package body Exp_Ch9 is
Delay_Val : Entity_Id;
Delay_Index : Entity_Id;
Delay_Min : Entity_Id;
- Delay_Num : Int := 1;
+ Delay_Num : Pos := 1;
Delay_Alt_List : List_Id := New_List;
Delay_List : constant List_Id := New_List;
D : Entity_Id;
@@ -10588,9 +10384,9 @@ package body Exp_Ch9 is
Guard_Open : Entity_Id;
End_Lab : Node_Id;
- Index : Int := 1;
+ Index : Pos := 1;
Lab : Node_Id;
- Num_Alts : Int;
+ Num_Alts : Nat;
Num_Accept : Nat := 0;
Proc : Node_Id;
Time_Type : Entity_Id;
@@ -11796,14 +11592,15 @@ package body Exp_Ch9 is
-- values of this task. The general form of this type declaration is
-- type taskV (discriminants) is record
- -- _Task_Id : Task_Id;
- -- entry_family : array (bounds) of Void;
- -- _Priority : Integer := priority_expression;
- -- _Size : Size_Type := size_expression;
- -- _Task_Info : Task_Info_Type := task_info_expression;
- -- _CPU : Integer := cpu_range_expression;
- -- _Relative_Deadline : Time_Span := time_span_expression;
- -- _Domain : Dispatching_Domain := dd_expression;
+ -- _Task_Id : Task_Id;
+ -- entry_family : array (bounds) of Void;
+ -- _Priority : Integer := priority_expression;
+ -- _Size : Size_Type := size_expression;
+ -- _Secondary_Stack_Size : Size_Type := size_expression;
+ -- _Task_Info : Task_Info_Type := task_info_expression;
+ -- _CPU : Integer := cpu_range_expression;
+ -- _Relative_Deadline : Time_Span := time_span_expression;
+ -- _Domain : Dispatching_Domain := dd_expression;
-- end record;
-- The discriminants are present only if the corresponding task type has
@@ -11827,6 +11624,13 @@ package body Exp_Ch9 is
-- in the pragma, and is used to override the task stack size otherwise
-- associated with the task type.
+ -- The _Secondary_Stack_Size field is present only the task entity has a
+ -- Secondary_Stack_Size rep item. It will be filled at the freeze point,
+ -- when the record init proc is built, to capture the expression of the
+ -- rep item (see Build_Record_Init_Proc in Exp_Ch3). Note that it cannot
+ -- be filled here since aspect evaluations are delayed till the freeze
+ -- point.
+
-- The _Priority field is present only if the task entity has a Priority or
-- Interrupt_Priority rep item (pragma, aspect specification or attribute
-- definition clause). It will be filled at the freeze point, when the
@@ -12166,6 +11970,24 @@ package body Exp_Ch9 is
Get_Rep_Pragma (TaskId, Name_Storage_Size))))))));
end if;
+ -- Add the _Secondary_Stack_Size component if a Secondary_Stack_Size
+ -- rep item is present.
+
+ if Has_Rep_Item
+ (TaskId, Name_Secondary_Stack_Size, Check_Parents => False)
+ then
+ Append_To (Cdecls,
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uSecondary_Stack_Size),
+
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Occurrence_Of (RTE (RE_Size_Type), Loc))));
+ end if;
+
-- Add the _Task_Info component if a Task_Info pragma is present
if Has_Rep_Pragma (TaskId, Name_Task_Info, Check_Parents => False) then
@@ -12802,7 +12624,7 @@ package body Exp_Ch9 is
Else_Statements => D_Stats));
else
- -- Simple case of a non-dispatching trigger. Skip assignments to
+ -- Simple case of a nondispatching trigger. Skip assignments to
-- temporaries created for in-out parameters.
-- This makes unwarranted assumptions about the shape of the expanded
@@ -12988,7 +12810,6 @@ package body Exp_Ch9 is
when others =>
raise Program_Error;
-
end case;
end loop;
@@ -13196,17 +13017,30 @@ package body Exp_Ch9 is
-- package or return statement.
Context := Parent (N);
- while not Nkind_In (Context, N_Block_Statement,
- N_Entry_Body,
- N_Extended_Return_Statement,
- N_Package_Body,
- N_Package_Declaration,
- N_Subprogram_Body,
- N_Task_Body)
- loop
+ while Present (Context) loop
+ if Nkind_In (Context, N_Entry_Body,
+ N_Extended_Return_Statement,
+ N_Package_Body,
+ N_Package_Declaration,
+ N_Subprogram_Body,
+ N_Task_Body)
+ then
+ exit;
+
+ -- Do not consider block created to protect a list of statements with
+ -- an Abort_Defer / Abort_Undefer_Direct pair.
+
+ elsif Nkind (Context) = N_Block_Statement
+ and then not Is_Abort_Block (Context)
+ then
+ exit;
+ end if;
+
Context := Parent (Context);
end loop;
+ pragma Assert (Present (Context));
+
-- Extract the constituents of the context
if Nkind (Context) = N_Extended_Return_Statement then
@@ -13237,8 +13071,6 @@ package body Exp_Ch9 is
end if;
else
- Context_Decls := Declarations (Context);
-
if Nkind (Context) = N_Block_Statement then
Context_Id := Entity (Identifier (Context));
@@ -13262,9 +13094,10 @@ package body Exp_Ch9 is
else
raise Program_Error;
end if;
+
+ Context_Decls := Declarations (Context);
end if;
- pragma Assert (Present (Context));
pragma Assert (Present (Context_Id));
pragma Assert (Present (Context_Decls));
end Find_Enclosing_Context;
@@ -13611,8 +13444,8 @@ package body Exp_Ch9 is
High := Type_High_Bound (Etype (Index));
Low := Type_Low_Bound (Etype (Index));
- -- In the simple case the entry family is given by a subtype
- -- mark and the index constant has the same type.
+ -- In the simple case the entry family is given by a subtype mark
+ -- and the index constant has the same type.
if Is_Entity_Name (Original_Node (
Discrete_Subtype_Definition (Parent (Index))))
@@ -13857,17 +13690,17 @@ package body Exp_Ch9 is
function Make_Initialize_Protection
(Protect_Rec : Entity_Id) return List_Id
is
- Loc : constant Source_Ptr := Sloc (Protect_Rec);
- P_Arr : Entity_Id;
- Pdec : Node_Id;
- Ptyp : constant Node_Id :=
- Corresponding_Concurrent_Type (Protect_Rec);
- Args : List_Id;
- L : constant List_Id := New_List;
- Has_Entry : constant Boolean := Has_Entries (Ptyp);
- Prio_Type : Entity_Id;
- Prio_Var : Entity_Id := Empty;
- Restricted : constant Boolean := Restricted_Profile;
+ Loc : constant Source_Ptr := Sloc (Protect_Rec);
+ P_Arr : Entity_Id;
+ Pdec : Node_Id;
+ Ptyp : constant Node_Id :=
+ Corresponding_Concurrent_Type (Protect_Rec);
+ Args : List_Id;
+ L : constant List_Id := New_List;
+ Has_Entry : constant Boolean := Has_Entries (Ptyp);
+ Prio_Type : Entity_Id;
+ Prio_Var : Entity_Id := Empty;
+ Restricted : constant Boolean := Restricted_Profile;
begin
-- We may need two calls to properly initialize the object, one to
@@ -13935,7 +13768,7 @@ package body Exp_Ch9 is
Expression
(First (Pragma_Argument_Associations (Prio_Clause)));
- -- Get_Rep_Item returns either priority pragma.
+ -- Get_Rep_Item returns either priority pragma
if Pragma_Name (Prio_Clause) = Name_Priority then
Prio_Type := RTE (RE_Any_Priority);
@@ -14037,9 +13870,35 @@ package body Exp_Ch9 is
Called_Subp := RE_Initialize_Protection;
when others =>
- raise Program_Error;
+ raise Program_Error;
end case;
+ -- Entry_Queue_Maxes parameter. This is an access to an array of
+ -- naturals representing the entry queue maximums for each entry
+ -- in the protected type. Zero represents no max. The access is
+ -- null if there is no limit for all entries (usual case).
+
+ if Has_Entry
+ and then Pkg_Id = System_Tasking_Protected_Objects_Entries
+ then
+ if Present (Entry_Max_Queue_Lengths_Array (Ptyp)) then
+ Append_To (Args,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of
+ (Entry_Max_Queue_Lengths_Array (Ptyp), Loc),
+ Attribute_Name => Name_Unrestricted_Access));
+ else
+ Append_To (Args, Make_Null (Loc));
+ end if;
+
+ -- Edge cases exist where entry initialization functions are
+ -- called, but no entries exist, so null is appended.
+
+ elsif Pkg_Id = System_Tasking_Protected_Objects_Entries then
+ Append_To (Args, Make_Null (Loc));
+ end if;
+
-- Entry_Bodies parameter. This is a pointer to an array of
-- pointers to the entry body procedures and barrier functions of
-- the object. If the protected type has no entries this object
@@ -14115,7 +13974,7 @@ package body Exp_Ch9 is
-- or, in the case of Ravenscar:
-- Install_Restricted_Handlers
- -- (Prio, (Expr1, Proc1'access), ...., (ExprN, ProcN'access));
+ -- (Prio, ((Expr1, Proc1'access), ...., (ExprN, ProcN'access)));
declare
Args : constant List_Id := New_List;
@@ -14319,6 +14178,29 @@ package body Exp_Ch9 is
New_Occurrence_Of (Storage_Size_Variable (Ttyp), Loc));
end if;
+ -- Secondary_Stack_Size parameter. Set Default_Secondary_Stack_Size
+ -- unless there is a Secondary_Stack_Size rep item, in which case we
+ -- take the value from the rep item. If the restriction
+ -- No_Secondary_Stack is active then a size of 0 is passed regardless
+ -- to prevent the allocation of the unused stack.
+
+ if Restriction_Active (No_Secondary_Stack) then
+ Append_To (Args, Make_Integer_Literal (Loc, 0));
+
+ elsif Has_Rep_Item
+ (Ttyp, Name_Secondary_Stack_Size, Check_Parents => False)
+ then
+ Append_To (Args,
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_uSecondary_Stack_Size)));
+
+ else
+ Append_To (Args,
+ New_Occurrence_Of (RTE (RE_Unspecified_Size), Loc));
+ end if;
+
-- Task_Info parameter. Set to Unspecified_Task_Info unless there is a
-- Task_Info pragma, in which case we take the value from the pragma.
@@ -14572,9 +14454,10 @@ package body Exp_Ch9 is
or else
(Nkind (Stmt) = N_Pragma
and then
- Nam_In (Pragma_Name (Stmt), Name_Unreferenced,
- Name_Unmodified,
- Name_Warnings)))
+ Nam_In (Pragma_Name_Unmapped (Stmt),
+ Name_Unreferenced,
+ Name_Unmodified,
+ Name_Warnings)))
loop
Next (Stmt);
end loop;
@@ -14800,7 +14683,6 @@ package body Exp_Ch9 is
when others =>
return False;
-
end case;
end Trivial_Accept_OK;
diff --git a/gcc/ada/exp_ch9.ads b/gcc/ada/exp_ch9.ads
index d49201bfe0..60fc056132 100644
--- a/gcc/ada/exp_ch9.ads
+++ b/gcc/ada/exp_ch9.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -55,16 +55,6 @@ package Exp_Ch9 is
-- interface, ensure that the designated type has a _master and generate
-- a renaming of the said master to service the access type.
- procedure Build_Entry_Names
- (Obj_Ref : Node_Id;
- Obj_Typ : Entity_Id;
- Stmts : List_Id);
- -- Given a concurrent object, create static string names for all entries
- -- and entry families. Associate each name with the Protection_Entries or
- -- ATCB field of the object. Obj_Ref is a reference to the concurrent
- -- object. Obj_Typ is the type of the object. Stmts is the list where all
- -- generated code is attached.
-
procedure Build_Master_Entity (Obj_Or_Typ : Entity_Id);
-- Given the name of an object or a type which is either a task, contains
-- tasks or designates tasks, create a _master in the appropriate scope
@@ -283,7 +273,7 @@ package Exp_Ch9 is
-- is the entity for the corresponding protected type declaration.
function External_Subprogram (E : Entity_Id) return Entity_Id;
- -- return the external version of a protected operation, which locks
+ -- Return the external version of a protected operation, which locks
-- the object before invoking the internal protected subprogram body.
function Find_Master_Scope (E : Entity_Id) return Entity_Id;
diff --git a/gcc/ada/exp_code.adb b/gcc/ada/exp_code.adb
index 2b0275268c..6fbe544930 100644
--- a/gcc/ada/exp_code.adb
+++ b/gcc/ada/exp_code.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -188,7 +188,7 @@ package body Exp_Code is
-- and not modified by Clobber_Get_Next. Empty if clobber string was in
-- error (resulting in no clobber arguments being returned).
- Clobber_Ptr : Nat;
+ Clobber_Ptr : Pos;
-- Pointer to current character of string. Initialized to 1 by the call
-- to Clobber_Setup, and then updated by Clobber_Get_Next.
diff --git a/gcc/ada/exp_dbug.adb b/gcc/ada/exp_dbug.adb
index 2c1d5180fa..a2ddfc369d 100644
--- a/gcc/ada/exp_dbug.adb
+++ b/gcc/ada/exp_dbug.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -333,7 +333,8 @@ package body Exp_Dbug is
----------------------------
procedure Enable_If_Packed_Array (N : Node_Id) is
- T : constant Entity_Id := Etype (N);
+ T : constant Entity_Id := Underlying_Type (Etype (N));
+
begin
Enable :=
Enable or else (Ekind (T) in Array_Kind
@@ -378,7 +379,6 @@ package body Exp_Dbug is
Ren := Nam;
loop
case Nkind (Ren) is
-
when N_Identifier =>
exit;
@@ -390,7 +390,20 @@ package body Exp_Dbug is
exit;
when N_Selected_Component =>
- Enable := Enable or else Is_Packed (Etype (Prefix (Ren)));
+ declare
+ First_Bit : constant Uint :=
+ Normalized_First_Bit
+ (Entity (Selector_Name (Ren)));
+
+ begin
+ Enable :=
+ Enable
+ or else Is_Packed
+ (Underlying_Type (Etype (Prefix (Ren))))
+ or else (First_Bit /= No_Uint
+ and then First_Bit /= Uint_0);
+ end;
+
Prepend_String_To_Buffer
(Get_Name_String (Chars (Selector_Name (Ren))));
Prepend_String_To_Buffer ("XR");
@@ -1441,12 +1454,52 @@ package body Exp_Dbug is
Name_Len := Full_Qualify_Len;
Name_Buffer (1 .. Name_Len) := Full_Qualify_Name (1 .. Name_Len);
+ -- Qualification needed for enumeration literals when generating C code
+ -- (to simplify their management in the backend).
+
+ elsif Modify_Tree_For_C
+ and then Ekind (Ent) = E_Enumeration_Literal
+ and then Scope (Ultimate_Alias (Ent)) /= Standard_Standard
+ then
+ Fully_Qualify_Name (Ent);
+ Name_Len := Full_Qualify_Len;
+ Name_Buffer (1 .. Name_Len) := Full_Qualify_Name (1 .. Name_Len);
+
elsif Qualify_Needed (Scope (Ent)) then
Name_Len := 0;
Set_Entity_Name (Ent);
else
Set_Has_Qualified_Name (Ent);
+
+ -- If a variable is hidden by a subsequent loop variable, qualify
+ -- the name of that loop variable to prevent visibility issues when
+ -- translating to C. Note that gdb probably never handled properly
+ -- this accidental hiding, given that loops are not scopes at
+ -- runtime. We also qualify a name if it hides an outer homonym,
+ -- and both are declared in blocks.
+
+ if Modify_Tree_For_C and then Ekind (Ent) = E_Variable then
+ if Present (Hiding_Loop_Variable (Ent)) then
+ declare
+ Var : constant Entity_Id := Hiding_Loop_Variable (Ent);
+
+ begin
+ Set_Entity_Name (Var);
+ Add_Str_To_Name_Buffer ("L");
+ Set_Chars (Var, Name_Enter);
+ end;
+
+ elsif Present (Homonym (Ent))
+ and then Ekind (Scope (Ent)) = E_Block
+ and then Ekind (Scope (Homonym (Ent))) = E_Block
+ then
+ Set_Entity_Name (Ent);
+ Add_Str_To_Name_Buffer ("B");
+ Set_Chars (Ent, Name_Enter);
+ end if;
+ end if;
+
return;
end if;
diff --git a/gcc/ada/exp_dbug.ads b/gcc/ada/exp_dbug.ads
index 827f149f70..b160caf62a 100644
--- a/gcc/ada/exp_dbug.ads
+++ b/gcc/ada/exp_dbug.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -435,6 +435,21 @@ package Exp_Dbug is
-- generating code, since the necessary information for computing the
-- proper external name is not available in this case.
+ -------------------------------------
+ -- Encoding for translation into C --
+ -------------------------------------
+
+ -- In Modify_Tree_For_C mode we must add encodings to dismabiguate cases
+ -- where Ada block structure cannot be directly translated. These cases
+ -- are as follows:
+
+ -- a) A loop variable may hide a homonym in an enclosing block
+ -- b) A block-local variable may hide a homonym in an enclosing block
+
+ -- In C these constructs are not scopes and we must distinguish the names
+ -- explicitly. In the first case we create a qualified name with the suffix
+ -- 'L', in the second case with a suffix 'B'.
+
--------------------------------------------
-- Subprograms for Handling Qualification --
--------------------------------------------
diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index 578f000bd7..d2ddb5e62e 100644
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -3448,9 +3448,9 @@ package body Exp_Disp is
(RTE (RE_Protected_Entry_Index), Loc),
Expression => Make_Identifier (Loc, Name_uI)),
- Make_Identifier (Loc, Name_uP), -- parameter block
- Make_Identifier (Loc, Name_uD), -- delay
- Make_Identifier (Loc, Name_uM), -- delay mode
+ Make_Identifier (Loc, Name_uP), -- parameter block
+ Make_Identifier (Loc, Name_uD), -- delay
+ Make_Identifier (Loc, Name_uM), -- delay mode
Make_Identifier (Loc, Name_uF)))); -- status flag
when others =>
@@ -3613,6 +3613,10 @@ package body Exp_Disp is
-- ...
-- end;
+ -- WARNING: This routine manages Ghost regions. Return statements must be
+ -- replaced by gotos which jump to the end of the routine and restore the
+ -- Ghost mode.
+
function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id is
Loc : constant Source_Ptr := Sloc (Typ);
@@ -3942,8 +3946,8 @@ package body Exp_Disp is
if Present (Thunk_Id) then
Append_To (Result, Thunk_Code);
- Prim_Table (UI_To_Int (DT_Position (Prim)))
- := Thunk_Id;
+ Prim_Table (UI_To_Int (DT_Position (Prim))) :=
+ Thunk_Id;
end if;
end if;
end if;
@@ -4367,71 +4371,62 @@ package body Exp_Disp is
-- Local variables
- Elab_Code : constant List_Id := New_List;
- Result : constant List_Id := New_List;
- Tname : constant Name_Id := Chars (Typ);
+ Elab_Code : constant List_Id := New_List;
+ Result : constant List_Id := New_List;
+ Tname : constant Name_Id := Chars (Typ);
+
+ -- The following name entries are used by Make_DT to generate a number
+ -- of entities related to a tagged type. These entities may be generated
+ -- in a scope other than that of the tagged type declaration, and if
+ -- the entities for two tagged types with the same name happen to be
+ -- generated in the same scope, we have to take care to use different
+ -- names. This is achieved by means of a unique serial number appended
+ -- to each generated entity name.
+
+ Name_DT : constant Name_Id :=
+ New_External_Name (Tname, 'T', Suffix_Index => -1);
+ Name_Exname : constant Name_Id :=
+ New_External_Name (Tname, 'E', Suffix_Index => -1);
+ Name_HT_Link : constant Name_Id :=
+ New_External_Name (Tname, 'H', Suffix_Index => -1);
+ Name_Predef_Prims : constant Name_Id :=
+ New_External_Name (Tname, 'R', Suffix_Index => -1);
+ Name_SSD : constant Name_Id :=
+ New_External_Name (Tname, 'S', Suffix_Index => -1);
+ Name_TSD : constant Name_Id :=
+ New_External_Name (Tname, 'B', Suffix_Index => -1);
+
AI : Elmt_Id;
AI_Tag_Elmt : Elmt_Id;
AI_Tag_Comp : Elmt_Id;
+ DT : Entity_Id;
DT_Aggr_List : List_Id;
DT_Constr_List : List_Id;
DT_Ptr : Entity_Id;
+ Exname : Entity_Id;
+ HT_Link : Entity_Id;
ITable : Node_Id;
I_Depth : Nat := 0;
Iface_Table_Node : Node_Id;
+ Mode : Ghost_Mode_Type;
Name_ITable : Name_Id;
Nb_Predef_Prims : Nat := 0;
Nb_Prim : Nat := 0;
New_Node : Node_Id;
Num_Ifaces : Nat := 0;
Parent_Typ : Entity_Id;
+ Predef_Prims : Entity_Id;
Prim : Entity_Id;
Prim_Elmt : Elmt_Id;
Prim_Ops_Aggr_List : List_Id;
+ SSD : Entity_Id;
Suffix_Index : Int;
Typ_Comps : Elist_Id;
Typ_Ifaces : Elist_Id;
+ TSD : Entity_Id;
TSD_Aggr_List : List_Id;
TSD_Tags_List : List_Id;
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
-
- -- The following name entries are used by Make_DT to generate a number
- -- of entities related to a tagged type. These entities may be generated
- -- in a scope other than that of the tagged type declaration, and if
- -- the entities for two tagged types with the same name happen to be
- -- generated in the same scope, we have to take care to use different
- -- names. This is achieved by means of a unique serial number appended
- -- to each generated entity name.
-
- Name_DT : constant Name_Id :=
- New_External_Name (Tname, 'T', Suffix_Index => -1);
- Name_Exname : constant Name_Id :=
- New_External_Name (Tname, 'E', Suffix_Index => -1);
- Name_HT_Link : constant Name_Id :=
- New_External_Name (Tname, 'H', Suffix_Index => -1);
- Name_Predef_Prims : constant Name_Id :=
- New_External_Name (Tname, 'R', Suffix_Index => -1);
- Name_SSD : constant Name_Id :=
- New_External_Name (Tname, 'S', Suffix_Index => -1);
- Name_TSD : constant Name_Id :=
- New_External_Name (Tname, 'B', Suffix_Index => -1);
-
- -- Entities built with above names
-
- DT : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Name_DT);
- Exname : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Name_Exname);
- HT_Link : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Name_HT_Link);
- Predef_Prims : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Name_Predef_Prims);
- SSD : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Name_SSD);
- TSD : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Name_TSD);
-
-- Start of processing for Make_DT
begin
@@ -4441,7 +4436,7 @@ package body Exp_Disp is
-- the mode now to ensure that any nodes generated during dispatch table
-- creation are properly marked as Ghost.
- Set_Ghost_Mode (Declaration_Node (Typ), Typ);
+ Set_Ghost_Mode (Typ, Mode);
-- Handle cases in which there is no need to build the dispatch table
@@ -4449,19 +4444,17 @@ package body Exp_Disp is
or else No (Access_Disp_Table (Typ))
or else Is_CPP_Class (Typ)
then
- Ghost_Mode := Save_Ghost_Mode;
- return Result;
+ goto Leave;
elsif No_Run_Time_Mode then
Error_Msg_CRT ("tagged types", Typ);
- Ghost_Mode := Save_Ghost_Mode;
- return Result;
+ goto Leave;
elsif not RTE_Available (RE_Tag) then
Append_To (Result,
Make_Object_Declaration (Loc,
- Defining_Identifier => Node (First_Elmt
- (Access_Disp_Table (Typ))),
+ Defining_Identifier =>
+ Node (First_Elmt (Access_Disp_Table (Typ))),
Object_Definition => New_Occurrence_Of (RTE (RE_Tag), Loc),
Constant_Present => True,
Expression =>
@@ -4470,8 +4463,7 @@ package body Exp_Disp is
Analyze_List (Result, Suppress => All_Checks);
Error_Msg_CRT ("tagged types", Typ);
- Ghost_Mode := Save_Ghost_Mode;
- return Result;
+ goto Leave;
end if;
-- Ensure that the value of Max_Predef_Prims defined in a-tags is
@@ -4481,18 +4473,23 @@ package body Exp_Disp is
if RTE_Available (RE_Interface_Data) then
if Max_Predef_Prims /= 15 then
Error_Msg_N ("run-time library configuration error", Typ);
- Ghost_Mode := Save_Ghost_Mode;
- return Result;
+ goto Leave;
end if;
else
if Max_Predef_Prims /= 9 then
Error_Msg_N ("run-time library configuration error", Typ);
Error_Msg_CRT ("tagged types", Typ);
- Ghost_Mode := Save_Ghost_Mode;
- return Result;
+ goto Leave;
end if;
end if;
+ DT := Make_Defining_Identifier (Loc, Name_DT);
+ Exname := Make_Defining_Identifier (Loc, Name_Exname);
+ HT_Link := Make_Defining_Identifier (Loc, Name_HT_Link);
+ Predef_Prims := Make_Defining_Identifier (Loc, Name_Predef_Prims);
+ SSD := Make_Defining_Identifier (Loc, Name_SSD);
+ TSD := Make_Defining_Identifier (Loc, Name_TSD);
+
-- Initialize Parent_Typ handling private types
Parent_Typ := Etype (Typ);
@@ -4695,7 +4692,7 @@ package body Exp_Disp is
Set_SCIL_Entity (New_Node, Typ);
Set_SCIL_Node (Last (Result), New_Node);
- goto Early_Exit_For_SCIL;
+ goto Leave_SCIL;
-- Gnat2scil has its own implementation of dispatch tables,
-- different than what is being implemented here. Generating
@@ -4772,7 +4769,7 @@ package body Exp_Disp is
Set_SCIL_Entity (New_Node, Typ);
Set_SCIL_Node (Last (Result), New_Node);
- goto Early_Exit_For_SCIL;
+ goto Leave_SCIL;
-- Gnat2scil has its own implementation of dispatch tables,
-- different than what is being implemented here. Generating
@@ -6238,13 +6235,15 @@ package body Exp_Disp is
end;
end if;
- <<Early_Exit_For_SCIL>>
+ <<Leave_SCIL>>
-- Register the tagged type in the call graph nodes table
Register_CG_Node (Typ);
- Ghost_Mode := Save_Ghost_Mode;
+ <<Leave>>
+ Restore_Ghost_Mode (Mode);
+
return Result;
end Make_DT;
@@ -6751,8 +6750,7 @@ package body Exp_Disp is
if Building_Static_DT (Typ) then
Iface_DT :=
Make_Defining_Identifier (Loc,
- Chars => New_External_Name
- (Typ_Name, 'T', Suffix_Index => -1));
+ Chars => New_External_Name (Typ_Name, 'T'));
Import_DT
(Tag_Typ => Related_Type (Node (AI_Tag_Comp)),
DT => Iface_DT,
diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb
index 635b2ff976..5af01bcd77 100644
--- a/gcc/ada/exp_dist.adb
+++ b/gcc/ada/exp_dist.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -504,7 +504,7 @@ package body Exp_Dist is
-- An expression whose value is a PolyORB reference to the target
-- object.
- when others =>
+ when others =>
Partition : Entity_Id;
-- A variable containing the Partition_ID of the target partition
@@ -996,6 +996,7 @@ package body Exp_Dist is
when others =>
null;
end case;
+
Next (Decl);
end loop;
end Build_Package_Stubs;
@@ -2658,6 +2659,7 @@ package body Exp_Dist is
case Get_PCS_Name is
when Name_PolyORB_DSA =>
return Make_String_Literal (Loc, Get_Subprogram_Id (E));
+
when others =>
return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
end case;
@@ -2761,8 +2763,9 @@ package body Exp_Dist is
end if;
case Nkind (Spec) is
-
- when N_Function_Specification | N_Access_Function_Definition =>
+ when N_Access_Function_Definition
+ | N_Function_Specification
+ =>
return
Make_Function_Specification (Loc,
Defining_Unit_Name =>
@@ -2772,7 +2775,9 @@ package body Exp_Dist is
Result_Definition =>
New_Occurrence_Of (Entity (Result_Definition (Spec)), Loc));
- when N_Procedure_Specification | N_Access_Procedure_Definition =>
+ when N_Access_Procedure_Definition
+ | N_Procedure_Specification
+ =>
return
Make_Procedure_Specification (Loc,
Defining_Unit_Name =>
@@ -11347,6 +11352,7 @@ package body Exp_Dist is
when Name_PolyORB_DSA =>
PolyORB_Support.Add_Obj_RPC_Receiver_Completion
(Loc, Decls, RPC_Receiver, Stub_Elements);
+
when others =>
GARLIC_Support.Add_Obj_RPC_Receiver_Completion
(Loc, Decls, RPC_Receiver, Stub_Elements);
@@ -11398,6 +11404,7 @@ package body Exp_Dist is
case Get_PCS_Name is
when Name_PolyORB_DSA =>
PolyORB_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
+
when others =>
GARLIC_Support.Add_RAST_Features (Vis_Decl, RAS_Type);
end case;
@@ -11417,6 +11424,7 @@ package body Exp_Dist is
when Name_PolyORB_DSA =>
PolyORB_Support.Add_Receiving_Stubs_To_Declarations
(Pkg_Spec, Decls, Stmts);
+
when others =>
GARLIC_Support.Add_Receiving_Stubs_To_Declarations
(Pkg_Spec, Decls, Stmts);
diff --git a/gcc/ada/exp_fixd.adb b/gcc/ada/exp_fixd.adb
index 89aaf26ef4..97bc99b837 100644
--- a/gcc/ada/exp_fixd.adb
+++ b/gcc/ada/exp_fixd.adb
@@ -404,15 +404,15 @@ package body Exp_Fixd is
(N : Node_Id;
X, Y, Z : Node_Id) return Node_Id
is
- Y_Size : constant Int := UI_To_Int (Esize (Etype (Y)));
- Z_Size : constant Int := UI_To_Int (Esize (Etype (Z)));
+ Y_Size : constant Nat := UI_To_Int (Esize (Etype (Y)));
+ Z_Size : constant Nat := UI_To_Int (Esize (Etype (Z)));
Expr : Node_Id;
begin
-- If denominator fits in 64 bits, we can build the operations directly
-- without causing any intermediate overflow, so that's what we do.
- if Int'Max (Y_Size, Z_Size) <= 32 then
+ if Nat'Max (Y_Size, Z_Size) <= 32 then
return
Build_Divide (N, X, Build_Multiply (N, Y, Z));
@@ -473,11 +473,11 @@ package body Exp_Fixd is
is
Loc : constant Source_Ptr := Sloc (N);
- X_Size : constant Int := UI_To_Int (Esize (Etype (X)));
- Y_Size : constant Int := UI_To_Int (Esize (Etype (Y)));
- Z_Size : constant Int := UI_To_Int (Esize (Etype (Z)));
+ X_Size : constant Nat := UI_To_Int (Esize (Etype (X)));
+ Y_Size : constant Nat := UI_To_Int (Esize (Etype (Y)));
+ Z_Size : constant Nat := UI_To_Int (Esize (Etype (Z)));
- QR_Siz : Int;
+ QR_Siz : Nat;
QR_Typ : Entity_Id;
Nnn : Entity_Id;
@@ -489,7 +489,7 @@ package body Exp_Fixd is
begin
-- Find type that will allow computation of numerator
- QR_Siz := Int'Max (X_Size, 2 * Int'Max (Y_Size, Z_Size));
+ QR_Siz := Nat'Max (X_Size, 2 * Nat'Max (Y_Size, Z_Size));
if QR_Siz <= 16 then
QR_Typ := Standard_Integer_16;
@@ -499,7 +499,7 @@ package body Exp_Fixd is
QR_Typ := Standard_Integer_64;
-- For more than 64, bits, we use the 64-bit integer defined in
- -- Interfaces, so that it can be handled by the runtime routine
+ -- Interfaces, so that it can be handled by the runtime routine.
else
QR_Typ := RTE (RE_Integer_64);
@@ -784,15 +784,15 @@ package body Exp_Fixd is
(N : Node_Id;
X, Y, Z : Node_Id) return Node_Id
is
- X_Size : constant Int := UI_To_Int (Esize (Etype (X)));
- Y_Size : constant Int := UI_To_Int (Esize (Etype (Y)));
+ X_Size : constant Nat := UI_To_Int (Esize (Etype (X)));
+ Y_Size : constant Nat := UI_To_Int (Esize (Etype (Y)));
Expr : Node_Id;
begin
-- If numerator fits in 64 bits, we can build the operations directly
-- without causing any intermediate overflow, so that's what we do.
- if Int'Max (X_Size, Y_Size) <= 32 then
+ if Nat'Max (X_Size, Y_Size) <= 32 then
return
Build_Divide (N, Build_Multiply (N, X, Y), Z);
@@ -850,11 +850,11 @@ package body Exp_Fixd is
is
Loc : constant Source_Ptr := Sloc (N);
- X_Size : constant Int := UI_To_Int (Esize (Etype (X)));
- Y_Size : constant Int := UI_To_Int (Esize (Etype (Y)));
- Z_Size : constant Int := UI_To_Int (Esize (Etype (Z)));
+ X_Size : constant Nat := UI_To_Int (Esize (Etype (X)));
+ Y_Size : constant Nat := UI_To_Int (Esize (Etype (Y)));
+ Z_Size : constant Nat := UI_To_Int (Esize (Etype (Z)));
- QR_Siz : Int;
+ QR_Siz : Nat;
QR_Typ : Entity_Id;
Nnn : Entity_Id;
@@ -866,7 +866,7 @@ package body Exp_Fixd is
begin
-- Find type that will allow computation of numerator
- QR_Siz := Int'Max (X_Size, 2 * Int'Max (Y_Size, Z_Size));
+ QR_Siz := Nat'Max (X_Size, 2 * Nat'Max (Y_Size, Z_Size));
if QR_Siz <= 16 then
QR_Typ := Standard_Integer_16;
@@ -876,7 +876,7 @@ package body Exp_Fixd is
QR_Typ := Standard_Integer_64;
-- For more than 64, bits, we use the 64-bit integer defined in
- -- Interfaces, so that it can be handled by the runtime routine
+ -- Interfaces, so that it can be handled by the runtime routine.
else
QR_Typ := RTE (RE_Integer_64);
diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb
index f249afe0f8..e4a07f7074 100644
--- a/gcc/ada/exp_imgv.adb
+++ b/gcc/ada/exp_imgv.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -694,7 +694,7 @@ package body Exp_Imgv is
if Ttyp = Standard_Integer_8 then
Func := RE_Value_Enumeration_8;
- elsif Ttyp = Standard_Integer_16 then
+ elsif Ttyp = Standard_Integer_16 then
Func := RE_Value_Enumeration_16;
else
Func := RE_Value_Enumeration_32;
@@ -1278,7 +1278,7 @@ package body Exp_Imgv is
when Normal =>
if Ttyp = Standard_Integer_8 then
XX := RE_Width_Enumeration_8;
- elsif Ttyp = Standard_Integer_16 then
+ elsif Ttyp = Standard_Integer_16 then
XX := RE_Width_Enumeration_16;
else
XX := RE_Width_Enumeration_32;
@@ -1287,7 +1287,7 @@ package body Exp_Imgv is
when Wide =>
if Ttyp = Standard_Integer_8 then
XX := RE_Wide_Width_Enumeration_8;
- elsif Ttyp = Standard_Integer_16 then
+ elsif Ttyp = Standard_Integer_16 then
XX := RE_Wide_Width_Enumeration_16;
else
XX := RE_Wide_Width_Enumeration_32;
@@ -1296,7 +1296,7 @@ package body Exp_Imgv is
when Wide_Wide =>
if Ttyp = Standard_Integer_8 then
XX := RE_Wide_Wide_Width_Enumeration_8;
- elsif Ttyp = Standard_Integer_16 then
+ elsif Ttyp = Standard_Integer_16 then
XX := RE_Wide_Wide_Width_Enumeration_16;
else
XX := RE_Wide_Wide_Width_Enumeration_32;
diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb
index beaa24af9e..3d0934c8d6 100644
--- a/gcc/ada/exp_intr.adb
+++ b/gcc/ada/exp_intr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -54,7 +54,6 @@ with Sinfo; use Sinfo;
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 Urealp; use Urealp;
@@ -107,63 +106,56 @@ package body Exp_Intr is
-- System.Address_To_Access_Conversions.
procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id);
- -- Rewrite the node by the appropriate string or positive constant.
- -- Nam can be one of the following:
- -- Name_File - expand string name of source file
- -- Name_Line - expand integer line number
- -- Name_Source_Location - expand string of form file:line
- -- Name_Enclosing_Entity - expand string name of enclosing entity
- -- Name_Compilation_Date - expand string with compilation date
- -- Name_Compilation_Time - expand string with compilation time
-
- procedure Write_Entity_Name (E : Entity_Id);
+ -- Rewrite the node as the appropriate string literal or positive
+ -- constant. Nam is the name of one of the intrinsics declared in
+ -- GNAT.Source_Info; see g-souinf.ads for documentation of these
+ -- intrinsics.
+
+ procedure Append_Entity_Name (Buf : in out Bounded_String; E : Entity_Id);
-- Recursive procedure to construct string for qualified name of enclosing
-- program unit. The qualification stops at an enclosing scope has no
-- source name (block or loop). If entity is a subprogram instance, skip
- -- enclosing wrapper package. The name is appended to the current contents
- -- of Name_Buffer, incrementing Name_Len.
+ -- enclosing wrapper package. The name is appended to Buf.
---------------------
-- Add_Source_Info --
---------------------
- procedure Add_Source_Info (Loc : Source_Ptr; Nam : Name_Id) is
- Ent : Entity_Id;
-
- Save_NB : constant String := Name_Buffer (1 .. Name_Len);
- Save_NL : constant Natural := Name_Len;
- -- Save current Name_Buffer contents
-
+ procedure Add_Source_Info
+ (Buf : in out Bounded_String;
+ Loc : Source_Ptr;
+ Nam : Name_Id)
+ is
begin
- Name_Len := 0;
-
- -- Line
-
case Nam is
-
when Name_Line =>
- Add_Nat_To_Name_Buffer (Nat (Get_Logical_Line_Number (Loc)));
+ Append (Buf, Nat (Get_Logical_Line_Number (Loc)));
when Name_File =>
- Get_Decoded_Name_String
- (Reference_Name (Get_Source_File_Index (Loc)));
+ Append_Decoded (Buf, Reference_Name (Get_Source_File_Index (Loc)));
when Name_Source_Location =>
- Build_Location_String (Loc);
+ Build_Location_String (Buf, Loc);
when Name_Enclosing_Entity =>
-- Skip enclosing blocks to reach enclosing unit
- Ent := Current_Scope;
- while Present (Ent) loop
- exit when not Ekind_In (Ent, E_Block, E_Loop);
- Ent := Scope (Ent);
- end loop;
+ declare
+ Ent : Entity_Id := Current_Scope;
+ begin
+ while Present (Ent) loop
+ exit when not Ekind_In (Ent, E_Block, E_Loop);
+ Ent := Scope (Ent);
+ end loop;
- -- Ent now points to the relevant defining entity
+ -- Ent now points to the relevant defining entity
+
+ Append_Entity_Name (Buf, Ent);
+ end;
- Write_Entity_Name (Ent);
+ when Name_Compilation_ISO_Date =>
+ Append (Buf, Opt.Compilation_Time (1 .. 10));
when Name_Compilation_Date =>
declare
@@ -177,34 +169,117 @@ package body Exp_Intr is
MM : constant Natural range 1 .. 12 :=
(Character'Pos (M1) - Character'Pos ('0')) * 10 +
- (Character'Pos (M2) - Character'Pos ('0'));
+ (Character'Pos (M2) - Character'Pos ('0'));
begin
-- Reformat ISO date into MMM DD YYYY (__DATE__) format
- Name_Buffer (1 .. 3) := Months (MM);
- Name_Buffer (4) := ' ';
- Name_Buffer (5 .. 6) := Opt.Compilation_Time (9 .. 10);
- Name_Buffer (7) := ' ';
- Name_Buffer (8 .. 11) := Opt.Compilation_Time (1 .. 4);
- Name_Len := 11;
+ Append (Buf, Months (MM));
+ Append (Buf, ' ');
+ Append (Buf, Opt.Compilation_Time (9 .. 10));
+ Append (Buf, ' ');
+ Append (Buf, Opt.Compilation_Time (1 .. 4));
end;
when Name_Compilation_Time =>
- Name_Buffer (1 .. 8) := Opt.Compilation_Time (12 .. 19);
- Name_Len := 8;
+ Append (Buf, Opt.Compilation_Time (12 .. 19));
when others =>
raise Program_Error;
end case;
+ end Add_Source_Info;
- -- Prepend original Name_Buffer contents
+ -----------------------
+ -- Append_Entity_Name --
+ -----------------------
- Name_Buffer (Save_NL + 1 .. Save_NL + Name_Len) :=
- Name_Buffer (1 .. Name_Len);
- Name_Buffer (1 .. Save_NL) := Save_NB;
- Name_Len := Name_Len + Save_NL;
- end Add_Source_Info;
+ procedure Append_Entity_Name (Buf : in out Bounded_String; E : Entity_Id) is
+ Temp : Bounded_String;
+
+ procedure Inner (E : Entity_Id);
+ -- Inner recursive routine, keep outer routine nonrecursive to ease
+ -- debugging when we get strange results from this routine.
+
+ -----------
+ -- Inner --
+ -----------
+
+ procedure Inner (E : Entity_Id) is
+ begin
+ -- If entity has an internal name, skip by it, and print its scope.
+ -- Note that we strip a final R from the name before the test; this
+ -- is needed for some cases of instantiations.
+
+ declare
+ E_Name : Bounded_String;
+
+ begin
+ Append (E_Name, Chars (E));
+
+ if E_Name.Chars (E_Name.Length) = 'R' then
+ E_Name.Length := E_Name.Length - 1;
+ end if;
+
+ if Is_Internal_Name (E_Name) then
+ Inner (Scope (E));
+ return;
+ end if;
+ end;
+
+ -- Just print entity name if its scope is at the outer level
+
+ if Scope (E) = Standard_Standard then
+ null;
+
+ -- If scope comes from source, write scope and entity
+
+ elsif Comes_From_Source (Scope (E)) then
+ Append_Entity_Name (Temp, Scope (E));
+ Append (Temp, '.');
+
+ -- If in wrapper package skip past it
+
+ elsif Is_Wrapper_Package (Scope (E)) then
+ Append_Entity_Name (Temp, Scope (Scope (E)));
+ Append (Temp, '.');
+
+ -- Otherwise nothing to output (happens in unnamed block statements)
+
+ else
+ null;
+ end if;
+
+ -- Output the name
+
+ declare
+ E_Name : Bounded_String;
+
+ begin
+ Append_Unqualified_Decoded (E_Name, Chars (E));
+
+ -- Remove trailing upper-case letters from the name (useful for
+ -- dealing with some cases of internal names generated in the case
+ -- of references from within a generic).
+
+ while E_Name.Length > 1
+ and then E_Name.Chars (E_Name.Length) in 'A' .. 'Z'
+ loop
+ E_Name.Length := E_Name.Length - 1;
+ end loop;
+
+ -- Adjust casing appropriately (gets name from source if possible)
+
+ Adjust_Name_Case (E_Name, Sloc (E));
+ Append (Temp, E_Name);
+ end;
+ end Inner;
+
+ -- Start of processing for Append_Entity_Name
+
+ begin
+ Inner (E);
+ Append (Buf, Temp);
+ end Append_Entity_Name;
---------------------------------
-- Expand_Binary_Operator_Call --
@@ -244,14 +319,10 @@ package body Exp_Intr is
Set_Etype (Res, T3);
case Nkind (N) is
- when N_Op_And =>
- Set_Entity (Res, Standard_Op_And);
- when N_Op_Or =>
- Set_Entity (Res, Standard_Op_Or);
- when N_Op_Xor =>
- Set_Entity (Res, Standard_Op_Xor);
- when others =>
- raise Program_Error;
+ when N_Op_And => Set_Entity (Res, Standard_Op_And);
+ when N_Op_Or => Set_Entity (Res, Standard_Op_Or);
+ when N_Op_Xor => Set_Entity (Res, Standard_Op_Xor);
+ when others => raise Program_Error;
end case;
-- Convert operands to large enough intermediate type
@@ -696,6 +767,7 @@ package body Exp_Intr is
Name_Line,
Name_Source_Location,
Name_Enclosing_Entity,
+ Name_Compilation_ISO_Date,
Name_Compilation_Date,
Name_Compilation_Time)
then
@@ -852,8 +924,6 @@ package body Exp_Intr is
procedure Expand_Source_Info (N : Node_Id; Nam : Name_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Ent : Entity_Id;
-
begin
-- Integer cases
@@ -866,68 +936,13 @@ package body Exp_Intr is
-- String cases
else
- Name_Len := 0;
-
- case Nam is
- when Name_File =>
- Get_Decoded_Name_String
- (Reference_Name (Get_Source_File_Index (Loc)));
-
- when Name_Source_Location =>
- Build_Location_String (Loc);
-
- when Name_Enclosing_Entity =>
-
- -- Skip enclosing blocks to reach enclosing unit
-
- Ent := Current_Scope;
- while Present (Ent) loop
- exit when Ekind (Ent) /= E_Block
- and then Ekind (Ent) /= E_Loop;
- Ent := Scope (Ent);
- end loop;
-
- -- Ent now points to the relevant defining entity
-
- Write_Entity_Name (Ent);
-
- when Name_Compilation_Date =>
- declare
- subtype S13 is String (1 .. 3);
- Months : constant array (1 .. 12) of S13 :=
- ("Jan", "Feb", "Mar", "Apr", "May", "Jun",
- "Jul", "Aug", "Sep", "Oct", "Nov", "Dec");
-
- M1 : constant Character := Opt.Compilation_Time (6);
- M2 : constant Character := Opt.Compilation_Time (7);
-
- MM : constant Natural range 1 .. 12 :=
- (Character'Pos (M1) - Character'Pos ('0')) * 10 +
- (Character'Pos (M2) - Character'Pos ('0'));
-
- begin
- -- Reformat ISO date into MMM DD YYYY (__DATE__) format
-
- Name_Buffer (1 .. 3) := Months (MM);
- Name_Buffer (4) := ' ';
- Name_Buffer (5 .. 6) := Opt.Compilation_Time (9 .. 10);
- Name_Buffer (7) := ' ';
- Name_Buffer (8 .. 11) := Opt.Compilation_Time (1 .. 4);
- Name_Len := 11;
- end;
-
- when Name_Compilation_Time =>
- Name_Buffer (1 .. 8) := Opt.Compilation_Time (12 .. 19);
- Name_Len := 8;
-
- when others =>
- raise Program_Error;
- end case;
-
- Rewrite (N,
- Make_String_Literal (Loc,
- Strval => String_From_Name_Buffer));
- Analyze_And_Resolve (N, Standard_String);
+ declare
+ Buf : Bounded_String;
+ begin
+ Add_Source_Info (Buf, Loc, Nam);
+ Rewrite (N, Make_String_Literal (Loc, Strval => +Buf));
+ Analyze_And_Resolve (N, Standard_String);
+ end;
end if;
Set_Is_Static_Expression (N);
@@ -1458,109 +1473,4 @@ package body Exp_Intr is
Analyze (N);
end Expand_To_Pointer;
- -----------------------
- -- Write_Entity_Name --
- -----------------------
-
- procedure Write_Entity_Name (E : Entity_Id) is
-
- procedure Write_Entity_Name_Inner (E : Entity_Id);
- -- Inner recursive routine, keep outer routine non-recursive to ease
- -- debugging when we get strange results from this routine.
-
- -----------------------------
- -- Write_Entity_Name_Inner --
- -----------------------------
-
- procedure Write_Entity_Name_Inner (E : Entity_Id) is
- begin
- -- If entity has an internal name, skip by it, and print its scope.
- -- Note that Is_Internal_Name destroys Name_Buffer, hence the save
- -- and restore since we depend on its current contents. Note that
- -- we strip a final R from the name before the test, this is needed
- -- for some cases of instantiations.
-
- declare
- Save_NB : constant String := Name_Buffer (1 .. Name_Len);
- Save_NL : constant Natural := Name_Len;
- Iname : Boolean;
-
- begin
- Get_Name_String (Chars (E));
-
- if Name_Buffer (Name_Len) = 'R' then
- Name_Len := Name_Len - 1;
- end if;
-
- Iname := Is_Internal_Name;
-
- Name_Buffer (1 .. Save_NL) := Save_NB;
- Name_Len := Save_NL;
-
- if Iname then
- Write_Entity_Name_Inner (Scope (E));
- return;
- end if;
- end;
-
- -- Just print entity name if its scope is at the outer level
-
- if Scope (E) = Standard_Standard then
- null;
-
- -- If scope comes from source, write scope and entity
-
- elsif Comes_From_Source (Scope (E)) then
- Write_Entity_Name (Scope (E));
- Add_Char_To_Name_Buffer ('.');
-
- -- If in wrapper package skip past it
-
- elsif Is_Wrapper_Package (Scope (E)) then
- Write_Entity_Name (Scope (Scope (E)));
- Add_Char_To_Name_Buffer ('.');
-
- -- Otherwise nothing to output (happens in unnamed block statements)
-
- else
- null;
- end if;
-
- -- Output the name
-
- declare
- Save_NB : constant String := Name_Buffer (1 .. Name_Len);
- Save_NL : constant Natural := Name_Len;
-
- begin
- Get_Unqualified_Decoded_Name_String (Chars (E));
-
- -- Remove trailing upper case letters from the name (useful for
- -- dealing with some cases of internal names generated in the case
- -- of references from within a generic.
-
- while Name_Len > 1
- and then Name_Buffer (Name_Len) in 'A' .. 'Z'
- loop
- Name_Len := Name_Len - 1;
- end loop;
-
- -- Adjust casing appropriately (gets name from source if possible)
-
- Adjust_Name_Case (Sloc (E));
-
- -- Append to original entry value of Name_Buffer
-
- Name_Buffer (Save_NL + 1 .. Save_NL + Name_Len) :=
- Name_Buffer (1 .. Name_Len);
- Name_Buffer (1 .. Save_NL) := Save_NB;
- Name_Len := Save_NL + Name_Len;
- end;
- end Write_Entity_Name_Inner;
-
- -- Start of processing for Write_Entity_Name
-
- begin
- Write_Entity_Name_Inner (E);
- end Write_Entity_Name;
end Exp_Intr;
diff --git a/gcc/ada/exp_intr.ads b/gcc/ada/exp_intr.ads
index f9be797d85..693ed5f986 100644
--- a/gcc/ada/exp_intr.ads
+++ b/gcc/ada/exp_intr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -30,16 +30,14 @@ with Types; use Types;
package Exp_Intr is
- procedure Add_Source_Info (Loc : Source_Ptr; Nam : Name_Id);
- -- Append a string to Name_Buffer depending on Nam
- -- Name_File - append name of source file
- -- Name_Line - append line number
- -- Name_Source_Location - append source location (file:line)
- -- Name_Enclosing_Entity - append name of enclosing entity
- -- Name_Compilation_Date - append compilation date
- -- Name_Compilation_Time - append compilation time
- -- The caller must set Name_Buffer and Name_Len before the call. Loc is
- -- passed to provide location information where it is needed.
+ procedure Add_Source_Info
+ (Buf : in out Bounded_String;
+ Loc : Source_Ptr;
+ Nam : Name_Id);
+ -- Append a string to Buf depending on Nam, which is the name of one of the
+ -- intrinsics declared in GNAT.Source_Info; see g-souinf.ads for
+ -- documentation of these intrinsics. Loc is passed to provide location
+ -- information where it is needed.
procedure Expand_Intrinsic_Call (N : Node_Id; E : Entity_Id);
-- N is either a function call node, a procedure call statement node, or
diff --git a/gcc/ada/exp_pakd.adb b/gcc/ada/exp_pakd.adb
index d4968a325a..0ec3ef4481 100644
--- a/gcc/ada/exp_pakd.adb
+++ b/gcc/ada/exp_pakd.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -90,6 +90,12 @@ package body Exp_Pakd is
-- Standard.Integer representing the zero-based linear subscript value.
-- This expression includes any required range checks.
+ function Compute_Number_Components
+ (N : Node_Id;
+ Typ : Entity_Id) return Node_Id;
+ -- Build an expression that multiplies the length of the dimensions of the
+ -- array, used to control array equality checks.
+
procedure Convert_To_PAT_Type (Aexp : Node_Id);
-- Given an expression of a packed array type, builds a corresponding
-- expression whose type is the implementation type used to represent
@@ -396,6 +402,38 @@ package body Exp_Pakd is
end loop;
end Compute_Linear_Subscript;
+ -------------------------------
+ -- Compute_Number_Components --
+ -------------------------------
+
+ function Compute_Number_Components
+ (N : Node_Id;
+ Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+ Len_Expr : Node_Id;
+
+ begin
+ Len_Expr :=
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Length,
+ Prefix => New_Occurrence_Of (Typ, Loc),
+ Expressions => New_List (Make_Integer_Literal (Loc, 1)));
+
+ for J in 2 .. Number_Dimensions (Typ) loop
+ Len_Expr :=
+ Make_Op_Multiply (Loc,
+ Left_Opnd => Len_Expr,
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Length,
+ Prefix => New_Occurrence_Of (Typ, Loc),
+ Expressions => New_List (Make_Integer_Literal (Loc, J))));
+ end loop;
+
+ return Len_Expr;
+ end Compute_Number_Components;
+
-------------------------
-- Convert_To_PAT_Type --
-------------------------
@@ -451,7 +489,6 @@ package body Exp_Pakd is
PASize : Uint;
Decl : Node_Id;
PAT : Entity_Id;
- Len_Dim : Node_Id;
Len_Expr : Node_Id;
Len_Bits : Uint;
Bits_U1 : Node_Id;
@@ -506,6 +543,7 @@ package body Exp_Pakd is
end if;
Set_Is_Itype (PAT, True);
+ Set_Is_Packed_Array_Impl_Type (PAT, True);
Set_Packed_Array_Impl_Type (Typ, PAT);
Analyze (Decl, Suppress => All_Checks);
@@ -532,7 +570,6 @@ package body Exp_Pakd is
Init_Alignment (PAT);
Set_Parent (PAT, Empty);
Set_Associated_Node_For_Itype (PAT, Typ);
- Set_Is_Packed_Array_Impl_Type (PAT, True);
Set_Original_Array_Type (PAT, Typ);
-- Propagate representation aspects
@@ -664,8 +701,6 @@ package body Exp_Pakd is
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Typ), 'P'));
- Set_Packed_Array_Impl_Type (Typ, PAT);
-
declare
Indexes : constant List_Id := New_List;
Indx : Node_Id;
@@ -761,9 +796,6 @@ package body Exp_Pakd is
Type_Definition => Typedef);
end;
- -- Set type as packed array type and install it
-
- Set_Is_Packed_Array_Impl_Type (PAT);
Install_PAT;
return;
@@ -782,13 +814,13 @@ package body Exp_Pakd is
Make_Defining_Identifier (Loc,
Chars => Make_Packed_Array_Impl_Type_Name (Typ, Csize));
- Set_Packed_Array_Impl_Type (Typ, PAT);
Set_PB_Type;
Decl :=
Make_Subtype_Declaration (Loc,
Defining_Identifier => PAT,
Subtype_Indication => New_Occurrence_Of (PB_Type, Loc));
+
Install_PAT;
return;
@@ -806,39 +838,10 @@ package body Exp_Pakd is
Make_Defining_Identifier (Loc,
Chars => Make_Packed_Array_Impl_Type_Name (Typ, Csize));
- Set_Packed_Array_Impl_Type (Typ, PAT);
-
-- Build an expression for the length of the array in bits.
-- This is the product of the length of each of the dimensions
- declare
- J : Nat := 1;
-
- begin
- Len_Expr := Empty; -- suppress junk warning
-
- loop
- Len_Dim :=
- Make_Attribute_Reference (Loc,
- Attribute_Name => Name_Length,
- Prefix => New_Occurrence_Of (Typ, Loc),
- Expressions => New_List (
- Make_Integer_Literal (Loc, J)));
-
- if J = 1 then
- Len_Expr := Len_Dim;
-
- else
- Len_Expr :=
- Make_Op_Multiply (Loc,
- Left_Opnd => Len_Expr,
- Right_Opnd => Len_Dim);
- end if;
-
- J := J + 1;
- exit when J > Number_Dimensions (Typ);
- end loop;
- end;
+ Len_Expr := Compute_Number_Components (Typ, Typ);
-- Temporarily attach the length expression to the tree and analyze
-- and resolve it, so that we can test its value. We assume that the
@@ -1137,19 +1140,6 @@ package body Exp_Pakd is
Analyze_And_Resolve (Rhs, Ctyp);
end if;
- -- For the AAMP target, indexing of certain packed array is passed
- -- through to the back end without expansion, because the expansion
- -- results in very inefficient code on that target. This allows the
- -- GNAAMP back end to generate specialized macros that support more
- -- efficient indexing of packed arrays with components having sizes
- -- that are small powers of two.
-
- if AAMP_On_Target
- and then (Csiz = 1 or else Csiz = 2 or else Csiz = 4)
- then
- return;
- end if;
-
-- Case of component size 1,2,4 or any component size for the modular
-- case. These are the cases for which we can inline the code.
@@ -1729,19 +1719,6 @@ package body Exp_Pakd is
Ctyp := Component_Type (Atyp);
Csiz := UI_To_Int (Component_Size (Atyp));
- -- For the AAMP target, indexing of certain packed array is passed
- -- through to the back end without expansion, because the expansion
- -- results in very inefficient code on that target. This allows the
- -- GNAAMP back end to generate specialized macros that support more
- -- efficient indexing of packed arrays with components having sizes
- -- that are small powers of two.
-
- if AAMP_On_Target
- and then (Csiz = 1 or else Csiz = 2 or else Csiz = 4)
- then
- return;
- end if;
-
-- Case of component size 1,2,4 or any component size for the modular
-- case. These are the cases for which we can inline the code.
@@ -1872,21 +1849,13 @@ package body Exp_Pakd is
LLexpr :=
Make_Op_Multiply (Loc,
- Left_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ltyp, Loc),
- Attribute_Name => Name_Length),
- Right_Opnd =>
- Make_Integer_Literal (Loc, Component_Size (Ltyp)));
+ Left_Opnd => Compute_Number_Components (N, Ltyp),
+ Right_Opnd => Make_Integer_Literal (Loc, Component_Size (Ltyp)));
RLexpr :=
Make_Op_Multiply (Loc,
- Left_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Rtyp, Loc),
- Attribute_Name => Name_Length),
- Right_Opnd =>
- Make_Integer_Literal (Loc, Component_Size (Rtyp)));
+ Left_Opnd => Compute_Number_Components (N, Rtyp),
+ Right_Opnd => Make_Integer_Literal (Loc, Component_Size (Rtyp)));
-- For the modular case, we transform the comparison to:
@@ -2322,9 +2291,12 @@ package body Exp_Pakd is
-- convert to a modular type of the source length, since otherwise, on
-- a big-endian machine, we get left-justification. We do it for little-
-- endian machines as well, because there might be junk bits that are
- -- not cleared if the type is not numeric.
+ -- not cleared if the type is not numeric. This can be done only if the
+ -- source siz is different from 0 (i.e. known), otherwise we must trust
+ -- the type declarations (case of non-discrete components).
- if Source_Siz /= Target_Siz
+ if Source_Siz /= 0
+ and then Source_Siz /= Target_Siz
and then not Is_Discrete_Type (Source_Typ)
then
Src := Unchecked_Convert_To (RTE (Bits_Id (Source_Siz)), Src);
diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb
index 62aa80da00..e2a6753003 100644
--- a/gcc/ada/exp_prag.adb
+++ b/gcc/ada/exp_prag.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -32,7 +32,6 @@ with Errout; use Errout;
with Exp_Ch11; use Exp_Ch11;
with Exp_Util; use Exp_Util;
with Expander; use Expander;
-with Ghost; use Ghost;
with Inline; use Inline;
with Namet; use Namet;
with Nlists; use Nlists;
@@ -174,53 +173,48 @@ package body Exp_Prag is
return;
end if;
- -- Note: we may have a pragma whose Pragma_Identifier field is not a
- -- recognized pragma, and we must ignore it at this stage.
+ case Get_Pragma_Id (Pname) is
- if Is_Pragma_Name (Pname) then
- case Get_Pragma_Id (Pname) is
+ -- Pragmas requiring special expander action
- -- Pragmas requiring special expander action
+ when Pragma_Abort_Defer =>
+ Expand_Pragma_Abort_Defer (N);
- when Pragma_Abort_Defer =>
- Expand_Pragma_Abort_Defer (N);
+ when Pragma_Check =>
+ Expand_Pragma_Check (N);
- when Pragma_Check =>
- Expand_Pragma_Check (N);
+ when Pragma_Common_Object =>
+ Expand_Pragma_Common_Object (N);
- when Pragma_Common_Object =>
- Expand_Pragma_Common_Object (N);
+ when Pragma_Import =>
+ Expand_Pragma_Import_Or_Interface (N);
- when Pragma_Import =>
- Expand_Pragma_Import_Or_Interface (N);
+ when Pragma_Inspection_Point =>
+ Expand_Pragma_Inspection_Point (N);
- when Pragma_Inspection_Point =>
- Expand_Pragma_Inspection_Point (N);
+ when Pragma_Interface =>
+ Expand_Pragma_Import_Or_Interface (N);
- when Pragma_Interface =>
- Expand_Pragma_Import_Or_Interface (N);
+ when Pragma_Interrupt_Priority =>
+ Expand_Pragma_Interrupt_Priority (N);
- when Pragma_Interrupt_Priority =>
- Expand_Pragma_Interrupt_Priority (N);
+ when Pragma_Loop_Variant =>
+ Expand_Pragma_Loop_Variant (N);
- when Pragma_Loop_Variant =>
- Expand_Pragma_Loop_Variant (N);
+ when Pragma_Psect_Object =>
+ Expand_Pragma_Psect_Object (N);
- when Pragma_Psect_Object =>
- Expand_Pragma_Psect_Object (N);
+ when Pragma_Relative_Deadline =>
+ Expand_Pragma_Relative_Deadline (N);
- when Pragma_Relative_Deadline =>
- Expand_Pragma_Relative_Deadline (N);
+ when Pragma_Suppress_Initialization =>
+ Expand_Pragma_Suppress_Initialization (N);
- when Pragma_Suppress_Initialization =>
- Expand_Pragma_Suppress_Initialization (N);
-
- -- All other pragmas need no expander action
-
- when others => null;
- end case;
- end if;
+ -- All other pragmas need no expander action (includes
+ -- Unknown_Pragma).
+ when others => null;
+ end case;
end Expand_N_Pragma;
-------------------------------
@@ -321,8 +315,6 @@ package body Exp_Prag is
-- Assert_Failure, so that coverage analysis tools can relate the
-- call to the failed check.
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
-
begin
-- Nothing to do if pragma is ignored
@@ -330,15 +322,8 @@ package body Exp_Prag is
return;
end if;
- -- Pragmas Assert, Assert_And_Cut, Assume, Check and Loop_Invariant are
- -- Ghost when they apply to a Ghost entity. Set the mode now to ensure
- -- that any nodes generated during expansion are properly flagged as
- -- Ghost.
-
- Set_Ghost_Mode (N);
-
- -- Since this check is active, we rewrite the pragma into a
- -- corresponding if statement, and then analyze the statement.
+ -- Since this check is active, rewrite the pragma into a corresponding
+ -- if statement, and then analyze the statement.
-- The normal case expansion transforms:
@@ -496,12 +481,9 @@ package body Exp_Prag is
elsif Nam = Name_Assert then
Error_Msg_N ("?A?assertion will fail at run time", N);
else
-
Error_Msg_N ("?A?check will fail at run time", N);
end if;
end if;
-
- Ghost_Mode := Save_Ghost_Mode;
end Expand_Pragma_Check;
---------------------------------
@@ -862,31 +844,44 @@ package body Exp_Prag is
-- Generate a temporary to capture the value of the prefix:
-- Temp : <Pref type>;
- -- Place that temporary at the beginning of declarations, to
- -- prevent anomalies in the GNATprove flow-analysis pass in
- -- the precondition procedure that follows.
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Object_Definition =>
New_Occurrence_Of (Etype (Pref), Loc));
- Set_No_Initialization (Decl);
+
+ -- Place that temporary at the beginning of declarations, to
+ -- prevent anomalies in the GNATprove flow-analysis pass in
+ -- the precondition procedure that follows.
Prepend_To (Decls, Decl);
- Analyze (Decl);
- -- Evaluate the prefix, generate:
- -- Temp := <Pref>;
+ -- If the type is unconstrained, the prefix provides its
+ -- value and constraint, so add it to declaration.
- if No (Eval_Stmts) then
- Eval_Stmts := New_List;
- end if;
+ if not Is_Constrained (Etype (Pref))
+ and then Is_Entity_Name (Pref)
+ then
+ Set_Expression (Decl, Pref);
+ Analyze (Decl);
+
+ -- Otherwise add an assignment statement to temporary using
+ -- prefix as RHS.
- Append_To (Eval_Stmts,
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Temp, Loc),
- Expression => Pref));
+ else
+ Analyze (Decl);
+
+ if No (Eval_Stmts) then
+ Eval_Stmts := New_List;
+ end if;
+
+ Append_To (Eval_Stmts,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Temp, Loc),
+ Expression => Pref));
+
+ end if;
-- Ensure that the prefix is valid
@@ -988,8 +983,6 @@ package body Exp_Prag is
Aggr : constant Node_Id :=
Expression (First (Pragma_Argument_Associations (CCs)));
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
-
Case_Guard : Node_Id;
CG_Checks : Node_Id;
CG_Stmts : List_Id;
@@ -1023,12 +1016,6 @@ package body Exp_Prag is
return;
end if;
- -- The contract cases is Ghost when it applies to a Ghost entity. Set
- -- the mode now to ensure that any nodes generated during expansion are
- -- properly flagged as Ghost.
-
- Set_Ghost_Mode (CCs);
-
-- The expansion of contract cases is quite distributed as it produces
-- various statements to evaluate the case guards and consequences. To
-- preserve the original context, set the Is_Assertion_Expr flag. This
@@ -1263,7 +1250,6 @@ package body Exp_Prag is
Append_To (Stmts, Conseq_Checks);
In_Assertion_Expr := In_Assertion_Expr - 1;
- Ghost_Mode := Save_Ghost_Mode;
end Expand_Pragma_Contract_Cases;
---------------------------------------
@@ -1279,7 +1265,7 @@ package body Exp_Prag is
if Relaxed_RM_Semantics
and then List_Length (Pragma_Argument_Associations (N)) = 2
- and then Chars (Pragma_Identifier (N)) = Name_Import
+ and then Pragma_Name (N) = Name_Import
and then Nkind (Arg2 (N)) = N_String_Literal
then
Def_Id := Entity (Arg1 (N));
@@ -1363,15 +1349,14 @@ package body Exp_Prag is
-------------------------------------
procedure Expand_Pragma_Initial_Condition (Spec_Or_Body : Node_Id) is
- Loc : constant Source_Ptr := Sloc (Spec_Or_Body);
+ Loc : constant Source_Ptr := Sloc (Spec_Or_Body);
+
Check : Node_Id;
Expr : Node_Id;
Init_Cond : Node_Id;
List : List_Id;
Pack_Id : Entity_Id;
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
-
begin
if Nkind (Spec_Or_Body) = N_Package_Body then
Pack_Id := Corresponding_Spec (Spec_Or_Body);
@@ -1410,12 +1395,6 @@ package body Exp_Prag is
Init_Cond := Get_Pragma (Pack_Id, Pragma_Initial_Condition);
- -- The initial condition is Ghost when it applies to a Ghost entity. Set
- -- the mode now to ensure that any nodes generated during expansion are
- -- properly flagged as Ghost.
-
- Set_Ghost_Mode (Init_Cond);
-
-- The caller should check whether the package is subject to pragma
-- Initial_Condition.
@@ -1428,7 +1407,6 @@ package body Exp_Prag is
-- runtime check as it will repeat the illegality.
if Error_Posted (Init_Cond) or else Error_Posted (Expr) then
- Ghost_Mode := Save_Ghost_Mode;
return;
end if;
@@ -1446,8 +1424,6 @@ package body Exp_Prag is
Append_To (List, Check);
Analyze (Check);
-
- Ghost_Mode := Save_Ghost_Mode;
end Expand_Pragma_Initial_Condition;
------------------------------------
@@ -1623,8 +1599,8 @@ package body Exp_Prag is
-- Local variables
- Expr : constant Node_Id := Expression (Variant);
- Expr_Typ : constant Entity_Id := Etype (Expr);
+ Expr : constant Node_Id := Expression (Variant);
+ Expr_Typ : constant Entity_Id := Etype (Expr);
Loc : constant Source_Ptr := Sloc (Expr);
Loop_Loc : constant Source_Ptr := Sloc (Loop_Stmt);
Curr_Id : Entity_Id;
@@ -1795,10 +1771,6 @@ package body Exp_Prag is
end if;
end Process_Variant;
- -- Local variables
-
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
-
-- Start of processing for Expand_Pragma_Loop_Variant
begin
@@ -1811,12 +1783,6 @@ package body Exp_Prag is
return;
end if;
- -- The loop variant is Ghost when it applies to a Ghost entity. Set
- -- the mode now to ensure that any nodes generated during expansion
- -- are properly flagged as Ghost.
-
- Set_Ghost_Mode (N);
-
-- The expansion of Loop_Variant is quite distributed as it produces
-- various statements to capture and compare the arguments. To preserve
-- the original context, set the Is_Assertion_Expr flag. This aids the
@@ -1887,7 +1853,6 @@ package body Exp_Prag is
-- for documentation purposes. It will be ignored by the backend.
In_Assertion_Expr := In_Assertion_Expr - 1;
- Ghost_Mode := Save_Ghost_Mode;
end Expand_Pragma_Loop_Variant;
--------------------------------
diff --git a/gcc/ada/exp_sel.ads b/gcc/ada/exp_sel.ads
index 440a0ea2c3..0ba7669888 100644
--- a/gcc/ada/exp_sel.ads
+++ b/gcc/ada/exp_sel.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -48,7 +48,7 @@ package Exp_Sel is
function Build_Abort_Block_Handler (Loc : Source_Ptr) return Node_Id;
-- Generate if front-end exception:
-- when others =>
- -- Abort_Under;
+ -- Abort_Undefer;
-- or if back-end exception:
-- when others =>
-- null;
diff --git a/gcc/ada/exp_spark.adb b/gcc/ada/exp_spark.adb
index 0fb50402bb..b80ef8294d 100644
--- a/gcc/ada/exp_spark.adb
+++ b/gcc/ada/exp_spark.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -24,13 +24,23 @@
------------------------------------------------------------------------------
with Atree; use Atree;
+with Checks; use Checks;
with Einfo; use Einfo;
with Exp_Ch5; use Exp_Ch5;
with Exp_Dbug; use Exp_Dbug;
with Exp_Util; use Exp_Util;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Rtsfind; use Rtsfind;
+with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
+with Snames; use Snames;
+with Stand; use Stand;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
package body Exp_SPARK is
@@ -38,13 +48,13 @@ package body Exp_SPARK is
-- Local Subprograms --
-----------------------
+ procedure Expand_SPARK_Attribute_Reference (N : Node_Id);
+ -- Replace occurrences of System'To_Address by calls to
+ -- System.Storage_Elements.To_Address
+
procedure Expand_SPARK_N_Object_Renaming_Declaration (N : Node_Id);
-- Perform name evaluation for a renamed object
- procedure Expand_Potential_Renaming (N : Node_Id);
- -- N denotes a N_Identifier or N_Expanded_Name. If N references a renaming,
- -- replace N with the renamed object.
-
------------------
-- Expand_SPARK --
------------------
@@ -61,19 +71,30 @@ package body Exp_SPARK is
-- user interaction. The verification back-end already takes care
-- of qualifying names when needed.
- when N_Block_Statement |
- N_Package_Body |
- N_Package_Declaration |
- N_Subprogram_Body =>
+ when N_Block_Statement
+ | N_Entry_Declaration
+ | N_Package_Body
+ | N_Package_Declaration
+ | N_Protected_Type_Declaration
+ | N_Subprogram_Body
+ | N_Task_Type_Declaration
+ =>
Qualify_Entity_Names (N);
- when N_Expanded_Name |
- N_Identifier =>
- Expand_Potential_Renaming (N);
+ when N_Expanded_Name
+ | N_Identifier
+ =>
+ Expand_SPARK_Potential_Renaming (N);
when N_Object_Renaming_Declaration =>
Expand_SPARK_N_Object_Renaming_Declaration (N);
+ -- Replace occurrences of System'To_Address by calls to
+ -- System.Storage_Elements.To_Address
+
+ when N_Attribute_Reference =>
+ Expand_SPARK_Attribute_Reference (N);
+
-- Loop iterations over arrays need to be expanded, to avoid getting
-- two names referring to the same object in memory (the array and
-- the iterator) in GNATprove, especially since both can be written
@@ -101,6 +122,110 @@ package body Exp_SPARK is
end case;
end Expand_SPARK;
+ --------------------------------------
+ -- Expand_SPARK_Attribute_Reference --
+ --------------------------------------
+
+ procedure Expand_SPARK_Attribute_Reference (N : Node_Id) is
+ Aname : constant Name_Id := Attribute_Name (N);
+ Attr_Id : constant Attribute_Id := Get_Attribute_Id (Aname);
+ Loc : constant Source_Ptr := Sloc (N);
+ Typ : constant Entity_Id := Etype (N);
+ Expr : Node_Id;
+
+ begin
+ if Attr_Id = Attribute_To_Address then
+
+ -- Extract and convert argument to expected type for call
+
+ Expr :=
+ Make_Type_Conversion (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (RTE (RE_Integer_Address), Loc),
+ Expression => Relocate_Node (First (Expressions (N))));
+
+ -- Replace attribute reference with call
+
+ Rewrite (N,
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_To_Address), Loc),
+ Parameter_Associations => New_List (Expr)));
+ Analyze_And_Resolve (N, Typ);
+
+ -- For attributes which return Universal_Integer, introduce a conversion
+ -- to the expected type with the appropriate check flags set.
+
+ elsif Attr_Id = Attribute_Alignment
+ or else Attr_Id = Attribute_Bit
+ or else Attr_Id = Attribute_Bit_Position
+ or else Attr_Id = Attribute_Descriptor_Size
+ or else Attr_Id = Attribute_First_Bit
+ or else Attr_Id = Attribute_Last_Bit
+ or else Attr_Id = Attribute_Length
+ or else Attr_Id = Attribute_Max_Size_In_Storage_Elements
+ or else Attr_Id = Attribute_Pos
+ or else Attr_Id = Attribute_Position
+ or else Attr_Id = Attribute_Range_Length
+ or else Attr_Id = Attribute_Object_Size
+ or else Attr_Id = Attribute_Size
+ or else Attr_Id = Attribute_Value_Size
+ or else Attr_Id = Attribute_VADS_Size
+ or else Attr_Id = Attribute_Aft
+ or else Attr_Id = Attribute_Max_Alignment_For_Allocation
+ then
+ -- If the expected type is Long_Long_Integer, there will be no check
+ -- flag as the compiler assumes attributes always fit in this type.
+ -- Since in SPARK_Mode we do not take Storage_Error into account, we
+ -- cannot make this assumption and need to produce a check.
+ -- ??? It should be enough to add this check for attributes 'Length
+ -- and 'Range_Length when the type is as big as Long_Long_Integer.
+
+ declare
+ Typ : Entity_Id := Empty;
+ begin
+ if Attr_Id = Attribute_Range_Length then
+ Typ := Etype (Prefix (N));
+
+ elsif Attr_Id = Attribute_Length then
+ Typ := Etype (Prefix (N));
+
+ declare
+ Indx : Node_Id;
+ J : Int;
+
+ begin
+ if Is_Access_Type (Typ) then
+ Typ := Designated_Type (Typ);
+ end if;
+
+ if No (Expressions (N)) then
+ J := 1;
+ else
+ J := UI_To_Int (Expr_Value (First (Expressions (N))));
+ end if;
+
+ Indx := First_Index (Typ);
+ while J > 1 loop
+ Next_Index (Indx);
+ J := J - 1;
+ end loop;
+
+ Typ := Etype (Indx);
+ end;
+ end if;
+
+ Apply_Universal_Integer_Attribute_Checks (N);
+
+ if Present (Typ)
+ and then RM_Size (Typ) = RM_Size (Standard_Long_Long_Integer)
+ then
+ Set_Do_Overflow_Check (N);
+ end if;
+ end;
+ end if;
+ end Expand_SPARK_Attribute_Reference;
+
------------------------------------------------
-- Expand_SPARK_N_Object_Renaming_Declaration --
------------------------------------------------
@@ -112,22 +237,41 @@ package body Exp_SPARK is
Evaluate_Name (Name (N));
end Expand_SPARK_N_Object_Renaming_Declaration;
- -------------------------------
- -- Expand_Potential_Renaming --
- -------------------------------
+ -------------------------------------
+ -- Expand_SPARK_Potential_Renaming --
+ -------------------------------------
- procedure Expand_Potential_Renaming (N : Node_Id) is
- E : constant Entity_Id := Entity (N);
- T : constant Entity_Id := Etype (N);
+ procedure Expand_SPARK_Potential_Renaming (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Ren_Id : constant Entity_Id := Entity (N);
+ Typ : constant Entity_Id := Etype (N);
+ Obj_Id : Node_Id;
begin
-- Replace a reference to a renaming with the actual renamed object
- if Ekind (E) in Object_Kind and then Present (Renamed_Object (E)) then
- Rewrite (N, New_Copy_Tree (Renamed_Object (E)));
- Reset_Analyzed_Flags (N);
- Analyze_And_Resolve (N, T);
+ if Ekind (Ren_Id) in Object_Kind then
+ Obj_Id := Renamed_Object (Ren_Id);
+
+ if Present (Obj_Id) then
+
+ -- The renamed object is an entity when instantiating generics
+ -- or inlining bodies. In this case the renaming is part of the
+ -- mapping "prologue" which links actuals to formals.
+
+ if Nkind (Obj_Id) in N_Entity then
+ Rewrite (N, New_Occurrence_Of (Obj_Id, Loc));
+
+ -- Otherwise the renamed object denotes a name
+
+ else
+ Rewrite (N, New_Copy_Tree (Obj_Id, New_Sloc => Loc));
+ Reset_Analyzed_Flags (N);
+ end if;
+
+ Analyze_And_Resolve (N, Typ);
+ end if;
end if;
- end Expand_Potential_Renaming;
+ end Expand_SPARK_Potential_Renaming;
end Exp_SPARK;
diff --git a/gcc/ada/exp_spark.ads b/gcc/ada/exp_spark.ads
index 750d66b872..9fc7f69035 100644
--- a/gcc/ada/exp_spark.ads
+++ b/gcc/ada/exp_spark.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -35,4 +35,8 @@ package Exp_SPARK is
procedure Expand_SPARK (N : Node_Id);
+ procedure Expand_SPARK_Potential_Renaming (N : Node_Id);
+ -- N must denote an N_Expanded_Name or N_Identifier. If N is a reference to
+ -- a renaming, replace N with the renamed object.
+
end Exp_SPARK;
diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb
index 88de827a90..20a7a7db5d 100644
--- a/gcc/ada/exp_strm.adb
+++ b/gcc/ada/exp_strm.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1116,23 +1116,28 @@ package body Exp_Strm is
-- an elementary type, then no Cn constants are defined.
procedure Build_Record_Or_Elementary_Input_Function
- (Loc : Source_Ptr;
- Typ : Entity_Id;
- Decl : out Node_Id;
- Fnam : out Entity_Id)
+ (Loc : Source_Ptr;
+ Typ : Entity_Id;
+ Decl : out Node_Id;
+ Fnam : out Entity_Id;
+ Use_Underlying : Boolean := True)
is
- B_Typ : constant Entity_Id := Underlying_Type (Base_Type (Typ));
+ B_Typ : Entity_Id := Base_Type (Typ);
Cn : Name_Id;
Constr : List_Id;
Decls : List_Id;
Discr : Entity_Id;
- Discr_Elmt : Elmt_Id := No_Elmt;
+ Discr_Elmt : Elmt_Id := No_Elmt;
J : Pos;
Obj_Decl : Node_Id;
Odef : Node_Id;
Stms : List_Id;
begin
+ if Use_Underlying then
+ B_Typ := Underlying_Type (B_Typ);
+ end if;
+
Decls := New_List;
Constr := New_List;
diff --git a/gcc/ada/exp_strm.ads b/gcc/ada/exp_strm.ads
index 97cb37bbd3..e3b859f156 100644
--- a/gcc/ada/exp_strm.ads
+++ b/gcc/ada/exp_strm.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -105,14 +105,17 @@ package Exp_Strm is
-- the same manner as is done for 'Output.
procedure Build_Record_Or_Elementary_Input_Function
- (Loc : Source_Ptr;
- Typ : Entity_Id;
- Decl : out Node_Id;
- Fnam : out Entity_Id);
- -- Build function for Input attribute for record type or for an
- -- elementary type (the latter is used only in the case where a
- -- user defined Read routine is defined, since in other cases,
- -- Input calls the appropriate runtime library routine directly.
+ (Loc : Source_Ptr;
+ Typ : Entity_Id;
+ Decl : out Node_Id;
+ Fnam : out Entity_Id;
+ Use_Underlying : Boolean := True);
+ -- Build function for Input attribute for record type or for an elementary
+ -- type (the latter is used only in the case where a user-defined Read
+ -- routine is defined, since, in other cases, Input calls the appropriate
+ -- runtime library routine directly). The flag Use_Underlying controls
+ -- whether the base type or the underlying type of the base type of Typ is
+ -- used during construction.
procedure Build_Record_Or_Elementary_Output_Procedure
(Loc : Source_Ptr;
diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb
index 93fbf6cf56..a3e433fedb 100644
--- a/gcc/ada/exp_unst.adb
+++ b/gcc/ada/exp_unst.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2014-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -47,6 +47,18 @@ with Uintp; use Uintp;
package body Exp_Unst is
+ -----------------------
+ -- Local Subprograms --
+ -----------------------
+
+ procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id);
+ -- Subp is a library-level subprogram which has nested subprograms, and
+ -- Subp_Body is the corresponding N_Subprogram_Body node. This procedure
+ -- declares the AREC types and objects, adds assignments to the AREC record
+ -- as required, defines the xxxPTR types for uplevel referenced objects,
+ -- adds the ARECP parameter to all nested subprograms which need it, and
+ -- modifies all uplevel references appropriately.
+
-----------
-- Calls --
-----------
@@ -80,6 +92,10 @@ package body Exp_Unst is
-- that are to other subprograms nested within the outer subprogram. These
-- are the calls that may need an additional parameter.
+ procedure Append_Unique_Call (Call : Call_Entry);
+ -- Append a call entry to the Calls table. A check is made to see if the
+ -- table already contains this entry and if so it has no effect.
+
-----------
-- Urefs --
-----------
@@ -119,6 +135,52 @@ package body Exp_Unst is
Table_Increment => 200,
Table_Name => "Unnest_Urefs");
+ ------------------------
+ -- Append_Unique_Call --
+ ------------------------
+
+ procedure Append_Unique_Call (Call : Call_Entry) is
+ begin
+ for J in Calls.First .. Calls.Last loop
+ if Calls.Table (J) = Call then
+ return;
+ end if;
+ end loop;
+
+ Calls.Append (Call);
+ end Append_Unique_Call;
+
+ ---------------
+ -- Get_Level --
+ ---------------
+
+ function Get_Level (Subp : Entity_Id; Sub : Entity_Id) return Nat is
+ Lev : Nat;
+ S : Entity_Id;
+
+ begin
+ Lev := 1;
+ S := Sub;
+ loop
+ if S = Subp then
+ return Lev;
+ else
+ Lev := Lev + 1;
+ S := Enclosing_Subprogram (S);
+ end if;
+ end loop;
+ end Get_Level;
+
+ ----------------
+ -- Subp_Index --
+ ----------------
+
+ function Subp_Index (Sub : Entity_Id) return SI_Type is
+ begin
+ pragma Assert (Is_Subprogram (Sub));
+ return SI_Type (UI_To_Int (Subps_Index (Sub)));
+ end Subp_Index;
+
-----------------------
-- Unnest_Subprogram --
-----------------------
@@ -132,17 +194,9 @@ package body Exp_Unst is
-- This function returns the index of the enclosing subprogram which
-- will have a Lev value one less than this.
- function Get_Level (Sub : Entity_Id) return Nat;
- -- Sub is either Subp itself, or a subprogram nested within Subp. This
- -- function returns the level of nesting (Subp = 1, subprograms that
- -- are immediately nested within Subp = 2, etc).
-
function Img_Pos (N : Pos) return String;
-- Return image of N without leading blank
- function Subp_Index (Sub : Entity_Id) return SI_Type;
- -- Given the entity for a subprogram, return corresponding Subps index
-
function Upref_Name
(Ent : Entity_Id;
Index : Pos;
@@ -161,7 +215,7 @@ package body Exp_Unst is
function AREC_Name (J : Pos; S : String) return Name_Id is
begin
- return Name_Find_Str ("AREC" & Img_Pos (J) & S);
+ return Name_Find ("AREC" & Img_Pos (J) & S);
end AREC_Name;
--------------------
@@ -177,26 +231,6 @@ package body Exp_Unst is
return Ret;
end Enclosing_Subp;
- ---------------
- -- Get_Level --
- ---------------
-
- function Get_Level (Sub : Entity_Id) return Nat is
- Lev : Nat;
- S : Entity_Id;
- begin
- Lev := 1;
- S := Sub;
- loop
- if S = Subp then
- return Lev;
- else
- S := Enclosing_Subprogram (S);
- Lev := Lev + 1;
- end if;
- end loop;
- end Get_Level;
-
-------------
-- Img_Pos --
-------------
@@ -219,16 +253,6 @@ package body Exp_Unst is
end Img_Pos;
----------------
- -- Subp_Index --
- ----------------
-
- function Subp_Index (Sub : Entity_Id) return SI_Type is
- begin
- pragma Assert (Is_Subprogram (Sub));
- return SI_Type (UI_To_Int (Subps_Index (Sub)));
- end Subp_Index;
-
- ----------------
-- Upref_Name --
----------------
@@ -243,9 +267,10 @@ package body Exp_Unst is
loop
if No (C) then
return Chars (Ent);
+
elsif Chars (Defining_Identifier (C)) = Chars (Ent) then
- return Name_Find_Str
- (Get_Name_String (Chars (Ent)) & Img_Pos (Index));
+ return
+ Name_Find (Get_Name_String (Chars (Ent)) & Img_Pos (Index));
else
Next (C);
end if;
@@ -435,6 +460,15 @@ package body Exp_Unst is
end loop;
end;
+ -- For private type, examine whether full view is static
+
+ elsif Is_Private_Type (T) and then Present (Full_View (T)) then
+ Check_Static_Type (Full_View (T), DT);
+
+ if Is_Static_Type (Full_View (T)) then
+ Set_Is_Static_Type (T);
+ end if;
+
-- For now, ignore other types
else
@@ -473,7 +507,7 @@ package body Exp_Unst is
elsif Ekind (Callee) = E_Function
and then Rewritten_For_C (Callee)
- and then Next_Entity (Callee) = Caller
+ and then Corresponding_Procedure (Callee) = Caller
then
return;
end if;
@@ -519,7 +553,7 @@ package body Exp_Unst is
-- Both caller and callee must be subprograms
if Is_Subprogram (Ent) then
- Calls.Append ((N, Current_Subprogram, Ent));
+ Append_Unique_Call ((N, Current_Subprogram, Ent));
end if;
end if;
end if;
@@ -541,7 +575,7 @@ package body Exp_Unst is
-- Make new entry in subprogram table if not already made
declare
- L : constant Nat := Get_Level (Ent);
+ L : constant Nat := Get_Level (Subp, Ent);
begin
Subps.Append
((Ent => Ent,
@@ -589,7 +623,7 @@ package body Exp_Unst is
end;
-- Now at this level, return skipping the subprogram body
- -- descendents, since we already took care of them!
+ -- descendants, since we already took care of them!
return Skip;
@@ -602,6 +636,10 @@ package body Exp_Unst is
if not Is_Library_Level_Entity (Ent)
and then Scope_Within_Or_Same (Scope (Ent), Subp)
+
+ -- Skip entities defined in inlined subprograms
+
+ and then Chars (Enclosing_Subprogram (Ent)) /= Name_uParent
and then
-- Constants and variables are interesting
@@ -1682,4 +1720,56 @@ package body Exp_Unst is
return;
end Unnest_Subprogram;
+ ------------------------
+ -- Unnest_Subprograms --
+ ------------------------
+
+ procedure Unnest_Subprograms (N : Node_Id) is
+ function Search_Subprograms (N : Node_Id) return Traverse_Result;
+ -- Tree visitor that search for outer level procedures with nested
+ -- subprograms and invokes Unnest_Subprogram()
+
+ ------------------------
+ -- Search_Subprograms --
+ ------------------------
+
+ function Search_Subprograms (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind_In (N, N_Subprogram_Body, N_Subprogram_Body_Stub) then
+ declare
+ Spec_Id : constant Entity_Id := Unique_Defining_Entity (N);
+
+ begin
+ -- We are only interested in subprograms (not generic
+ -- subprograms), that have nested subprograms.
+
+ if Is_Subprogram (Spec_Id)
+ and then Has_Nested_Subprogram (Spec_Id)
+ and then Is_Library_Level_Entity (Spec_Id)
+ then
+ Unnest_Subprogram (Spec_Id, N);
+ end if;
+ end;
+ end if;
+
+ return OK;
+ end Search_Subprograms;
+
+ ---------------
+ -- Do_Search --
+ ---------------
+
+ procedure Do_Search is new Traverse_Proc (Search_Subprograms);
+ -- Subtree visitor instantiation
+
+ -- Start of processing for Unnest_Subprograms
+
+ begin
+ if not Opt.Unnest_Subprogram_Mode then
+ return;
+ end if;
+
+ Do_Search (N);
+ end Unnest_Subprograms;
+
end Exp_Unst;
diff --git a/gcc/ada/exp_unst.ads b/gcc/ada/exp_unst.ads
index 084e904b67..c013e25da5 100644
--- a/gcc/ada/exp_unst.ads
+++ b/gcc/ada/exp_unst.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2014-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -678,12 +678,17 @@ package Exp_Unst is
-- Subprograms --
-----------------
- procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id);
- -- Subp is a library level subprogram which has nested subprograms, and
- -- Subp_Body is the corresponding N_Subprogram_Body node. This procedure
- -- declares the AREC types and objects, adds assignments to the AREC record
- -- as required, defines the xxxPTR types for uplevel referenced objects,
- -- adds the ARECP parameter to all nested subprograms which need it, and
- -- modifies all uplevel references appropriately.
+ function Get_Level (Subp : Entity_Id; Sub : Entity_Id) return Nat;
+ -- Sub is either Subp itself, or a subprogram nested within Subp. This
+ -- function returns the level of nesting (Subp = 1, subprograms that
+ -- are immediately nested within Subp = 2, etc.).
+
+ function Subp_Index (Sub : Entity_Id) return SI_Type;
+ -- Given the entity for a subprogram, return corresponding Subp's index
+
+ procedure Unnest_Subprograms (N : Node_Id);
+ -- Called to unnest subprograms. If we are in unnest subprogram mode, this
+ -- is the call that traverses the tree N and locates all the library level
+ -- subprograms with nested subprograms to process them.
end Exp_Unst;
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 55836e102e..67a6c64a1d 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -34,6 +34,7 @@ with Errout; use Errout;
with Exp_Aggr; use Exp_Aggr;
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch7; use Exp_Ch7;
+with Exp_Ch11; use Exp_Ch11;
with Ghost; use Ghost;
with Inline; use Inline;
with Itypes; use Itypes;
@@ -45,7 +46,12 @@ with Restrict; use Restrict;
with Rident; use Rident;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch12; use Sem_Ch12;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
@@ -59,8 +65,46 @@ with Ttypes; use Ttypes;
with Urealp; use Urealp;
with Validsw; use Validsw;
+with GNAT.HTable; use GNAT.HTable;
+
package body Exp_Util is
+ ---------------------------------------------------------
+ -- Handling of inherited class-wide pre/postconditions --
+ ---------------------------------------------------------
+
+ -- Following AI12-0113, the expression for a class-wide condition is
+ -- transformed for a subprogram that inherits it, by replacing calls
+ -- to primitive operations of the original controlling type into the
+ -- corresponding overriding operations of the derived type. The following
+ -- hash table manages this mapping, and is expanded on demand whenever
+ -- such inherited expression needs to be constructed.
+
+ -- The mapping is also used to check whether an inherited operation has
+ -- a condition that depends on overridden operations. For such an
+ -- operation we must create a wrapper that is then treated as a normal
+ -- overriding. In SPARK mode such operations are illegal.
+
+ -- For a given root type there may be several type extensions with their
+ -- own overriding operations, so at various times a given operation of
+ -- the root will be mapped into different overridings. The root type is
+ -- also mapped into the current type extension to indicate that its
+ -- operations are mapped into the overriding operations of that current
+ -- type extension.
+
+ Primitives_Mapping_Size : constant := 511;
+
+ subtype Num_Primitives is Integer range 0 .. Primitives_Mapping_Size - 1;
+ function Entity_Hash (E : Entity_Id) return Num_Primitives;
+
+ package Primitives_Mapping is new GNAT.HTable.Simple_HTable
+ (Header_Num => Num_Primitives,
+ Key => Entity_Id,
+ Element => Entity_Id,
+ No_element => Empty,
+ Hash => Entity_Hash,
+ Equal => "=");
+
-----------------------
-- Local Subprograms --
-----------------------
@@ -111,6 +155,11 @@ package body Exp_Util is
-- Force evaluation of bounds of a slice, which may be given by a range
-- or by a subtype indication with or without a constraint.
+ function Find_DIC_Type (Typ : Entity_Id) return Entity_Id;
+ -- Subsidiary to all Build_DIC_Procedure_xxx routines. Find the type which
+ -- defines the Default_Initial_Condition pragma of type Typ. This is either
+ -- Typ itself or a parent type when the pragma is inherited.
+
function Make_CW_Equivalent_Type
(T : Entity_Id;
E : Node_Id) return Entity_Id;
@@ -175,34 +224,35 @@ package body Exp_Util is
begin
case Nkind (Parent (N)) is
- -- Check for cases of appearing in the prefix of a construct where
- -- we don't need atomic synchronization for this kind of usage.
+ -- Check for cases of appearing in the prefix of a construct where we
+ -- don't need atomic synchronization for this kind of usage.
when
- -- Nothing to do if we are the prefix of an attribute, since we
- -- do not want an atomic sync operation for things like 'Size.
-
- N_Attribute_Reference |
+ -- Nothing to do if we are the prefix of an attribute, since we
+ -- do not want an atomic sync operation for things like 'Size.
- -- The N_Reference node is like an attribute
+ N_Attribute_Reference
- N_Reference |
+ -- The N_Reference node is like an attribute
- -- Nothing to do for a reference to a component (or components)
- -- of a composite object. Only reads and updates of the object
- -- as a whole require atomic synchronization (RM C.6 (15)).
+ | N_Reference
- N_Indexed_Component |
- N_Selected_Component |
- N_Slice =>
+ -- Nothing to do for a reference to a component (or components)
+ -- of a composite object. Only reads and updates of the object
+ -- as a whole require atomic synchronization (RM C.6 (15)).
+ | N_Indexed_Component
+ | N_Selected_Component
+ | N_Slice
+ =>
-- For all the above cases, nothing to do if we are the prefix
if Prefix (Parent (N)) = N then
return;
end if;
- when others => null;
+ when others =>
+ null;
end case;
-- Nothing to do for the identifier in an object renaming declaration,
@@ -223,10 +273,14 @@ package body Exp_Util is
when N_Identifier =>
Msg_Node := N;
- when N_Selected_Component | N_Expanded_Name =>
+ when N_Expanded_Name
+ | N_Selected_Component
+ =>
Msg_Node := Selector_Name (N);
- when N_Explicit_Dereference | N_Indexed_Component =>
+ when N_Explicit_Dereference
+ | N_Indexed_Component
+ =>
Msg_Node := Empty;
when others =>
@@ -354,12 +408,15 @@ package body Exp_Util is
return;
-- Otherwise we perform a conversion from the current type, which
- -- must be Standard.Boolean, to the desired type.
+ -- must be Standard.Boolean, to the desired type. Use the base
+ -- type to prevent spurious constraint checks that are extraneous
+ -- to the transformation. The type and its base have the same
+ -- representation, standard or otherwise.
else
Set_Analyzed (N);
- Rewrite (N, Convert_To (T, N));
- Analyze_And_Resolve (N, T);
+ Rewrite (N, Convert_To (Base_Type (T), N));
+ Analyze_And_Resolve (N, Base_Type (T));
end if;
end;
end if;
@@ -583,6 +640,14 @@ package body Exp_Util is
elsif Is_RTE (Pool_Id, RE_SS_Pool) then
return;
+ -- Optimize the case where we are using the default Global_Pool_Object,
+ -- and we don't need the heavy finalization machinery.
+
+ elsif Pool_Id = RTE (RE_Global_Pool_Object)
+ and then not Needs_Finalization (Desig_Typ)
+ then
+ return;
+
-- Do not replicate the machinery if the allocator / free has already
-- been expanded and has a custom Allocate / Deallocate.
@@ -712,7 +777,7 @@ package body Exp_Util is
-- For deallocation of class-wide types we obtain the value of
-- alignment from the Type Specific Record of the deallocated object.
-- This is needed because the frontend expansion of class-wide types
- -- into equivalent types confuses the backend.
+ -- into equivalent types confuses the back end.
else
-- Generate:
@@ -918,6 +983,1243 @@ package body Exp_Util is
end;
end Build_Allocate_Deallocate_Proc;
+ -------------------------------
+ -- Build_Abort_Undefer_Block --
+ -------------------------------
+
+ function Build_Abort_Undefer_Block
+ (Loc : Source_Ptr;
+ Stmts : List_Id;
+ Context : Node_Id) return Node_Id
+ is
+ Exceptions_OK : constant Boolean :=
+ not Restriction_Active (No_Exception_Propagation);
+
+ AUD : Entity_Id;
+ Blk : Node_Id;
+ Blk_Id : Entity_Id;
+ HSS : Node_Id;
+
+ begin
+ -- The block should be generated only when undeferring abort in the
+ -- context of a potential exception.
+
+ pragma Assert (Abort_Allowed and Exceptions_OK);
+
+ -- Generate:
+ -- begin
+ -- <Stmts>
+ -- at end
+ -- Abort_Undefer_Direct;
+ -- end;
+
+ AUD := RTE (RE_Abort_Undefer_Direct);
+
+ HSS :=
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stmts,
+ At_End_Proc => New_Occurrence_Of (AUD, Loc));
+
+ Blk :=
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence => HSS);
+ Set_Is_Abort_Block (Blk);
+
+ Add_Block_Identifier (Blk, Blk_Id);
+ Expand_At_End_Handler (HSS, Blk_Id);
+
+ -- Present the Abort_Undefer_Direct function to the back end to inline
+ -- the call to the routine.
+
+ Add_Inlined_Body (AUD, Context);
+
+ return Blk;
+ end Build_Abort_Undefer_Block;
+
+ ---------------------------------
+ -- Build_Class_Wide_Expression --
+ ---------------------------------
+
+ procedure Build_Class_Wide_Expression
+ (Prag : 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
+ -- operation of root type, with corresponding entity for derived type,
+ -- when constructing the class-wide condition of an overriding
+ -- subprogram.
+
+ --------------------
+ -- Replace_Entity --
+ --------------------
+
+ function Replace_Entity (N : Node_Id) return Traverse_Result is
+ New_E : Entity_Id;
+
+ begin
+ if Adjust_Sloc then
+ Adjust_Inherited_Pragma_Sloc (N);
+ end if;
+
+ 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 replacement 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 := Primitives_Mapping.Get (Entity (N));
+
+ if Present (New_E) then
+ Rewrite (N, New_Occurrence_Of (New_E, Sloc (N)));
+ end if;
+
+ -- Check that there are no calls left to abstract operations if
+ -- the current subprogram is not abstract.
+
+ 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_NE
+ ("cannot call abstract subprogram in inherited condition "
+ & "for&#", N, Current_Scope);
+
+ -- 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
+ -- the function's return type.
+
+ if Is_Subprogram (Entity (N))
+ and then Nkind (Parent (N)) = N_Function_Call
+ then
+ Set_Etype (Parent (N), Etype (Entity (N)));
+ end if;
+
+ -- The whole expression will be reanalyzed
+
+ elsif Nkind (N) in N_Has_Etype then
+ Set_Analyzed (N, False);
+ end if;
+
+ return OK;
+ end Replace_Entity;
+
+ procedure Replace_Condition_Entities is
+ new Traverse_Proc (Replace_Entity);
+
+ -- Local variables
+
+ Par_Formal : Entity_Id;
+ Subp_Formal : Entity_Id;
+
+ -- Start of processing for Build_Class_Wide_Expression
+
+ begin
+ -- 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
+ Primitives_Mapping.Set (Par_Formal, Subp_Formal);
+ Next_Formal (Par_Formal);
+ Next_Formal (Subp_Formal);
+ end loop;
+
+ Replace_Condition_Entities (Prag);
+ end Build_Class_Wide_Expression;
+
+ --------------------
+ -- Build_DIC_Call --
+ --------------------
+
+ function Build_DIC_Call
+ (Loc : Source_Ptr;
+ Obj_Id : Entity_Id;
+ Typ : Entity_Id) return Node_Id
+ is
+ Proc_Id : constant Entity_Id := DIC_Procedure (Typ);
+ Formal_Typ : constant Entity_Id := Etype (First_Formal (Proc_Id));
+
+ begin
+ return
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Proc_Id, Loc),
+ Parameter_Associations => New_List (
+ Make_Unchecked_Type_Conversion (Loc,
+ Subtype_Mark => New_Occurrence_Of (Formal_Typ, Loc),
+ Expression => New_Occurrence_Of (Obj_Id, Loc))));
+ end Build_DIC_Call;
+
+ ------------------------------
+ -- Build_DIC_Procedure_Body --
+ ------------------------------
+
+ -- WARNING: This routine manages Ghost regions. Return statements must be
+ -- replaced by gotos which jump to the end of the routine and restore the
+ -- Ghost mode.
+
+ procedure Build_DIC_Procedure_Body (Typ : Entity_Id) is
+ procedure Add_DIC_Check
+ (DIC_Prag : Node_Id;
+ DIC_Expr : Node_Id;
+ Stmts : in out List_Id);
+ -- Subsidiary to all Add_xxx_DIC routines. Add a runtime check to verify
+ -- assertion expression DIC_Expr of pragma DIC_Prag. All generated code
+ -- is added to list Stmts.
+
+ procedure Add_Inherited_DIC
+ (DIC_Prag : Node_Id;
+ Par_Typ : Entity_Id;
+ Deriv_Typ : Entity_Id;
+ Stmts : in out List_Id);
+ -- Add a runtime check to verify the assertion expression of inherited
+ -- pragma DIC_Prag. Par_Typ is parent type, which is also the owner of
+ -- the DIC pragma. Deriv_Typ is the derived type inheriting the DIC
+ -- pragma. All generated code is added to list Stmts.
+
+ procedure Add_Inherited_Tagged_DIC
+ (DIC_Prag : Node_Id;
+ Par_Typ : Entity_Id;
+ Deriv_Typ : Entity_Id;
+ Stmts : in out List_Id);
+ -- Add a runtime check to verify assertion expression DIC_Expr of
+ -- inherited pragma DIC_Prag. This routine applies class-wide pre- and
+ -- postcondition-like runtime semantics to the check. Par_Typ is the
+ -- parent type whose DIC pragma is being inherited. Deriv_Typ is the
+ -- derived type inheriting the DIC pragma. All generated code is added
+ -- to list Stmts.
+
+ procedure Add_Own_DIC
+ (DIC_Prag : Node_Id;
+ DIC_Typ : Entity_Id;
+ Stmts : in out List_Id);
+ -- Add a runtime check to verify the assertion expression of pragma
+ -- DIC_Prag. DIC_Typ is the owner of the DIC pragma. All generated code
+ -- is added to list Stmts.
+
+ procedure Replace_Object_And_Primitive_References
+ (Expr : Node_Id;
+ Par_Typ : Entity_Id;
+ Deriv_Typ : Entity_Id;
+ Par_Obj : Entity_Id := Empty;
+ Deriv_Obj : Entity_Id := Empty);
+ -- Expr denotes an arbitrary expression. Par_Typ is a parent type in a
+ -- type hierarchy. Deriv_Typ is a type derived from Par_Typ. Par_Obj is
+ -- the formal parameter which emulates the current instance of Par_Typ.
+ -- Deriv_Obj is the formal parameter which emulates the current instance
+ -- of Deriv_Typ. Perform the following substitutions:
+ --
+ -- * Replace a reference to Par_Obj with a reference to Deriv_Obj if
+ -- applicable.
+ --
+ -- * Replace a call to an overridden parent primitive with a call to
+ -- the overriding derived type primitive.
+ --
+ -- * Replace a call to an inherited parent primitive with a call to
+ -- the internally-generated inherited derived type primitive.
+
+ procedure Replace_Type_References
+ (Expr : Node_Id;
+ Typ : Entity_Id;
+ Obj_Id : Entity_Id);
+ -- Substitute all references of the current instance of type Typ with
+ -- references to formal parameter Obj_Id within expression Expr.
+
+ -------------------
+ -- Add_DIC_Check --
+ -------------------
+
+ procedure Add_DIC_Check
+ (DIC_Prag : Node_Id;
+ DIC_Expr : Node_Id;
+ Stmts : in out List_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (DIC_Prag);
+ Nam : constant Name_Id := Original_Aspect_Pragma_Name (DIC_Prag);
+
+ begin
+ -- The DIC pragma is ignored, nothing left to do
+
+ if Is_Ignored (DIC_Prag) then
+ null;
+
+ -- Otherwise the DIC expression must be checked at runtime. Generate:
+
+ -- pragma Check (<Nam>, <DIC_Expr>);
+
+ else
+ Append_New_To (Stmts,
+ Make_Pragma (Loc,
+ Pragma_Identifier =>
+ Make_Identifier (Loc, Name_Check),
+
+ Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Loc,
+ Expression => Make_Identifier (Loc, Nam)),
+
+ Make_Pragma_Argument_Association (Loc,
+ Expression => DIC_Expr))));
+ end if;
+ end Add_DIC_Check;
+
+ -----------------------
+ -- Add_Inherited_DIC --
+ -----------------------
+
+ procedure Add_Inherited_DIC
+ (DIC_Prag : Node_Id;
+ Par_Typ : Entity_Id;
+ Deriv_Typ : Entity_Id;
+ Stmts : in out List_Id)
+ is
+ Deriv_Proc : constant Entity_Id := DIC_Procedure (Deriv_Typ);
+ Deriv_Obj : constant Entity_Id := First_Entity (Deriv_Proc);
+ Par_Proc : constant Entity_Id := DIC_Procedure (Par_Typ);
+ Par_Obj : constant Entity_Id := First_Entity (Par_Proc);
+ Loc : constant Source_Ptr := Sloc (DIC_Prag);
+
+ begin
+ pragma Assert (Present (Deriv_Proc) and then Present (Par_Proc));
+
+ -- Verify the inherited DIC assertion expression by calling the DIC
+ -- procedure of the parent type.
+
+ -- Generate:
+ -- <Par_Typ>DIC (Par_Typ (_object));
+
+ Append_New_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Par_Proc, Loc),
+ Parameter_Associations => New_List (
+ Convert_To
+ (Typ => Etype (Par_Obj),
+ Expr => New_Occurrence_Of (Deriv_Obj, Loc)))));
+ end Add_Inherited_DIC;
+
+ ------------------------------
+ -- Add_Inherited_Tagged_DIC --
+ ------------------------------
+
+ procedure Add_Inherited_Tagged_DIC
+ (DIC_Prag : Node_Id;
+ Par_Typ : Entity_Id;
+ Deriv_Typ : Entity_Id;
+ Stmts : in out List_Id)
+ is
+ Deriv_Decl : constant Node_Id := Declaration_Node (Deriv_Typ);
+ Deriv_Proc : constant Entity_Id := DIC_Procedure (Deriv_Typ);
+ DIC_Args : constant List_Id :=
+ Pragma_Argument_Associations (DIC_Prag);
+ DIC_Arg : constant Node_Id := First (DIC_Args);
+ DIC_Expr : constant Node_Id := Expression_Copy (DIC_Arg);
+ Par_Proc : constant Entity_Id := DIC_Procedure (Par_Typ);
+
+ Expr : Node_Id;
+
+ begin
+ -- The processing of an inherited DIC assertion expression starts off
+ -- with a copy of the original parent expression where all references
+ -- to the parent type have already been replaced with references to
+ -- the _object formal parameter of the parent type's DIC procedure.
+
+ pragma Assert (Present (DIC_Expr));
+ Expr := New_Copy_Tree (DIC_Expr);
+
+ -- Perform the following substitutions:
+
+ -- * Replace a reference to the _object parameter of the parent
+ -- type's DIC procedure with a reference to the _object parameter
+ -- of the derived types' DIC procedure.
+
+ -- * Replace a call to an overridden parent primitive with a call
+ -- to the overriding derived type primitive.
+
+ -- * Replace a call to an inherited parent primitive with a call to
+ -- the internally-generated inherited derived type primitive.
+
+ -- Note that primitives defined in the private part are automatically
+ -- handled by the overriding/inheritance mechanism and do not require
+ -- an extra replacement pass.
+
+ pragma Assert (Present (Deriv_Proc) and then Present (Par_Proc));
+
+ Replace_Object_And_Primitive_References
+ (Expr => Expr,
+ Par_Typ => Par_Typ,
+ Deriv_Typ => Deriv_Typ,
+ Par_Obj => First_Formal (Par_Proc),
+ Deriv_Obj => First_Formal (Deriv_Proc));
+
+ -- Preanalyze the DIC expression to detect errors and at the same
+ -- time capture the visibility of the proper package part.
+
+ Set_Parent (Expr, Deriv_Decl);
+ Preanalyze_Assert_Expression (Expr, Any_Boolean);
+
+ -- Once the DIC assertion expression is fully processed, add a check
+ -- to the statements of the DIC procedure.
+
+ Add_DIC_Check
+ (DIC_Prag => DIC_Prag,
+ DIC_Expr => Expr,
+ Stmts => Stmts);
+ end Add_Inherited_Tagged_DIC;
+
+ -----------------
+ -- Add_Own_DIC --
+ -----------------
+
+ procedure Add_Own_DIC
+ (DIC_Prag : Node_Id;
+ DIC_Typ : Entity_Id;
+ Stmts : in out List_Id)
+ is
+ DIC_Args : constant List_Id :=
+ Pragma_Argument_Associations (DIC_Prag);
+ DIC_Arg : constant Node_Id := First (DIC_Args);
+ DIC_Asp : constant Node_Id := Corresponding_Aspect (DIC_Prag);
+ DIC_Expr : constant Node_Id := Get_Pragma_Arg (DIC_Arg);
+ DIC_Proc : constant Entity_Id := DIC_Procedure (DIC_Typ);
+ Obj_Id : constant Entity_Id := First_Formal (DIC_Proc);
+
+ procedure Preanalyze_Own_DIC_For_ASIS;
+ -- Preanalyze the original DIC expression of an aspect or a source
+ -- pragma for ASIS.
+
+ ---------------------------------
+ -- Preanalyze_Own_DIC_For_ASIS --
+ ---------------------------------
+
+ procedure Preanalyze_Own_DIC_For_ASIS is
+ Expr : Node_Id := Empty;
+
+ begin
+ -- The DIC pragma is a source construct, preanalyze the original
+ -- expression of the pragma.
+
+ if Comes_From_Source (DIC_Prag) then
+ Expr := DIC_Expr;
+
+ -- Otherwise preanalyze the expression of the corresponding aspect
+
+ elsif Present (DIC_Asp) then
+ Expr := Expression (DIC_Asp);
+ end if;
+
+ -- The expression must be subjected to the same substitutions as
+ -- the copy used in the generation of the runtime check.
+
+ if Present (Expr) then
+ Replace_Type_References
+ (Expr => Expr,
+ Typ => DIC_Typ,
+ Obj_Id => Obj_Id);
+
+ Preanalyze_Assert_Expression (Expr, Any_Boolean);
+ end if;
+ end Preanalyze_Own_DIC_For_ASIS;
+
+ -- Local variables
+
+ Typ_Decl : constant Node_Id := Declaration_Node (DIC_Typ);
+
+ Expr : Node_Id;
+
+ -- Start of processing for Add_Own_DIC
+
+ begin
+ Expr := New_Copy_Tree (DIC_Expr);
+
+ -- Perform the following substitution:
+
+ -- * Replace the current instance of DIC_Typ with a reference to
+ -- the _object formal parameter of the DIC procedure.
+
+ Replace_Type_References
+ (Expr => Expr,
+ Typ => DIC_Typ,
+ Obj_Id => Obj_Id);
+
+ -- Preanalyze the DIC expression to detect errors and at the same
+ -- time capture the visibility of the proper package part.
+
+ Set_Parent (Expr, Typ_Decl);
+ Preanalyze_Assert_Expression (Expr, Any_Boolean);
+
+ -- Save a copy of the expression with all replacements and analysis
+ -- already taken place in case a derived type inherits the pragma.
+ -- The copy will be used as the foundation of the derived type's own
+ -- version of the DIC assertion expression.
+
+ if Is_Tagged_Type (DIC_Typ) then
+ Set_Expression_Copy (DIC_Arg, New_Copy_Tree (Expr));
+ end if;
+
+ -- If the pragma comes from an aspect specification, replace the
+ -- saved expression because all type references must be substituted
+ -- for the call to Preanalyze_Spec_Expression in Check_Aspect_At_xxx
+ -- routines.
+
+ if Present (DIC_Asp) then
+ Set_Entity (Identifier (DIC_Asp), New_Copy_Tree (Expr));
+ end if;
+
+ -- Preanalyze the original DIC expression for ASIS
+
+ if ASIS_Mode then
+ Preanalyze_Own_DIC_For_ASIS;
+ end if;
+
+ -- Once the DIC assertion expression is fully processed, add a check
+ -- to the statements of the DIC procedure.
+
+ Add_DIC_Check
+ (DIC_Prag => DIC_Prag,
+ DIC_Expr => Expr,
+ Stmts => Stmts);
+ end Add_Own_DIC;
+
+ ---------------------------------------------
+ -- Replace_Object_And_Primitive_References --
+ ---------------------------------------------
+
+ procedure Replace_Object_And_Primitive_References
+ (Expr : Node_Id;
+ Par_Typ : Entity_Id;
+ Deriv_Typ : Entity_Id;
+ Par_Obj : Entity_Id := Empty;
+ Deriv_Obj : Entity_Id := Empty)
+ is
+ function Replace_Ref (Ref : Node_Id) return Traverse_Result;
+ -- Substitute a reference to an entity with a reference to the
+ -- corresponding entity stored in in table Primitives_Mapping.
+
+ -----------------
+ -- Replace_Ref --
+ -----------------
+
+ function Replace_Ref (Ref : Node_Id) return Traverse_Result is
+ Context : constant Node_Id := Parent (Ref);
+ Loc : constant Source_Ptr := Sloc (Ref);
+ New_Id : Entity_Id;
+ New_Ref : Node_Id;
+ Ref_Id : Entity_Id;
+ Result : Traverse_Result;
+
+ begin
+ Result := OK;
+
+ -- The current node denotes a reference
+
+ if Nkind (Ref) in N_Has_Entity and then Present (Entity (Ref)) then
+ Ref_Id := Entity (Ref);
+ New_Id := Primitives_Mapping.Get (Ref_Id);
+
+ -- The reference mentions a parent type primitive which has a
+ -- corresponding derived type primitive.
+
+ if Present (New_Id) then
+ New_Ref := New_Occurrence_Of (New_Id, Loc);
+
+ -- The reference mentions the _object parameter of the parent
+ -- type's DIC procedure.
+
+ elsif Present (Par_Obj)
+ and then Present (Deriv_Obj)
+ and then Ref_Id = Par_Obj
+ then
+ New_Ref := New_Occurrence_Of (Deriv_Obj, Loc);
+
+ -- The reference to _object acts as an actual parameter in a
+ -- subprogram call which may be invoking a primitive of the
+ -- parent type:
+
+ -- Primitive (... _object ...);
+
+ -- The parent type primitive may not be overridden nor
+ -- inherited when it is declared after the derived type
+ -- definition:
+
+ -- type Parent is tagged private;
+ -- type Child is new Parent with private;
+ -- procedure Primitive (Obj : Parent);
+
+ -- In this scenario the _object parameter is converted to
+ -- the parent type.
+
+ if Nkind_In (Context, N_Function_Call,
+ N_Procedure_Call_Statement)
+ and then
+ No (Primitives_Mapping.Get (Entity (Name (Context))))
+ then
+ New_Ref := Convert_To (Par_Typ, New_Ref);
+
+ -- Do not process the generated type conversion because
+ -- both the parent type and the derived type are in the
+ -- Primitives_Mapping table. This will clobber the type
+ -- conversion by resetting its subtype mark.
+
+ Result := Skip;
+ end if;
+
+ -- Otherwise there is nothing to replace
+
+ else
+ New_Ref := Empty;
+ end if;
+
+ if Present (New_Ref) then
+ Rewrite (Ref, New_Ref);
+
+ -- Update the return type when the context of the reference
+ -- acts as the name of a function call. Note that the update
+ -- should not be performed when the reference appears as an
+ -- actual in the call.
+
+ if Nkind (Context) = N_Function_Call
+ and then Name (Context) = Ref
+ then
+ Set_Etype (Context, Etype (New_Id));
+ end if;
+ end if;
+ end if;
+
+ -- Reanalyze the reference due to potential replacements
+
+ if Nkind (Ref) in N_Has_Etype then
+ Set_Analyzed (Ref, False);
+ end if;
+
+ return Result;
+ end Replace_Ref;
+
+ procedure Replace_Refs is new Traverse_Proc (Replace_Ref);
+
+ -- Start of processing for Replace_Object_And_Primitive_References
+
+ begin
+ -- Map each primitive operation of the parent type to the proper
+ -- primitive of the derived type.
+
+ Update_Primitives_Mapping_Of_Types
+ (Par_Typ => Par_Typ,
+ Deriv_Typ => Deriv_Typ);
+
+ -- Inspect the input expression and perform substitutions where
+ -- necessary.
+
+ Replace_Refs (Expr);
+ end Replace_Object_And_Primitive_References;
+
+ -----------------------------
+ -- Replace_Type_References --
+ -----------------------------
+
+ procedure Replace_Type_References
+ (Expr : Node_Id;
+ Typ : Entity_Id;
+ Obj_Id : Entity_Id)
+ is
+ procedure Replace_Type_Ref (N : Node_Id);
+ -- Substitute a single reference of the current instance of type Typ
+ -- with a reference to Obj_Id.
+
+ ----------------------
+ -- Replace_Type_Ref --
+ ----------------------
+
+ procedure Replace_Type_Ref (N : Node_Id) is
+ Ref : Node_Id;
+
+ begin
+ -- Decorate the reference to Typ even though it may be rewritten
+ -- further down. This is done for two reasons:
+
+ -- 1) ASIS has all necessary semantic information in the
+ -- original tree.
+
+ -- 2) Routines which examine properties of the Original_Node
+ -- have some semantic information.
+
+ if Nkind (N) = N_Identifier then
+ Set_Entity (N, Typ);
+ Set_Etype (N, Typ);
+
+ elsif Nkind (N) = N_Selected_Component then
+ Analyze (Prefix (N));
+ Set_Entity (Selector_Name (N), Typ);
+ Set_Etype (Selector_Name (N), Typ);
+ end if;
+
+ -- Perform the following substitution:
+
+ -- Typ --> _object
+
+ Ref := Make_Identifier (Sloc (N), Chars (Obj_Id));
+ Set_Entity (Ref, Obj_Id);
+ Set_Etype (Ref, Typ);
+
+ Rewrite (N, Ref);
+
+ Set_Comes_From_Source (N, True);
+ end Replace_Type_Ref;
+
+ procedure Replace_Type_Refs is
+ new Replace_Type_References_Generic (Replace_Type_Ref);
+
+ -- Start of processing for Replace_Type_References
+
+ begin
+ Replace_Type_Refs (Expr, Typ);
+ end Replace_Type_References;
+
+ -- Local variables
+
+ Loc : constant Source_Ptr := Sloc (Typ);
+
+ DIC_Prag : Node_Id;
+ DIC_Typ : Entity_Id;
+ Dummy_1 : Entity_Id;
+ Dummy_2 : Entity_Id;
+ Mode : Ghost_Mode_Type;
+ Proc_Body : Node_Id;
+ Proc_Body_Id : Entity_Id;
+ Proc_Decl : Node_Id;
+ Proc_Id : Entity_Id;
+ Stmts : List_Id := No_List;
+
+ Work_Typ : Entity_Id;
+ -- The working type
+
+ -- Start of processing for Build_DIC_Procedure_Body
+
+ begin
+ Work_Typ := Base_Type (Typ);
+
+ -- Do not process class-wide types as these are Itypes, but lack a first
+ -- subtype (see below).
+
+ if Is_Class_Wide_Type (Work_Typ) then
+ return;
+
+ -- Do not process the underlying full view of a private type. There is
+ -- no way to get back to the partial view, plus the body will be built
+ -- by the full view or the base type.
+
+ elsif Is_Underlying_Full_View (Work_Typ) then
+ return;
+
+ -- Use the first subtype when dealing with various base types
+
+ elsif Is_Itype (Work_Typ) then
+ Work_Typ := First_Subtype (Work_Typ);
+
+ -- The input denotes the corresponding record type of a protected or a
+ -- task type. Work with the concurrent type because the corresponding
+ -- record type may not be visible to clients of the type.
+
+ elsif Ekind (Work_Typ) = E_Record_Type
+ and then Is_Concurrent_Record_Type (Work_Typ)
+ then
+ Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
+ end if;
+
+ -- The working type may be subject to pragma Ghost. Set the mode now to
+ -- ensure that the DIC procedure is properly marked as Ghost.
+
+ Set_Ghost_Mode (Work_Typ, Mode);
+
+ -- The working type must be either define a DIC pragma of its own or
+ -- inherit one from a parent type.
+
+ pragma Assert (Has_DIC (Work_Typ));
+
+ -- Recover the type which defines the DIC pragma. This is either the
+ -- working type itself or a parent type when the pragma is inherited.
+
+ DIC_Typ := Find_DIC_Type (Work_Typ);
+ pragma Assert (Present (DIC_Typ));
+
+ DIC_Prag := Get_Pragma (DIC_Typ, Pragma_Default_Initial_Condition);
+ pragma Assert (Present (DIC_Prag));
+
+ -- Nothing to do if pragma DIC appears without an argument or its sole
+ -- argument is "null".
+
+ if not Is_Verifiable_DIC_Pragma (DIC_Prag) then
+ goto Leave;
+ end if;
+
+ -- The working type may lack a DIC procedure declaration. This may be
+ -- due to several reasons:
+
+ -- * The working type's own DIC pragma does not contain a verifiable
+ -- assertion expression. In this case there is no need to build a
+ -- DIC procedure because there is nothing to check.
+
+ -- * The working type derives from a parent type. In this case a DIC
+ -- procedure should be built only when the inherited DIC pragma has
+ -- a verifiable assertion expression.
+
+ Proc_Id := DIC_Procedure (Work_Typ);
+
+ -- Build a DIC procedure declaration when the working type derives from
+ -- a parent type.
+
+ if No (Proc_Id) then
+ Build_DIC_Procedure_Declaration (Work_Typ);
+ Proc_Id := DIC_Procedure (Work_Typ);
+ end if;
+
+ -- At this point there should be a DIC procedure declaration
+
+ pragma Assert (Present (Proc_Id));
+ Proc_Decl := Unit_Declaration_Node (Proc_Id);
+
+ -- Nothing to do if the DIC procedure already has a body
+
+ if Present (Corresponding_Body (Proc_Decl)) then
+ goto Leave;
+ end if;
+
+ -- Emulate the environment of the DIC procedure by installing its scope
+ -- and formal parameters.
+
+ Push_Scope (Proc_Id);
+ Install_Formals (Proc_Id);
+
+ -- The working type defines its own DIC pragma. Replace the current
+ -- instance of the working type with the formal of the DIC procedure.
+ -- Note that there is no need to consider inherited DIC pragmas from
+ -- parent types because the working type's DIC pragma "hides" all
+ -- inherited DIC pragmas.
+
+ if Has_Own_DIC (Work_Typ) then
+ pragma Assert (DIC_Typ = Work_Typ);
+
+ Add_Own_DIC
+ (DIC_Prag => DIC_Prag,
+ DIC_Typ => DIC_Typ,
+ Stmts => Stmts);
+
+ -- Otherwise the working type inherits a DIC pragma from a parent type
+
+ else
+ pragma Assert (Has_Inherited_DIC (Work_Typ));
+ pragma Assert (DIC_Typ /= Work_Typ);
+
+ -- The working type is tagged. The verification of the assertion
+ -- expression is subject to the same semantics as class-wide pre-
+ -- and postconditions.
+
+ if Is_Tagged_Type (Work_Typ) then
+ Add_Inherited_Tagged_DIC
+ (DIC_Prag => DIC_Prag,
+ Par_Typ => DIC_Typ,
+ Deriv_Typ => Work_Typ,
+ Stmts => Stmts);
+
+ -- Otherwise the working type is not tagged. Verify the assertion
+ -- expression of the inherited DIC pragma by directly calling the
+ -- DIC procedure of the parent type.
+
+ else
+ Add_Inherited_DIC
+ (DIC_Prag => DIC_Prag,
+ Par_Typ => DIC_Typ,
+ Deriv_Typ => Work_Typ,
+ Stmts => Stmts);
+ end if;
+ end if;
+
+ End_Scope;
+
+ -- Produce an empty completing body in the following cases:
+ -- * Assertions are disabled
+ -- * The DIC Assertion_Policy is Ignore
+ -- * Pragma DIC appears without an argument
+ -- * Pragma DIC appears with argument "null"
+
+ if No (Stmts) then
+ Stmts := New_List (Make_Null_Statement (Loc));
+ end if;
+
+ -- Generate:
+ -- procedure <Work_Typ>DIC (_object : <Work_Typ>) is
+ -- begin
+ -- <Stmts>
+ -- end <Work_Typ>DIC;
+
+ Proc_Body :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Copy_Subprogram_Spec (Parent (Proc_Id)),
+ Declarations => Empty_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stmts));
+ Proc_Body_Id := Defining_Entity (Proc_Body);
+
+ -- Perform minor decoration in case the body is not analyzed
+
+ Set_Ekind (Proc_Body_Id, E_Subprogram_Body);
+ Set_Etype (Proc_Body_Id, Standard_Void_Type);
+ Set_Scope (Proc_Body_Id, Current_Scope);
+
+ -- Link both spec and body to avoid generating duplicates
+
+ Set_Corresponding_Body (Proc_Decl, Proc_Body_Id);
+ Set_Corresponding_Spec (Proc_Body, Proc_Id);
+
+ -- The body should not be inserted into the tree when the context is
+ -- ASIS or a generic unit because it is not part of the template. Note
+ -- that the body must still be generated in order to resolve the DIC
+ -- assertion expression.
+
+ if ASIS_Mode or Inside_A_Generic then
+ null;
+
+ -- Semi-insert the body into the tree for GNATprove by setting its
+ -- Parent field. This allows for proper upstream tree traversals.
+
+ elsif GNATprove_Mode then
+ Set_Parent (Proc_Body, Parent (Declaration_Node (Work_Typ)));
+
+ -- Otherwise the body is part of the freezing actions of the working
+ -- type.
+
+ else
+ Append_Freeze_Action (Work_Typ, Proc_Body);
+ end if;
+
+ <<Leave>>
+ Restore_Ghost_Mode (Mode);
+ end Build_DIC_Procedure_Body;
+
+ -------------------------------------
+ -- Build_DIC_Procedure_Declaration --
+ -------------------------------------
+
+ -- WARNING: This routine manages Ghost regions. Return statements must be
+ -- replaced by gotos which jump to the end of the routine and restore the
+ -- Ghost mode.
+
+ procedure Build_DIC_Procedure_Declaration (Typ : Entity_Id) is
+ Loc : constant Source_Ptr := Sloc (Typ);
+
+ DIC_Prag : Node_Id;
+ DIC_Typ : Entity_Id;
+ Mode : Ghost_Mode_Type;
+ Proc_Decl : Node_Id;
+ Proc_Id : Entity_Id;
+ Typ_Decl : Node_Id;
+
+ CRec_Typ : Entity_Id;
+ -- The corresponding record type of Full_Typ
+
+ Full_Base : Entity_Id;
+ -- The base type of Full_Typ
+
+ Full_Typ : Entity_Id;
+ -- The full view of working type
+
+ Obj_Id : Entity_Id;
+ -- The _object formal parameter of the DIC procedure
+
+ Priv_Typ : Entity_Id;
+ -- The partial view of working type
+
+ Work_Typ : Entity_Id;
+ -- The working type
+
+ begin
+ Work_Typ := Base_Type (Typ);
+
+ -- Do not process class-wide types as these are Itypes, but lack a first
+ -- subtype (see below).
+
+ if Is_Class_Wide_Type (Work_Typ) then
+ return;
+
+ -- Do not process the underlying full view of a private type. There is
+ -- no way to get back to the partial view, plus the body will be built
+ -- by the full view or the base type.
+
+ elsif Is_Underlying_Full_View (Work_Typ) then
+ return;
+
+ -- Use the first subtype when dealing with various base types
+
+ elsif Is_Itype (Work_Typ) then
+ Work_Typ := First_Subtype (Work_Typ);
+
+ -- The input denotes the corresponding record type of a protected or a
+ -- task type. Work with the concurrent type because the corresponding
+ -- record type may not be visible to clients of the type.
+
+ elsif Ekind (Work_Typ) = E_Record_Type
+ and then Is_Concurrent_Record_Type (Work_Typ)
+ then
+ Work_Typ := Corresponding_Concurrent_Type (Work_Typ);
+ end if;
+
+ -- The working type may be subject to pragma Ghost. Set the mode now to
+ -- ensure that the DIC procedure is properly marked as Ghost.
+
+ Set_Ghost_Mode (Work_Typ, Mode);
+
+ -- The type must be either subject to a DIC pragma or inherit one from a
+ -- parent type.
+
+ pragma Assert (Has_DIC (Work_Typ));
+
+ -- Recover the type which defines the DIC pragma. This is either the
+ -- working type itself or a parent type when the pragma is inherited.
+
+ DIC_Typ := Find_DIC_Type (Work_Typ);
+ pragma Assert (Present (DIC_Typ));
+
+ DIC_Prag := Get_Pragma (DIC_Typ, Pragma_Default_Initial_Condition);
+ pragma Assert (Present (DIC_Prag));
+
+ -- Nothing to do if pragma DIC appears without an argument or its sole
+ -- argument is "null".
+
+ if not Is_Verifiable_DIC_Pragma (DIC_Prag) then
+ goto Leave;
+
+ -- Nothing to do if the type already has a DIC procedure
+
+ elsif Present (DIC_Procedure (Work_Typ)) then
+ goto Leave;
+ end if;
+
+ Proc_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars =>
+ New_External_Name (Chars (Work_Typ), "Default_Initial_Condition"));
+
+ -- Perform minor decoration in case the declaration is not analyzed
+
+ Set_Ekind (Proc_Id, E_Procedure);
+ Set_Etype (Proc_Id, Standard_Void_Type);
+ Set_Scope (Proc_Id, Current_Scope);
+
+ Set_Is_DIC_Procedure (Proc_Id);
+ Set_DIC_Procedure (Work_Typ, Proc_Id);
+
+ -- The DIC procedure requires debug info when the assertion expression
+ -- is subject to Source Coverage Obligations.
+
+ if Opt.Generate_SCO then
+ Set_Needs_Debug_Info (Proc_Id);
+ end if;
+
+ -- Obtain all views of the input type
+
+ Get_Views (Work_Typ, Priv_Typ, Full_Typ, Full_Base, CRec_Typ);
+
+ -- Associate the DIC procedure and various relevant flags with all views
+
+ Propagate_DIC_Attributes (Priv_Typ, From_Typ => Work_Typ);
+ Propagate_DIC_Attributes (Full_Typ, From_Typ => Work_Typ);
+ Propagate_DIC_Attributes (Full_Base, From_Typ => Work_Typ);
+ Propagate_DIC_Attributes (CRec_Typ, From_Typ => Work_Typ);
+
+ -- The declaration of the DIC procedure must be inserted after the
+ -- declaration of the partial view as this allows for proper external
+ -- visibility.
+
+ if Present (Priv_Typ) then
+ Typ_Decl := Declaration_Node (Priv_Typ);
+
+ -- Derived types with the full view as parent do not have a partial
+ -- view. Insert the DIC procedure after the derived type.
+
+ else
+ Typ_Decl := Declaration_Node (Full_Typ);
+ end if;
+
+ -- The type should have a declarative node
+
+ pragma Assert (Present (Typ_Decl));
+
+ -- Create the formal parameter which emulates the variable-like behavior
+ -- of the type's current instance.
+
+ Obj_Id := Make_Defining_Identifier (Loc, Chars => Name_uObject);
+
+ -- Perform minor decoration in case the declaration is not analyzed
+
+ Set_Ekind (Obj_Id, E_In_Parameter);
+ Set_Etype (Obj_Id, Work_Typ);
+ Set_Scope (Obj_Id, Proc_Id);
+
+ Set_First_Entity (Proc_Id, Obj_Id);
+
+ -- Generate:
+ -- procedure <Work_Typ>DIC (_object : <Work_Typ>);
+
+ Proc_Decl :=
+ Make_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Proc_Id,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Obj_Id,
+ Parameter_Type =>
+ New_Occurrence_Of (Work_Typ, Loc)))));
+
+ -- The declaration should not be inserted into the tree when the context
+ -- is ASIS or a generic unit because it is not part of the template.
+
+ if ASIS_Mode or Inside_A_Generic then
+ null;
+
+ -- Semi-insert the declaration into the tree for GNATprove by setting
+ -- its Parent field. This allows for proper upstream tree traversals.
+
+ elsif GNATprove_Mode then
+ Set_Parent (Proc_Decl, Parent (Typ_Decl));
+
+ -- Otherwise insert the declaration
+
+ else
+ Insert_After_And_Analyze (Typ_Decl, Proc_Decl);
+ end if;
+
+ <<Leave>>
+ Restore_Ghost_Mode (Mode);
+ end Build_DIC_Procedure_Declaration;
+
+ --------------------------
+ -- Build_Procedure_Form --
+ --------------------------
+
+ procedure Build_Procedure_Form (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Subp : constant Entity_Id := Defining_Entity (N);
+
+ Func_Formal : Entity_Id;
+ Proc_Formals : List_Id;
+ Proc_Decl : Node_Id;
+
+ begin
+ -- No action needed if this transformation was already done, or in case
+ -- of subprogram renaming declarations.
+
+ if Nkind (Specification (N)) = N_Procedure_Specification
+ or else Nkind (N) = N_Subprogram_Renaming_Declaration
+ then
+ return;
+ end if;
+
+ -- Ditto when dealing with an expression function, where both the
+ -- original expression and the generated declaration end up being
+ -- expanded here.
+
+ if Rewritten_For_C (Subp) then
+ return;
+ end if;
+
+ Proc_Formals := New_List;
+
+ -- Create a list of formal parameters with the same types as the
+ -- function.
+
+ Func_Formal := First_Formal (Subp);
+ while Present (Func_Formal) loop
+ Append_To (Proc_Formals,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Chars (Func_Formal)),
+ Parameter_Type =>
+ New_Occurrence_Of (Etype (Func_Formal), Loc)));
+
+ Next_Formal (Func_Formal);
+ end loop;
+
+ -- Add an extra out parameter to carry the function result
+
+ Name_Len := 6;
+ Name_Buffer (1 .. Name_Len) := "RESULT";
+ Append_To (Proc_Formals,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Chars => Name_Find),
+ Out_Present => True,
+ Parameter_Type => New_Occurrence_Of (Etype (Subp), Loc)));
+
+ -- The new procedure declaration is inserted immediately after the
+ -- function declaration. The processing in Build_Procedure_Body_Form
+ -- relies on this order.
+
+ Proc_Decl :=
+ Make_Subprogram_Declaration (Loc,
+ Specification =>
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc, Chars (Subp)),
+ Parameter_Specifications => Proc_Formals));
+
+ Insert_After_And_Analyze (Unit_Declaration_Node (Subp), Proc_Decl);
+
+ -- Entity of procedure must remain invisible so that it does not
+ -- overload subsequent references to the original function.
+
+ Set_Is_Immediately_Visible (Defining_Entity (Proc_Decl), False);
+
+ -- Mark the function as having a procedure form and link the function
+ -- and its internally built procedure.
+
+ Set_Rewritten_For_C (Subp);
+ Set_Corresponding_Procedure (Subp, Defining_Entity (Proc_Decl));
+ Set_Corresponding_Function (Defining_Entity (Proc_Decl), Subp);
+ end Build_Procedure_Form;
+
------------------------
-- Build_Runtime_Call --
------------------------
@@ -1556,6 +2858,136 @@ package body Exp_Util is
return Build_Task_Image_Function (Loc, Decls, Stats, Res);
end Build_Task_Record_Image;
+ ---------------------------------------
+ -- Build_Transient_Object_Statements --
+ ---------------------------------------
+
+ procedure Build_Transient_Object_Statements
+ (Obj_Decl : Node_Id;
+ Fin_Call : out Node_Id;
+ Hook_Assign : out Node_Id;
+ Hook_Clear : out Node_Id;
+ Hook_Decl : out Node_Id;
+ Ptr_Decl : out Node_Id;
+ Finalize_Obj : Boolean := True)
+ is
+ Loc : constant Source_Ptr := Sloc (Obj_Decl);
+ Obj_Id : constant Entity_Id := Defining_Entity (Obj_Decl);
+ Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
+
+ Desig_Typ : Entity_Id;
+ Hook_Expr : Node_Id;
+ Hook_Id : Entity_Id;
+ Obj_Ref : Node_Id;
+ Ptr_Typ : Entity_Id;
+
+ begin
+ -- Recover the type of the object
+
+ Desig_Typ := Obj_Typ;
+
+ if Is_Access_Type (Desig_Typ) then
+ Desig_Typ := Available_View (Designated_Type (Desig_Typ));
+ end if;
+
+ -- Create an access type which provides a reference to the transient
+ -- object. Generate:
+
+ -- type Ptr_Typ is access all Desig_Typ;
+
+ Ptr_Typ := Make_Temporary (Loc, 'A');
+ Set_Ekind (Ptr_Typ, E_General_Access_Type);
+ Set_Directly_Designated_Type (Ptr_Typ, Desig_Typ);
+
+ Ptr_Decl :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Ptr_Typ,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc)));
+
+ -- Create a temporary check which acts as a hook to the transient
+ -- object. Generate:
+
+ -- Hook : Ptr_Typ := null;
+
+ Hook_Id := Make_Temporary (Loc, 'T');
+ Set_Ekind (Hook_Id, E_Variable);
+ Set_Etype (Hook_Id, Ptr_Typ);
+
+ Hook_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Hook_Id,
+ Object_Definition => New_Occurrence_Of (Ptr_Typ, Loc),
+ Expression => Make_Null (Loc));
+
+ -- Mark the temporary as a hook. This signals the machinery in
+ -- Build_Finalizer to recognize this special case.
+
+ Set_Status_Flag_Or_Transient_Decl (Hook_Id, Obj_Decl);
+
+ -- Hook the transient object to the temporary. Generate:
+
+ -- Hook := Ptr_Typ (Obj_Id);
+ -- <or>
+ -- Hool := Obj_Id'Unrestricted_Access;
+
+ if Is_Access_Type (Obj_Typ) then
+ Hook_Expr :=
+ Unchecked_Convert_To (Ptr_Typ, New_Occurrence_Of (Obj_Id, Loc));
+ else
+ Hook_Expr :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Obj_Id, Loc),
+ Attribute_Name => Name_Unrestricted_Access);
+ end if;
+
+ Hook_Assign :=
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Hook_Id, Loc),
+ Expression => Hook_Expr);
+
+ -- Crear the hook prior to finalizing the object. Generate:
+
+ -- Hook := null;
+
+ Hook_Clear :=
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Hook_Id, Loc),
+ Expression => Make_Null (Loc));
+
+ -- Finalize the object. Generate:
+
+ -- [Deep_]Finalize (Obj_Ref[.all]);
+
+ if Finalize_Obj then
+ Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
+
+ if Is_Access_Type (Obj_Typ) then
+ Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
+ Set_Etype (Obj_Ref, Desig_Typ);
+ end if;
+
+ Fin_Call :=
+ Make_Final_Call
+ (Obj_Ref => Obj_Ref,
+ Typ => Desig_Typ);
+
+ -- Otherwise finalize the hook. Generate:
+
+ -- [Deep_]Finalize (Hook.all);
+
+ else
+ Fin_Call :=
+ Make_Final_Call (
+ Obj_Ref =>
+ Make_Explicit_Dereference (Loc,
+ Prefix => New_Occurrence_Of (Hook_Id, Loc)),
+ Typ => Desig_Typ);
+ end if;
+ end Build_Transient_Object_Statements;
+
-----------------------------
-- Check_Float_Op_Overflow --
-----------------------------
@@ -1672,13 +3104,10 @@ package body Exp_Util is
function Containing_Package_With_Ext_Axioms
(E : Entity_Id) return Entity_Id
is
- Decl : Node_Id;
- First_Ax_Parent_Scope : Entity_Id;
-
begin
-- E is the package or generic package which is externally axiomatized
- if Ekind_In (E, E_Package, E_Generic_Package)
+ if Ekind_In (E, E_Generic_Package, E_Package)
and then Has_Annotate_Pragma_For_External_Axiomatization (E)
then
return E;
@@ -1687,29 +3116,36 @@ package body Exp_Util is
-- If E's scope is axiomatized, E is axiomatized
if Present (Scope (E)) then
- First_Ax_Parent_Scope :=
- Containing_Package_With_Ext_Axioms (Scope (E));
-
- if Present (First_Ax_Parent_Scope) then
- return First_Ax_Parent_Scope;
- end if;
-
+ declare
+ First_Ax_Parent_Scope : constant Entity_Id :=
+ Containing_Package_With_Ext_Axioms (Scope (E));
+ begin
+ if Present (First_Ax_Parent_Scope) then
+ return First_Ax_Parent_Scope;
+ end if;
+ end;
end if;
-- Otherwise, if E is a package instance, it is axiomatized if the
-- corresponding generic package is axiomatized.
if Ekind (E) = E_Package then
- if Nkind (Parent (E)) = N_Defining_Program_Unit_Name then
- Decl := Parent (Parent (E));
- else
- Decl := Parent (E);
- end if;
+ declare
+ Par : constant Node_Id := Parent (E);
+ Decl : Node_Id;
- if Present (Generic_Parent (Decl)) then
- return
- Containing_Package_With_Ext_Axioms (Generic_Parent (Decl));
- end if;
+ begin
+ if Nkind (Par) = N_Defining_Program_Unit_Name then
+ Decl := Parent (Par);
+ else
+ Decl := Par;
+ end if;
+
+ if Present (Generic_Parent (Decl)) then
+ return
+ Containing_Package_With_Ext_Axioms (Generic_Parent (Decl));
+ end if;
+ end;
end if;
return Empty;
@@ -1738,8 +3174,52 @@ package body Exp_Util is
-----------------------------------
function Corresponding_Runtime_Package (Typ : Entity_Id) return RTU_Id is
+ function Has_One_Entry_And_No_Queue (T : Entity_Id) return Boolean;
+ -- Return True if protected type T has one entry and the maximum queue
+ -- length is one.
+
+ --------------------------------
+ -- Has_One_Entry_And_No_Queue --
+ --------------------------------
+
+ function Has_One_Entry_And_No_Queue (T : Entity_Id) return Boolean is
+ Item : Entity_Id;
+ Is_First : Boolean := True;
+
+ begin
+ Item := First_Entity (T);
+ while Present (Item) loop
+ if Is_Entry (Item) then
+
+ -- The protected type has more than one entry
+
+ if not Is_First then
+ return False;
+ end if;
+
+ -- The queue length is not one
+
+ if not Restriction_Active (No_Entry_Queue)
+ and then Get_Max_Queue_Length (Item) /= Uint_1
+ then
+ return False;
+ end if;
+
+ Is_First := False;
+ end if;
+
+ Next_Entity (Item);
+ end loop;
+
+ return True;
+ end Has_One_Entry_And_No_Queue;
+
+ -- Local variables
+
Pkg_Id : RTU_Id := RTU_Null;
+ -- Start of processing for Corresponding_Runtime_Package
+
begin
pragma Assert (Is_Concurrent_Type (Typ));
@@ -1765,9 +3245,8 @@ package body Exp_Util is
or else Has_Interrupt_Handler (Typ)
then
if Abort_Allowed
- or else Restriction_Active (No_Entry_Queue) = False
or else Restriction_Active (No_Select_Statements) = False
- or else Number_Entries (Typ) > 1
+ or else not Has_One_Entry_And_No_Queue (Typ)
or else (Has_Attach_Handler (Typ)
and then not Restricted_Profile)
then
@@ -1899,6 +3378,15 @@ package body Exp_Util is
end if;
end Ensure_Defined;
+ -----------------
+ -- Entity_Hash --
+ -----------------
+
+ function Entity_Hash (E : Entity_Id) return Num_Primitives is
+ begin
+ return Num_Primitives (E mod Primitives_Mapping_Size);
+ end Entity_Hash;
+
--------------------
-- Entry_Names_OK --
--------------------
@@ -2213,7 +3701,7 @@ package body Exp_Util is
-- If the type of the expression is an internally generated type it
-- may not be necessary to create a new subtype. However there are two
-- exceptions: references to the current instances, and aliased array
- -- object declarations for which the backend needs to create a template.
+ -- object declarations for which the back end has to create a template.
elsif Is_Constrained (Exp_Typ)
and then not Is_Class_Wide_Type (Unc_Type)
@@ -2294,7 +3782,13 @@ package body Exp_Util is
then
-- Nothing to be done if no underlying record view available
- if No (Underlying_Record_View (Unc_Type)) then
+ -- If this is a limited type derived from a type with unknown
+ -- discriminants, do not expand either, so that subsequent expansion
+ -- of the call can add build-in-place parameters to call.
+
+ if No (Underlying_Record_View (Unc_Type))
+ or else Is_Limited_Type (Unc_Type)
+ then
null;
-- Otherwise use the Underlying_Record_View to create the proper
@@ -2439,6 +3933,66 @@ package body Exp_Util is
return TSS (Utyp, TSS_Finalize_Address);
end Finalize_Address;
+ -------------------
+ -- Find_DIC_Type --
+ -------------------
+
+ function Find_DIC_Type (Typ : Entity_Id) return Entity_Id is
+ Curr_Typ : Entity_Id;
+ -- The current type being examined in the parent hierarchy traversal
+
+ DIC_Typ : Entity_Id;
+ -- The type which carries the DIC pragma. This variable denotes the
+ -- partial view when private types are involved.
+
+ Par_Typ : Entity_Id;
+ -- The parent type of the current type. This variable denotes the full
+ -- view when private types are involved.
+
+ begin
+ -- The input type defines its own DIC pragma, therefore it is the owner
+
+ if Has_Own_DIC (Typ) then
+ DIC_Typ := Typ;
+
+ -- Otherwise the DIC pragma is inherited from a parent type
+
+ else
+ pragma Assert (Has_Inherited_DIC (Typ));
+
+ -- Climb the parent chain
+
+ Curr_Typ := Typ;
+ loop
+ -- Inspect the parent type. Do not consider subtypes as they
+ -- inherit the DIC attributes from their base types.
+
+ DIC_Typ := Base_Type (Etype (Curr_Typ));
+
+ -- Look at the full view of a private type because the type may
+ -- have a hidden parent introduced in the full view.
+
+ Par_Typ := DIC_Typ;
+
+ if Is_Private_Type (Par_Typ)
+ and then Present (Full_View (Par_Typ))
+ then
+ Par_Typ := Full_View (Par_Typ);
+ end if;
+
+ -- Stop the climb once the nearest parent type which defines a DIC
+ -- pragma of its own is encountered or when the root of the parent
+ -- chain is reached.
+
+ exit when Has_Own_DIC (DIC_Typ) or else Curr_Typ = Par_Typ;
+
+ Curr_Typ := Par_Typ;
+ end loop;
+ end if;
+
+ return DIC_Typ;
+ end Find_DIC_Type;
+
------------------------
-- Find_Interface_ADT --
------------------------
@@ -2703,50 +4257,6 @@ package body Exp_Util is
end if;
end Find_Optional_Prim_Op;
- -------------------------------
- -- Find_Primitive_Operations --
- -------------------------------
-
- function Find_Primitive_Operations
- (T : Entity_Id;
- Name : Name_Id) return Node_Id
- is
- Prim_Elmt : Elmt_Id;
- Prim_Id : Entity_Id;
- Ref : Node_Id;
- Typ : Entity_Id := T;
-
- begin
- if Is_Class_Wide_Type (Typ) then
- Typ := Root_Type (Typ);
- end if;
-
- Typ := Underlying_Type (Typ);
-
- Ref := Empty;
- Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
- while Present (Prim_Elmt) loop
- Prim_Id := Node (Prim_Elmt);
- if Chars (Prim_Id) = Name then
-
- -- If this is the first primitive operation found,
- -- create a reference to it.
-
- if No (Ref) then
- Ref := New_Occurrence_Of (Prim_Id, Sloc (T));
-
- -- Otherwise, add interpretation to existing reference
-
- else
- Add_One_Interp (Ref, Prim_Id, Etype (Prim_Id));
- end if;
- end if;
- Next_Elmt (Prim_Elmt);
- end loop;
-
- return Ref;
- end Find_Primitive_Operations;
-
------------------
-- Find_Prim_Op --
------------------
@@ -2894,10 +4404,9 @@ package body Exp_Util is
N_Discriminant_Association,
N_Parameter_Association,
N_Pragma_Argument_Association)
- and then not Nkind_In
- (Parent (Par), N_Function_Call,
- N_Procedure_Call_Statement,
- N_Entry_Call_Statement)
+ and then not Nkind_In (Parent (Par), N_Function_Call,
+ N_Procedure_Call_Statement,
+ N_Entry_Call_Statement)
then
return Par;
@@ -3072,17 +4581,21 @@ package body Exp_Util is
Name_Req : Boolean := False;
Related_Id : Entity_Id := Empty;
Is_Low_Bound : Boolean := False;
- Is_High_Bound : Boolean := False)
+ Is_High_Bound : Boolean := False;
+ Mode : Force_Evaluation_Mode := Relaxed)
is
begin
Remove_Side_Effects
- (Exp => Exp,
- Name_Req => Name_Req,
- Variable_Ref => True,
- Renaming_Req => False,
- Related_Id => Related_Id,
- Is_Low_Bound => Is_Low_Bound,
- Is_High_Bound => Is_High_Bound);
+ (Exp => Exp,
+ Name_Req => Name_Req,
+ Variable_Ref => True,
+ Renaming_Req => False,
+ Related_Id => Related_Id,
+ Is_Low_Bound => Is_Low_Bound,
+ Is_High_Bound => Is_High_Bound,
+ Check_Side_Effects =>
+ Is_Static_Expression (Exp)
+ or else Mode = Relaxed);
end Force_Evaluation;
---------------------------------
@@ -3617,7 +5130,7 @@ package body Exp_Util is
begin
if Nkind (N) = N_Pragma
- and then Get_Pragma_Id (Pragma_Name (N)) = Pragma_Annotate
+ and then Get_Pragma_Id (N) = Pragma_Annotate
and then List_Length (Pragma_Argument_Associations (N)) = 2
then
declare
@@ -3744,20 +5257,11 @@ package body Exp_Util is
P := Node;
while Present (P) loop
case Nkind (P) is
- when N_Subprogram_Body =>
- return True;
-
- when N_If_Statement =>
- return False;
-
- when N_Loop_Statement =>
- return False;
-
- when N_Case_Statement =>
- return False;
-
- when others =>
- P := Parent (P);
+ when N_Subprogram_Body => return True;
+ when N_If_Statement => return False;
+ when N_Loop_Statement => return False;
+ when N_Case_Statement => return False;
+ when others => P := Parent (P);
end case;
end loop;
@@ -4053,8 +5557,8 @@ package body Exp_Util is
-- They will be moved further out when the while loop or elsif
-- is analyzed.
- when N_Iteration_Scheme |
- N_Elsif_Part
+ when N_Elsif_Part
+ | N_Iteration_Scheme
=>
if N = Condition (P) then
if Present (Condition_Actions (P)) then
@@ -4074,22 +5578,6 @@ package body Exp_Util is
end if;
return;
-
- -- Iteration scheme located in a transient scope
-
- elsif Nkind (P) = N_Iteration_Scheme
- and then Present (Wrapped_Node)
- then
- -- If the enclosing iterator loop is marked as requiring the
- -- secondary stack then the actions must be inserted in the
- -- transient scope.
-
- if Uses_Sec_Stack
- (Find_Enclosing_Iterator_Loop (Current_Scope))
- then
- Store_Before_Actions_In_Scope (Ins_Actions);
- return;
- end if;
end if;
-- Statements, declarations, pragmas, representation clauses
@@ -4097,73 +5585,73 @@ package body Exp_Util is
when
-- Statements
- N_Procedure_Call_Statement |
- N_Statement_Other_Than_Procedure_Call |
+ N_Procedure_Call_Statement
+ | N_Statement_Other_Than_Procedure_Call
-- Pragmas
- N_Pragma |
+ | N_Pragma
-- Representation_Clause
- N_At_Clause |
- N_Attribute_Definition_Clause |
- N_Enumeration_Representation_Clause |
- N_Record_Representation_Clause |
+ | N_At_Clause
+ | N_Attribute_Definition_Clause
+ | N_Enumeration_Representation_Clause
+ | N_Record_Representation_Clause
-- Declarations
- N_Abstract_Subprogram_Declaration |
- N_Entry_Body |
- N_Exception_Declaration |
- N_Exception_Renaming_Declaration |
- N_Expression_Function |
- N_Formal_Abstract_Subprogram_Declaration |
- N_Formal_Concrete_Subprogram_Declaration |
- N_Formal_Object_Declaration |
- N_Formal_Type_Declaration |
- N_Full_Type_Declaration |
- N_Function_Instantiation |
- N_Generic_Function_Renaming_Declaration |
- N_Generic_Package_Declaration |
- N_Generic_Package_Renaming_Declaration |
- N_Generic_Procedure_Renaming_Declaration |
- N_Generic_Subprogram_Declaration |
- N_Implicit_Label_Declaration |
- N_Incomplete_Type_Declaration |
- N_Number_Declaration |
- N_Object_Declaration |
- N_Object_Renaming_Declaration |
- N_Package_Body |
- N_Package_Body_Stub |
- N_Package_Declaration |
- N_Package_Instantiation |
- N_Package_Renaming_Declaration |
- N_Private_Extension_Declaration |
- N_Private_Type_Declaration |
- N_Procedure_Instantiation |
- N_Protected_Body |
- N_Protected_Body_Stub |
- N_Protected_Type_Declaration |
- N_Single_Task_Declaration |
- N_Subprogram_Body |
- N_Subprogram_Body_Stub |
- N_Subprogram_Declaration |
- N_Subprogram_Renaming_Declaration |
- N_Subtype_Declaration |
- N_Task_Body |
- N_Task_Body_Stub |
- N_Task_Type_Declaration |
+ | N_Abstract_Subprogram_Declaration
+ | N_Entry_Body
+ | N_Exception_Declaration
+ | N_Exception_Renaming_Declaration
+ | N_Expression_Function
+ | N_Formal_Abstract_Subprogram_Declaration
+ | N_Formal_Concrete_Subprogram_Declaration
+ | N_Formal_Object_Declaration
+ | N_Formal_Type_Declaration
+ | N_Full_Type_Declaration
+ | N_Function_Instantiation
+ | N_Generic_Function_Renaming_Declaration
+ | N_Generic_Package_Declaration
+ | N_Generic_Package_Renaming_Declaration
+ | N_Generic_Procedure_Renaming_Declaration
+ | N_Generic_Subprogram_Declaration
+ | N_Implicit_Label_Declaration
+ | N_Incomplete_Type_Declaration
+ | N_Number_Declaration
+ | N_Object_Declaration
+ | N_Object_Renaming_Declaration
+ | N_Package_Body
+ | N_Package_Body_Stub
+ | N_Package_Declaration
+ | N_Package_Instantiation
+ | N_Package_Renaming_Declaration
+ | N_Private_Extension_Declaration
+ | N_Private_Type_Declaration
+ | N_Procedure_Instantiation
+ | N_Protected_Body
+ | N_Protected_Body_Stub
+ | N_Protected_Type_Declaration
+ | N_Single_Task_Declaration
+ | N_Subprogram_Body
+ | N_Subprogram_Body_Stub
+ | N_Subprogram_Declaration
+ | N_Subprogram_Renaming_Declaration
+ | N_Subtype_Declaration
+ | N_Task_Body
+ | N_Task_Body_Stub
+ | N_Task_Type_Declaration
-- Use clauses can appear in lists of declarations
- N_Use_Package_Clause |
- N_Use_Type_Clause |
+ | N_Use_Package_Clause
+ | N_Use_Type_Clause
-- Freeze entity behaves like a declaration or statement
- N_Freeze_Entity |
- N_Freeze_Generic_Entity
+ | N_Freeze_Entity
+ | N_Freeze_Generic_Entity
=>
-- Do not insert here if the item is not a list member (this
-- happens for example with a triggering statement, and the
@@ -4221,22 +5709,21 @@ package body Exp_Util is
-- or a subexpression. We tell the difference by looking at the
-- Etype. It is set to Standard_Void_Type in the statement case.
- when
- N_Raise_xxx_Error =>
- if Etype (P) = Standard_Void_Type then
- if P = Wrapped_Node then
- Store_Before_Actions_In_Scope (Ins_Actions);
- else
- Insert_List_Before_And_Analyze (P, Ins_Actions);
- end if;
+ when N_Raise_xxx_Error =>
+ if Etype (P) = Standard_Void_Type then
+ if P = Wrapped_Node then
+ Store_Before_Actions_In_Scope (Ins_Actions);
+ else
+ Insert_List_Before_And_Analyze (P, Ins_Actions);
+ end if;
- return;
+ return;
- -- In the subexpression case, keep climbing
+ -- In the subexpression case, keep climbing
- else
- null;
- end if;
+ else
+ null;
+ end if;
-- If a component association appears within a loop created for
-- an array aggregate, attach the actions to the association so
@@ -4245,74 +5732,73 @@ package body Exp_Util is
-- an association that will generate a loop, its Loop_Actions
-- attribute is already initialized (see exp_aggr.adb).
- -- The list of loop_actions can in turn generate additional ones,
+ -- The list of Loop_Actions can in turn generate additional ones,
-- that are inserted before the associated node. If the associated
-- node is outside the aggregate, the new actions are collected
- -- at the end of the loop actions, to respect the order in which
+ -- at the end of the Loop_Actions, to respect the order in which
-- they are to be elaborated.
- when
- N_Component_Association =>
- if Nkind (Parent (P)) = N_Aggregate
- and then Present (Loop_Actions (P))
- then
- if Is_Empty_List (Loop_Actions (P)) then
- Set_Loop_Actions (P, Ins_Actions);
- Analyze_List (Ins_Actions);
-
- else
- declare
- Decl : Node_Id;
-
- begin
- -- Check whether these actions were generated by a
- -- declaration that is part of the loop_ actions
- -- for the component_association.
-
- Decl := Assoc_Node;
- while Present (Decl) loop
- exit when Parent (Decl) = P
- and then Is_List_Member (Decl)
- and then
- List_Containing (Decl) = Loop_Actions (P);
- Decl := Parent (Decl);
- end loop;
-
- if Present (Decl) then
- Insert_List_Before_And_Analyze
- (Decl, Ins_Actions);
- else
- Insert_List_After_And_Analyze
- (Last (Loop_Actions (P)), Ins_Actions);
- end if;
- end;
- end if;
-
- return;
-
+ when N_Component_Association
+ | N_Iterated_Component_Association
+ =>
+ if Nkind (Parent (P)) = N_Aggregate
+ and then Present (Loop_Actions (P))
+ then
+ if Is_Empty_List (Loop_Actions (P)) then
+ Set_Loop_Actions (P, Ins_Actions);
+ Analyze_List (Ins_Actions);
else
- null;
+ declare
+ Decl : Node_Id;
+
+ begin
+ -- Check whether these actions were generated by a
+ -- declaration that is part of the Loop_Actions for
+ -- the component_association.
+
+ Decl := Assoc_Node;
+ while Present (Decl) loop
+ exit when Parent (Decl) = P
+ and then Is_List_Member (Decl)
+ and then
+ List_Containing (Decl) = Loop_Actions (P);
+ Decl := Parent (Decl);
+ end loop;
+
+ if Present (Decl) then
+ Insert_List_Before_And_Analyze
+ (Decl, Ins_Actions);
+ else
+ Insert_List_After_And_Analyze
+ (Last (Loop_Actions (P)), Ins_Actions);
+ end if;
+ end;
end if;
- -- Another special case, an attribute denoting a procedure call
-
- when
- N_Attribute_Reference =>
- if Is_Procedure_Attribute_Name (Attribute_Name (P)) then
- if P = Wrapped_Node then
- Store_Before_Actions_In_Scope (Ins_Actions);
- else
- Insert_List_Before_And_Analyze (P, Ins_Actions);
- end if;
+ return;
- return;
+ else
+ null;
+ end if;
- -- In the subexpression case, keep climbing
+ -- Another special case, an attribute denoting a procedure call
+ when N_Attribute_Reference =>
+ if Is_Procedure_Attribute_Name (Attribute_Name (P)) then
+ if P = Wrapped_Node then
+ Store_Before_Actions_In_Scope (Ins_Actions);
else
- null;
+ Insert_List_Before_And_Analyze (P, Ins_Actions);
end if;
+ return;
+
+ -- In the subexpression case, keep climbing
+
+ else
+ null;
+ end if;
+
-- A contract node should not belong to the tree
when N_Contract =>
@@ -4320,153 +5806,153 @@ package body Exp_Util is
-- For all other node types, keep climbing tree
- when
- N_Abortable_Part |
- N_Accept_Alternative |
- N_Access_Definition |
- N_Access_Function_Definition |
- N_Access_Procedure_Definition |
- N_Access_To_Object_Definition |
- N_Aggregate |
- N_Allocator |
- N_Aspect_Specification |
- N_Case_Expression |
- N_Case_Statement_Alternative |
- N_Character_Literal |
- N_Compilation_Unit |
- N_Compilation_Unit_Aux |
- N_Component_Clause |
- N_Component_Declaration |
- N_Component_Definition |
- N_Component_List |
- N_Constrained_Array_Definition |
- N_Decimal_Fixed_Point_Definition |
- N_Defining_Character_Literal |
- N_Defining_Identifier |
- N_Defining_Operator_Symbol |
- N_Defining_Program_Unit_Name |
- N_Delay_Alternative |
- N_Delta_Constraint |
- N_Derived_Type_Definition |
- N_Designator |
- N_Digits_Constraint |
- N_Discriminant_Association |
- N_Discriminant_Specification |
- N_Empty |
- N_Entry_Body_Formal_Part |
- N_Entry_Call_Alternative |
- N_Entry_Declaration |
- N_Entry_Index_Specification |
- N_Enumeration_Type_Definition |
- N_Error |
- N_Exception_Handler |
- N_Expanded_Name |
- N_Explicit_Dereference |
- N_Extension_Aggregate |
- N_Floating_Point_Definition |
- N_Formal_Decimal_Fixed_Point_Definition |
- N_Formal_Derived_Type_Definition |
- N_Formal_Discrete_Type_Definition |
- N_Formal_Floating_Point_Definition |
- N_Formal_Modular_Type_Definition |
- N_Formal_Ordinary_Fixed_Point_Definition |
- N_Formal_Package_Declaration |
- N_Formal_Private_Type_Definition |
- N_Formal_Incomplete_Type_Definition |
- N_Formal_Signed_Integer_Type_Definition |
- N_Function_Call |
- N_Function_Specification |
- N_Generic_Association |
- N_Handled_Sequence_Of_Statements |
- N_Identifier |
- N_In |
- N_Index_Or_Discriminant_Constraint |
- N_Indexed_Component |
- N_Integer_Literal |
- N_Iterator_Specification |
- N_Itype_Reference |
- N_Label |
- N_Loop_Parameter_Specification |
- N_Mod_Clause |
- N_Modular_Type_Definition |
- N_Not_In |
- N_Null |
- N_Op_Abs |
- N_Op_Add |
- N_Op_And |
- N_Op_Concat |
- N_Op_Divide |
- N_Op_Eq |
- N_Op_Expon |
- N_Op_Ge |
- N_Op_Gt |
- N_Op_Le |
- N_Op_Lt |
- N_Op_Minus |
- N_Op_Mod |
- N_Op_Multiply |
- N_Op_Ne |
- N_Op_Not |
- N_Op_Or |
- N_Op_Plus |
- N_Op_Rem |
- N_Op_Rotate_Left |
- N_Op_Rotate_Right |
- N_Op_Shift_Left |
- N_Op_Shift_Right |
- N_Op_Shift_Right_Arithmetic |
- N_Op_Subtract |
- N_Op_Xor |
- N_Operator_Symbol |
- N_Ordinary_Fixed_Point_Definition |
- N_Others_Choice |
- N_Package_Specification |
- N_Parameter_Association |
- N_Parameter_Specification |
- N_Pop_Constraint_Error_Label |
- N_Pop_Program_Error_Label |
- N_Pop_Storage_Error_Label |
- N_Pragma_Argument_Association |
- N_Procedure_Specification |
- N_Protected_Definition |
- N_Push_Constraint_Error_Label |
- N_Push_Program_Error_Label |
- N_Push_Storage_Error_Label |
- N_Qualified_Expression |
- N_Quantified_Expression |
- N_Raise_Expression |
- N_Range |
- N_Range_Constraint |
- N_Real_Literal |
- N_Real_Range_Specification |
- N_Record_Definition |
- N_Reference |
- N_SCIL_Dispatch_Table_Tag_Init |
- N_SCIL_Dispatching_Call |
- N_SCIL_Membership_Test |
- N_Selected_Component |
- N_Signed_Integer_Type_Definition |
- N_Single_Protected_Declaration |
- N_Slice |
- N_String_Literal |
- N_Subtype_Indication |
- N_Subunit |
- N_Task_Definition |
- N_Terminate_Alternative |
- N_Triggering_Alternative |
- N_Type_Conversion |
- N_Unchecked_Expression |
- N_Unchecked_Type_Conversion |
- N_Unconstrained_Array_Definition |
- N_Unused_At_End |
- N_Unused_At_Start |
- N_Variant |
- N_Variant_Part |
- N_Validate_Unchecked_Conversion |
- N_With_Clause
+ when N_Abortable_Part
+ | N_Accept_Alternative
+ | N_Access_Definition
+ | N_Access_Function_Definition
+ | N_Access_Procedure_Definition
+ | N_Access_To_Object_Definition
+ | N_Aggregate
+ | N_Allocator
+ | N_Aspect_Specification
+ | N_Case_Expression
+ | N_Case_Statement_Alternative
+ | N_Character_Literal
+ | N_Compilation_Unit
+ | N_Compilation_Unit_Aux
+ | N_Component_Clause
+ | N_Component_Declaration
+ | N_Component_Definition
+ | N_Component_List
+ | N_Constrained_Array_Definition
+ | N_Decimal_Fixed_Point_Definition
+ | N_Defining_Character_Literal
+ | N_Defining_Identifier
+ | N_Defining_Operator_Symbol
+ | N_Defining_Program_Unit_Name
+ | N_Delay_Alternative
+ | N_Delta_Aggregate
+ | N_Delta_Constraint
+ | N_Derived_Type_Definition
+ | N_Designator
+ | N_Digits_Constraint
+ | N_Discriminant_Association
+ | N_Discriminant_Specification
+ | N_Empty
+ | N_Entry_Body_Formal_Part
+ | N_Entry_Call_Alternative
+ | N_Entry_Declaration
+ | N_Entry_Index_Specification
+ | N_Enumeration_Type_Definition
+ | N_Error
+ | N_Exception_Handler
+ | N_Expanded_Name
+ | N_Explicit_Dereference
+ | N_Extension_Aggregate
+ | N_Floating_Point_Definition
+ | N_Formal_Decimal_Fixed_Point_Definition
+ | N_Formal_Derived_Type_Definition
+ | N_Formal_Discrete_Type_Definition
+ | N_Formal_Floating_Point_Definition
+ | N_Formal_Modular_Type_Definition
+ | N_Formal_Ordinary_Fixed_Point_Definition
+ | N_Formal_Package_Declaration
+ | N_Formal_Private_Type_Definition
+ | N_Formal_Incomplete_Type_Definition
+ | N_Formal_Signed_Integer_Type_Definition
+ | N_Function_Call
+ | N_Function_Specification
+ | N_Generic_Association
+ | N_Handled_Sequence_Of_Statements
+ | N_Identifier
+ | N_In
+ | N_Index_Or_Discriminant_Constraint
+ | N_Indexed_Component
+ | N_Integer_Literal
+ | N_Iterator_Specification
+ | N_Itype_Reference
+ | N_Label
+ | N_Loop_Parameter_Specification
+ | N_Mod_Clause
+ | N_Modular_Type_Definition
+ | N_Not_In
+ | N_Null
+ | N_Op_Abs
+ | N_Op_Add
+ | N_Op_And
+ | N_Op_Concat
+ | N_Op_Divide
+ | N_Op_Eq
+ | N_Op_Expon
+ | N_Op_Ge
+ | N_Op_Gt
+ | N_Op_Le
+ | N_Op_Lt
+ | N_Op_Minus
+ | N_Op_Mod
+ | N_Op_Multiply
+ | N_Op_Ne
+ | N_Op_Not
+ | N_Op_Or
+ | N_Op_Plus
+ | N_Op_Rem
+ | N_Op_Rotate_Left
+ | N_Op_Rotate_Right
+ | N_Op_Shift_Left
+ | N_Op_Shift_Right
+ | N_Op_Shift_Right_Arithmetic
+ | N_Op_Subtract
+ | N_Op_Xor
+ | N_Operator_Symbol
+ | N_Ordinary_Fixed_Point_Definition
+ | N_Others_Choice
+ | N_Package_Specification
+ | N_Parameter_Association
+ | N_Parameter_Specification
+ | N_Pop_Constraint_Error_Label
+ | N_Pop_Program_Error_Label
+ | N_Pop_Storage_Error_Label
+ | N_Pragma_Argument_Association
+ | N_Procedure_Specification
+ | N_Protected_Definition
+ | N_Push_Constraint_Error_Label
+ | N_Push_Program_Error_Label
+ | N_Push_Storage_Error_Label
+ | N_Qualified_Expression
+ | N_Quantified_Expression
+ | N_Raise_Expression
+ | N_Range
+ | N_Range_Constraint
+ | N_Real_Literal
+ | N_Real_Range_Specification
+ | N_Record_Definition
+ | N_Reference
+ | N_SCIL_Dispatch_Table_Tag_Init
+ | N_SCIL_Dispatching_Call
+ | N_SCIL_Membership_Test
+ | N_Selected_Component
+ | N_Signed_Integer_Type_Definition
+ | N_Single_Protected_Declaration
+ | N_Slice
+ | N_String_Literal
+ | N_Subtype_Indication
+ | N_Subunit
+ | N_Target_Name
+ | N_Task_Definition
+ | N_Terminate_Alternative
+ | N_Triggering_Alternative
+ | N_Type_Conversion
+ | N_Unchecked_Expression
+ | N_Unchecked_Type_Conversion
+ | N_Unconstrained_Array_Definition
+ | N_Unused_At_End
+ | N_Unused_At_Start
+ | N_Variant
+ | N_Variant_Part
+ | N_Validate_Unchecked_Conversion
+ | N_With_Clause
=>
null;
-
end case;
-- If we fall through above tests, keep climbing tree
@@ -4678,28 +6164,37 @@ package body Exp_Util is
Expr : Node_Id := Original_Node (N);
begin
- if Nkind (Expr) = N_Function_Call then
- Expr := Name (Expr);
-
-- When a function call appears in Object.Operation format, the
- -- original representation has two possible forms depending on the
- -- availability of actual parameters:
+ -- original representation has several possible forms depending on
+ -- the availability and form of actual parameters:
- -- Obj.Func_Call N_Selected_Component
- -- Obj.Func_Call (Param) N_Indexed_Component
+ -- Obj.Func N_Selected_Component
+ -- Obj.Func (Actual) N_Indexed_Component
+ -- Obj.Func (Formal => Actual) N_Function_Call, whose Name is an
+ -- N_Selected_Component
- else
- if Nkind (Expr) = N_Indexed_Component then
+ loop
+ if Nkind (Expr) = N_Function_Call then
+ Expr := Name (Expr);
+
+ -- "Obj.Func (Actual)" case
+
+ elsif Nkind (Expr) = N_Indexed_Component then
Expr := Prefix (Expr);
- end if;
- if Nkind (Expr) = N_Selected_Component then
+ -- "Obj.Func" or "Obj.Func (Formal => Actual) case
+
+ elsif Nkind (Expr) = N_Selected_Component then
Expr := Selector_Name (Expr);
+
+ else
+ exit;
end if;
- end if;
+ end loop;
return
- Nkind_In (Expr, N_Expanded_Name, N_Identifier)
+ Nkind (Expr) in N_Has_Entity
+ and then Present (Entity (Expr))
and then Ekind (Entity (Expr)) = E_Function
and then Needs_Finalization (Etype (Entity (Expr)));
end Is_Controlled_Function_Call;
@@ -5007,7 +6502,7 @@ package body Exp_Util is
-- explicit aliases of it:
-- do
- -- Trans_Id : Ctrl_Typ ...; -- controlled transient object
+ -- Trans_Id : Ctrl_Typ ...; -- transient object
-- Alias : ... := Trans_Id; -- object is aliased
-- Val : constant Boolean :=
-- ... Alias ...; -- aliasing ends
@@ -5176,6 +6671,10 @@ package body Exp_Util is
and then Requires_Transient_Scope (Desig)
and then Nkind (Rel_Node) /= N_Simple_Return_Statement
+ -- Do not consider a transient object that was already processed
+
+ and then not Is_Finalized_Transient (Obj_Id)
+
-- Do not consider renamed or 'reference-d transient objects because
-- the act of renaming extends the object's lifetime.
@@ -6349,29 +7848,19 @@ package body Exp_Util is
function Make_Invariant_Call (Expr : Node_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (Expr);
- Typ : Entity_Id;
+ Typ : constant Entity_Id := Base_Type (Etype (Expr));
- begin
- Typ := Etype (Expr);
-
- -- Subtypes may be subject to invariants coming from their respective
- -- base types. The subtype may be fully or partially private.
+ Proc_Id : Entity_Id;
- if Ekind_In (Typ, E_Array_Subtype,
- E_Private_Subtype,
- E_Record_Subtype,
- E_Record_Subtype_With_Private)
- then
- Typ := Base_Type (Typ);
- end if;
+ begin
+ pragma Assert (Has_Invariants (Typ));
- pragma Assert
- (Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ)));
+ Proc_Id := Invariant_Procedure (Typ);
+ pragma Assert (Present (Proc_Id));
return
Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (Invariant_Procedure (Typ), Loc),
+ Name => New_Occurrence_Of (Proc_Id, Loc),
Parameter_Associations => New_List (Relocate_Node (Expr)));
end Make_Invariant_Call;
@@ -6448,16 +7937,20 @@ package body Exp_Util is
-- Make_Predicate_Call --
-------------------------
+ -- WARNING: This routine manages Ghost regions. Return statements must be
+ -- replaced by gotos which jump to the end of the routine and restore the
+ -- Ghost mode.
+
function Make_Predicate_Call
(Typ : Entity_Id;
Expr : Node_Id;
Mem : Boolean := False) return Node_Id
is
- Loc : constant Source_Ptr := Sloc (Expr);
- Call : Node_Id;
- PFM : Entity_Id;
+ Loc : constant Source_Ptr := Sloc (Expr);
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
+ Call : Node_Id;
+ Func_Id : Entity_Id;
+ Mode : Ghost_Mode_Type;
begin
pragma Assert (Present (Predicate_Function (Typ)));
@@ -6465,33 +7958,24 @@ package body Exp_Util is
-- The related type may be subject to pragma Ghost. Set the mode now to
-- ensure that the call is properly marked as Ghost.
- Set_Ghost_Mode_From_Entity (Typ);
+ Set_Ghost_Mode (Typ, Mode);
-- Call special membership version if requested and available
- if Mem then
- PFM := Predicate_Function_M (Typ);
-
- if Present (PFM) then
- Call :=
- Make_Function_Call (Loc,
- Name => New_Occurrence_Of (PFM, Loc),
- Parameter_Associations => New_List (Relocate_Node (Expr)));
-
- Ghost_Mode := Save_Ghost_Mode;
- return Call;
- end if;
+ if Mem and then Present (Predicate_Function_M (Typ)) then
+ Func_Id := Predicate_Function_M (Typ);
+ else
+ Func_Id := Predicate_Function (Typ);
end if;
-- Case of calling normal predicate function
Call :=
Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (Predicate_Function (Typ), Loc),
+ Name => New_Occurrence_Of (Func_Id, Loc),
Parameter_Associations => New_List (Relocate_Node (Expr)));
- Ghost_Mode := Save_Ghost_Mode;
+ Restore_Ghost_Mode (Mode);
return Call;
end Make_Predicate_Call;
@@ -6503,9 +7987,38 @@ package body Exp_Util is
(Typ : Entity_Id;
Expr : Node_Id) return Node_Id
is
- Loc : constant Source_Ptr := Sloc (Expr);
- Arg_List : List_Id;
- Nam : Name_Id;
+ procedure Replace_Subtype_Reference (N : Node_Id);
+ -- Replace current occurrences of the subtype to which a dynamic
+ -- predicate applies, by the expression that triggers a predicate
+ -- check. This is needed for aspect Predicate_Failure, for which
+ -- we do not generate a wrapper procedure, but simply modify the
+ -- expression for the pragma of the predicate check.
+
+ --------------------------------
+ -- Replace_Subtype_Reference --
+ --------------------------------
+
+ procedure Replace_Subtype_Reference (N : Node_Id) is
+ begin
+ Rewrite (N, New_Copy_Tree (Expr));
+
+ -- We want to treat the node as if it comes from source, so
+ -- that ASIS will not ignore it.
+
+ Set_Comes_From_Source (N, True);
+ end Replace_Subtype_Reference;
+
+ procedure Replace_Subtype_References is
+ new Replace_Type_References_Generic (Replace_Subtype_Reference);
+
+ -- Local variables
+
+ Loc : constant Source_Ptr := Sloc (Expr);
+ Arg_List : List_Id;
+ Fail_Expr : Node_Id;
+ Nam : Name_Id;
+
+ -- Start of processing for Make_Predicate_Check
begin
-- If predicate checks are suppressed, then return a null statement. For
@@ -6540,17 +8053,24 @@ package body Exp_Util is
Make_Pragma_Argument_Association (Loc,
Expression => Make_Predicate_Call (Typ, Expr)));
+ -- If subtype has Predicate_Failure defined, add the correponding
+ -- expression as an additional pragma parameter, after replacing
+ -- current instances with the expression being checked.
+
if Has_Aspect (Typ, Aspect_Predicate_Failure) then
+ Fail_Expr :=
+ New_Copy_Tree
+ (Expression (Find_Aspect (Typ, Aspect_Predicate_Failure)));
+ Replace_Subtype_References (Fail_Expr, Typ);
+
Append_To (Arg_List,
Make_Pragma_Argument_Association (Loc,
- Expression =>
- New_Copy_Tree
- (Expression (Find_Aspect (Typ, Aspect_Predicate_Failure)))));
+ Expression => Fail_Expr));
end if;
return
Make_Pragma (Loc,
- Pragma_Identifier => Make_Identifier (Loc, Name_Check),
+ Chars => Name_Check,
Pragma_Argument_Associations => Arg_List);
end Make_Predicate_Check;
@@ -6888,11 +8408,10 @@ package body Exp_Util is
return False;
- elsif Is_Array_Type (Rec) then
- return Needs_Finalization (Component_Type (Rec));
-
else
- return Has_Controlled_Component (Rec);
+ return
+ Is_Array_Type (Rec)
+ and then Needs_Finalization (Component_Type (Rec));
end if;
else
return False;
@@ -6919,13 +8438,15 @@ package body Exp_Util is
elsif Disable_Controlled (T) then
return False;
+ elsif Is_Class_Wide_Type (T) and then Disable_Controlled (Etype (T)) then
+ return False;
+
else
-- Class-wide types are treated as controlled because derivations
-- from the root type can introduce controlled components.
return Is_Class_Wide_Type (T)
or else Is_Controlled (T)
- or else Has_Controlled_Component (T)
or else Has_Some_Controlled_Component (T)
or else
(Is_Concurrent_Type (T)
@@ -7186,7 +8707,6 @@ package body Exp_Util is
else
return False;
end if;
-
end case;
end Possible_Bit_Aligned_Component;
@@ -7277,11 +8797,11 @@ package body Exp_Util is
-- list and ensure that a finalizer is properly built.
case Nkind (N) is
- when N_Elsif_Part |
- N_If_Statement |
- N_Conditional_Entry_Call |
- N_Selective_Accept =>
-
+ when N_Conditional_Entry_Call
+ | N_Elsif_Part
+ | N_If_Statement
+ | N_Selective_Accept
+ =>
-- Check the "then statements" for elsif parts and if statements
if Nkind_In (N, N_Elsif_Part, N_If_Statement)
@@ -7313,15 +8833,15 @@ package body Exp_Util is
Analyze (Block);
end if;
- when N_Abortable_Part |
- N_Accept_Alternative |
- N_Case_Statement_Alternative |
- N_Delay_Alternative |
- N_Entry_Call_Alternative |
- N_Exception_Handler |
- N_Loop_Statement |
- N_Triggering_Alternative =>
-
+ when N_Abortable_Part
+ | N_Accept_Alternative
+ | N_Case_Statement_Alternative
+ | N_Delay_Alternative
+ | N_Entry_Call_Alternative
+ | N_Exception_Handler
+ | N_Loop_Statement
+ | N_Triggering_Alternative
+ =>
if not Is_Empty_List (Statements (N))
and then not Are_Wrapped (Statements (N))
and then Requires_Cleanup_Actions (Statements (N), False, False)
@@ -7478,13 +8998,14 @@ package body Exp_Util is
-------------------------
procedure Remove_Side_Effects
- (Exp : Node_Id;
- Name_Req : Boolean := False;
- Renaming_Req : Boolean := False;
- Variable_Ref : Boolean := False;
- Related_Id : Entity_Id := Empty;
- Is_Low_Bound : Boolean := False;
- Is_High_Bound : Boolean := False)
+ (Exp : Node_Id;
+ Name_Req : Boolean := False;
+ Renaming_Req : Boolean := False;
+ Variable_Ref : Boolean := False;
+ Related_Id : Entity_Id := Empty;
+ Is_Low_Bound : Boolean := False;
+ Is_High_Bound : Boolean := False;
+ Check_Side_Effects : Boolean := True)
is
function Build_Temporary
(Loc : Source_Ptr;
@@ -7494,12 +9015,6 @@ package body Exp_Util is
-- is present (xxx is taken from the Chars field of Related_Nod),
-- otherwise it generates an internal temporary.
- function Is_Name_Reference (N : Node_Id) return Boolean;
- -- Determine if the tree referenced by N represents a name. This is
- -- similar to Is_Object_Reference but returns true only if N can be
- -- renamed without the need for a temporary, the typical example of
- -- an object not in this category being a function call.
-
---------------------
-- Build_Temporary --
---------------------
@@ -7530,58 +9045,6 @@ package body Exp_Util is
end if;
end Build_Temporary;
- -----------------------
- -- Is_Name_Reference --
- -----------------------
-
- function Is_Name_Reference (N : Node_Id) return Boolean is
- begin
- if Is_Entity_Name (N) then
- return Present (Entity (N)) and then Is_Object (Entity (N));
- end if;
-
- case Nkind (N) is
- when N_Indexed_Component | N_Slice =>
- return
- Is_Name_Reference (Prefix (N))
- or else Is_Access_Type (Etype (Prefix (N)));
-
- -- Attributes 'Input, 'Old and 'Result produce objects
-
- when N_Attribute_Reference =>
- return
- Nam_In
- (Attribute_Name (N), Name_Input, Name_Old, Name_Result);
-
- when N_Selected_Component =>
- return
- Is_Name_Reference (Selector_Name (N))
- and then
- (Is_Name_Reference (Prefix (N))
- or else Is_Access_Type (Etype (Prefix (N))));
-
- when N_Explicit_Dereference =>
- return True;
-
- -- A view conversion of a tagged name is a name reference
-
- when N_Type_Conversion =>
- return Is_Tagged_Type (Etype (Subtype_Mark (N)))
- and then Is_Tagged_Type (Etype (Expression (N)))
- and then Is_Name_Reference (Expression (N));
-
- -- An unchecked type conversion is considered to be a name if
- -- the operand is a name (this construction arises only as a
- -- result of expansion activities).
-
- when N_Unchecked_Type_Conversion =>
- return Is_Name_Reference (Expression (N));
-
- when others =>
- return False;
- end case;
- end Is_Name_Reference;
-
-- Local variables
Loc : constant Source_Ptr := Sloc (Exp);
@@ -7606,19 +9069,30 @@ package body Exp_Util is
and (Inside_A_Generic or not Full_Analysis or not GNATprove_Mode)
then
return;
- end if;
-- Cannot generate temporaries if the invocation to remove side effects
-- was issued too early and the type of the expression is not resolved
-- (this happens because routines Duplicate_Subexpr_XX implicitly invoke
-- Remove_Side_Effects).
- if No (Exp_Type) or else Ekind (Exp_Type) = E_Access_Attribute_Type then
+ elsif No (Exp_Type)
+ or else Ekind (Exp_Type) = E_Access_Attribute_Type
+ then
+ return;
+
+ -- Nothing to do if prior expansion determined that a function call does
+ -- not require side effect removal.
+
+ elsif Nkind (Exp) = N_Function_Call
+ and then No_Side_Effect_Removal (Exp)
+ then
return;
-- No action needed for side-effect free expressions
- elsif Side_Effect_Free (Exp, Name_Req, Variable_Ref) then
+ elsif Check_Side_Effects
+ and then Side_Effect_Free (Exp, Name_Req, Variable_Ref)
+ then
return;
end if;
@@ -7629,15 +9103,22 @@ package body Exp_Util is
Scope_Suppress.Suppress := (others => True);
- -- If it is an elementary type and we need to capture the value, just
- -- make a constant. Likewise if this is not a name reference, except
- -- for a type conversion because we would enter an infinite recursion
- -- with Checks.Apply_Predicate_Check if the target type has predicates.
- -- And type conversions need a specific treatment anyway, see below.
- -- Also do it if we have a volatile reference and Name_Req is not set
- -- (see comments for Side_Effect_Free).
-
- if Is_Elementary_Type (Exp_Type)
+ -- If this is an elementary or a small not by-reference record type, and
+ -- we need to capture the value, just make a constant; this is cheap and
+ -- objects of both kinds of types can be bit aligned, so it might not be
+ -- possible to generate a reference to them. Likewise if this is not a
+ -- name reference, except for a type conversion because we would enter
+ -- an infinite recursion with Checks.Apply_Predicate_Check if the target
+ -- type has predicates (and type conversions need a specific treatment
+ -- anyway, see below). Also do it if we have a volatile reference and
+ -- Name_Req is not set (see comments for Side_Effect_Free).
+
+ if (Is_Elementary_Type (Exp_Type)
+ or else (Is_Record_Type (Exp_Type)
+ and then Known_Static_RM_Size (Exp_Type)
+ and then RM_Size (Exp_Type) <= 64
+ and then not Has_Discriminants (Exp_Type)
+ and then not Is_By_Reference_Type (Exp_Type)))
and then (Variable_Ref
or else (not Is_Name_Reference (Exp)
and then Nkind (Exp) /= N_Type_Conversion)
@@ -7722,7 +9203,30 @@ package body Exp_Util is
elsif Nkind (Exp) = N_Type_Conversion then
Remove_Side_Effects (Expression (Exp), Name_Req, Variable_Ref);
- goto Leave;
+
+ -- Generating C code the type conversion of an access to constrained
+ -- array type into an access to unconstrained array type involves
+ -- initializing a fat pointer and the expression must be free of
+ -- side effects to safely compute its bounds.
+
+ if Modify_Tree_For_C
+ and then Is_Access_Type (Etype (Exp))
+ and then Is_Array_Type (Designated_Type (Etype (Exp)))
+ and then not Is_Constrained (Designated_Type (Etype (Exp)))
+ then
+ Def_Id := Build_Temporary (Loc, 'R', Exp);
+ Set_Etype (Def_Id, Exp_Type);
+ Res := New_Occurrence_Of (Def_Id, Loc);
+
+ Insert_Action (Exp,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Object_Definition => New_Occurrence_Of (Exp_Type, Loc),
+ Constant_Present => True,
+ Expression => Relocate_Node (Exp)));
+ else
+ goto Leave;
+ end if;
-- If this is an unchecked conversion that Gigi can't handle, make
-- a copy or a use a renaming to capture the value.
@@ -7816,13 +9320,35 @@ package body Exp_Util is
else
-- An expression which is in SPARK mode is considered side effect
-- free if the resulting value is captured by a variable or a
- -- constant. Same reasoning when generating C code.
- -- Why can't we apply this test in general???
+ -- constant.
- if (GNATprove_Mode or Generate_C_Code)
+ if GNATprove_Mode
and then Nkind (Parent (Exp)) = N_Object_Declaration
then
goto Leave;
+
+ -- When generating C code we cannot consider side effect free object
+ -- declarations that have discriminants and are initialized by means
+ -- of a function call since on this target there is no secondary
+ -- stack to store the return value and the expander may generate an
+ -- extra call to the function to compute the discriminant value. In
+ -- addition, for targets that have secondary stack, the expansion of
+ -- functions with side effects involves the generation of an access
+ -- type to capture the return value stored in the secondary stack;
+ -- by contrast when generating C code such expansion generates an
+ -- internal object declaration (no access type involved) which must
+ -- be identified here to avoid entering into a never-ending loop
+ -- generating internal object declarations.
+
+ elsif Modify_Tree_For_C
+ and then Nkind (Parent (Exp)) = N_Object_Declaration
+ and then
+ (Nkind (Exp) /= N_Function_Call
+ or else not Has_Discriminants (Exp_Type)
+ or else Is_Internal_Name
+ (Chars (Defining_Identifier (Parent (Exp)))))
+ then
+ goto Leave;
end if;
-- Special processing for function calls that return a limited type.
@@ -7866,7 +9392,7 @@ package body Exp_Util is
-- When generating C code, no need for a 'reference since the
-- secondary stack is not supported.
- if GNATprove_Mode or Generate_C_Code then
+ if GNATprove_Mode or Modify_Tree_For_C then
Res := New_Occurrence_Of (Def_Id, Loc);
Ref_Type := Exp_Type;
@@ -7904,7 +9430,7 @@ package body Exp_Util is
-- Do not generate a 'reference in SPARK mode or C generation
-- since the access type is not created in the first place.
- if GNATprove_Mode or Generate_C_Code then
+ if GNATprove_Mode or Modify_Tree_For_C then
New_Exp := E;
-- Otherwise generate reference, marking the value as non-null
@@ -7935,12 +9461,39 @@ package body Exp_Util is
Set_Analyzed (E, False);
end if;
- Insert_Action (Exp,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Def_Id,
- Object_Definition => New_Occurrence_Of (Ref_Type, Loc),
- Constant_Present => True,
- Expression => New_Exp));
+ -- Generating C code of object declarations that have discriminants
+ -- and are initialized by means of a function call we propagate the
+ -- discriminants of the parent type to the internally built object.
+ -- This is needed to avoid generating an extra call to the called
+ -- function.
+
+ -- For example, if we generate here the following declaration, it
+ -- will be expanded later adding an extra call to evaluate the value
+ -- of the discriminant (needed to compute the size of the object).
+ --
+ -- type Rec (D : Integer) is ...
+ -- Obj : constant Rec := SomeFunc;
+
+ if Modify_Tree_For_C
+ and then Nkind (Parent (Exp)) = N_Object_Declaration
+ and then Has_Discriminants (Exp_Type)
+ and then Nkind (Exp) = N_Function_Call
+ then
+ Insert_Action (Exp,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Object_Definition => New_Copy_Tree
+ (Object_Definition (Parent (Exp))),
+ Constant_Present => True,
+ Expression => New_Exp));
+ else
+ Insert_Action (Exp,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Def_Id,
+ Object_Definition => New_Occurrence_Of (Ref_Type, Loc),
+ Constant_Present => True,
+ Expression => New_Exp));
+ end if;
end if;
-- Preserve the Assignment_OK flag in all copies, since at least one
@@ -7987,13 +9540,14 @@ package body Exp_Util is
begin
case Nkind (N) is
- when N_Accept_Statement |
- N_Block_Statement |
- N_Entry_Body |
- N_Package_Body |
- N_Protected_Body |
- N_Subprogram_Body |
- N_Task_Body =>
+ when N_Accept_Statement
+ | N_Block_Statement
+ | N_Entry_Body
+ | N_Package_Body
+ | N_Protected_Body
+ | N_Subprogram_Body
+ | N_Task_Body
+ =>
return
Requires_Cleanup_Actions (Declarations (N), At_Lib_Level, True)
or else
@@ -8011,7 +9565,7 @@ package body Exp_Util is
Requires_Cleanup_Actions
(Private_Declarations (N), At_Lib_Level, True);
- when others =>
+ when others =>
return False;
end case;
end Requires_Cleanup_Actions;
@@ -8078,11 +9632,19 @@ package body Exp_Util is
if Lib_Level and then Finalize_Storage_Only (Obj_Typ) then
null;
- -- Transient variables are treated separately in order to minimize
- -- the size of the generated code. See Exp_Ch7.Process_Transient_
- -- Objects.
+ -- Finalization of transient objects are treated separately in
+ -- order to handle sensitive cases. These include:
- elsif Is_Processed_Transient (Obj_Id) then
+ -- * Aggregate expansion
+ -- * If, case, and expression with actions expansion
+ -- * Transient scopes
+
+ -- If one of those contexts has marked the transient object as
+ -- ignored, do not generate finalization actions for it.
+
+ elsif Is_Finalized_Transient (Obj_Id)
+ or else Is_Ignored_Transient (Obj_Id)
+ then
null;
-- Ignored Ghost objects do not need any cleanup actions because
@@ -8102,16 +9664,21 @@ package body Exp_Util is
return False;
-- The object is of the form:
- -- Obj : Typ [:= Expr];
+ -- Obj : [constant] Typ [:= Expr];
--
- -- Do not process the incomplete view of a deferred constant. Do
- -- not consider tag-to-class-wide conversions.
+ -- Do not process tag-to-class-wide conversions because they do
+ -- not yield an object. Do not process the incomplete view of a
+ -- deferred constant. Note that an object initialized by means
+ -- of a build-in-place function call may appear as a deferred
+ -- constant after expansion activities. These kinds of objects
+ -- must be finalized.
elsif not Is_Imported (Obj_Id)
and then Needs_Finalization (Obj_Typ)
- and then not (Ekind (Obj_Id) = E_Constant
- and then not Has_Completion (Obj_Id))
and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id)
+ and then not (Ekind (Obj_Id) = E_Constant
+ and then not Has_Completion (Obj_Id)
+ and then No (BIP_Initialization_Call (Obj_Id)))
then
return True;
@@ -8133,8 +9700,8 @@ package body Exp_Util is
then
return True;
- -- Processing for "hook" objects generated for controlled
- -- transients declared inside an Expression_With_Actions.
+ -- Processing for "hook" objects generated for transient objects
+ -- declared inside an Expression_With_Actions.
elsif Is_Access_Type (Obj_Typ)
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
@@ -8282,7 +9849,7 @@ package body Exp_Util is
elsif Nkind (Decl) = N_Block_Statement
and then
- -- Handle a rare case caused by a controlled transient variable
+ -- Handle a rare case caused by a controlled transient object
-- created as part of a record init proc. The variable is wrapped
-- in a block, but the block is not associated with a transient
-- scope.
@@ -8464,7 +10031,7 @@ package body Exp_Util is
-- alignment is known to be at least the maximum alignment for the
-- target or if both alignments are known and the output type's
-- alignment is no stricter than the input's. We can use the component
- -- type alignement for an array if a type is an unpacked array type.
+ -- type alignment for an array if a type is an unpacked array type.
if Present (Alignment_Clause (Otyp)) then
Oalign := Expr_Value (Expression (Alignment_Clause (Otyp)));
@@ -8906,7 +10473,7 @@ package body Exp_Util is
-- Note on checks that could raise Constraint_Error. Strictly, if we
-- take advantage of 11.6, these checks do not count as side effects.
-- However, we would prefer to consider that they are side effects,
- -- since the backend CSE does not work very well on expressions which
+ -- since the back end CSE does not work very well on expressions which
-- can raise Constraint_Error. On the other hand if we don't consider
-- them to be side effect free, then we get some awkward expansions
-- in -gnato mode, resulting in code insertions at a point where we
@@ -8998,6 +10565,19 @@ package body Exp_Util is
and then Is_Class_Wide_Type (Typ)
then
return True;
+
+ -- Generating C the type conversion of an access to constrained array
+ -- type into an access to unconstrained array type involves initializing
+ -- a fat pointer and the expression cannot be assumed to be free of side
+ -- effects since it must referenced several times to compute its bounds.
+
+ elsif Modify_Tree_For_C
+ and then Nkind (N) = N_Type_Conversion
+ and then Is_Access_Type (Typ)
+ and then Is_Array_Type (Designated_Type (Typ))
+ and then not Is_Constrained (Designated_Type (Typ))
+ then
+ return False;
end if;
-- For other than entity names and compile time known values,
@@ -9012,17 +10592,21 @@ package body Exp_Util is
-- Is this right? what about x'first where x is a variable???
when N_Attribute_Reference =>
- return Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
- and then Attribute_Name (N) /= Name_Input
- and then (Is_Entity_Name (Prefix (N))
- or else Side_Effect_Free
- (Prefix (N), Name_Req, Variable_Ref));
+ return
+ Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
+ and then Attribute_Name (N) /= Name_Input
+ and then (Is_Entity_Name (Prefix (N))
+ or else Side_Effect_Free
+ (Prefix (N), Name_Req, Variable_Ref));
-- A binary operator is side effect free if and both operands are
-- side effect free. For this purpose binary operators include
-- membership tests and short circuit forms.
- when N_Binary_Op | N_Membership_Test | N_Short_Circuit =>
+ when N_Binary_Op
+ | N_Membership_Test
+ | N_Short_Circuit
+ =>
return Side_Effect_Free (Left_Opnd (N), Name_Req, Variable_Ref)
and then
Side_Effect_Free (Right_Opnd (N), Name_Req, Variable_Ref);
@@ -9037,9 +10621,10 @@ package body Exp_Util is
-- is side effect free and it has no actions.
when N_Expression_With_Actions =>
- return Is_Empty_List (Actions (N))
- and then
- Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
+ return
+ Is_Empty_List (Actions (N))
+ and then Side_Effect_Free
+ (Expression (N), Name_Req, Variable_Ref);
-- A call to _rep_to_pos is side effect free, since we generate
-- this pure function call ourselves. Moreover it is critically
@@ -9051,11 +10636,12 @@ package body Exp_Util is
-- All other function calls are not side effect free
when N_Function_Call =>
- return Nkind (Name (N)) = N_Identifier
- and then Is_TSS (Name (N), TSS_Rep_To_Pos)
- and then
- Side_Effect_Free
- (First (Parameter_Associations (N)), Name_Req, Variable_Ref);
+ return
+ Nkind (Name (N)) = N_Identifier
+ and then Is_TSS (Name (N), TSS_Rep_To_Pos)
+ and then Side_Effect_Free
+ (First (Parameter_Associations (N)),
+ Name_Req, Variable_Ref);
-- An IF expression is side effect free if it's of a scalar type, and
-- all its components are all side effect free (conditions and then
@@ -9064,17 +10650,19 @@ package body Exp_Util is
-- where the type involved is a string type.
when N_If_Expression =>
- return Is_Scalar_Type (Typ)
- and then
- Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref);
+ return
+ Is_Scalar_Type (Typ)
+ and then Side_Effect_Free
+ (Expressions (N), Name_Req, Variable_Ref);
-- An indexed component is side effect free if it is a side
-- effect free prefixed reference and all the indexing
-- expressions are side effect free.
when N_Indexed_Component =>
- return Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
- and then Safe_Prefixed_Reference (N);
+ return
+ Side_Effect_Free (Expressions (N), Name_Req, Variable_Ref)
+ and then Safe_Prefixed_Reference (N);
-- A type qualification is side effect free if the expression
-- is side effect free.
@@ -9099,9 +10687,9 @@ package body Exp_Util is
-- prefixed reference and the bounds are side effect free.
when N_Slice =>
- return Side_Effect_Free
- (Discrete_Range (N), Name_Req, Variable_Ref)
- and then Safe_Prefixed_Reference (N);
+ return
+ Side_Effect_Free (Discrete_Range (N), Name_Req, Variable_Ref)
+ and then Safe_Prefixed_Reference (N);
-- A type conversion is side effect free if the expression to be
-- converted is side effect free.
@@ -9119,9 +10707,10 @@ package body Exp_Util is
-- is safe and its argument is side effect free.
when N_Unchecked_Type_Conversion =>
- return Safe_Unchecked_Type_Conversion (N)
- and then
- Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
+ return
+ Safe_Unchecked_Type_Conversion (N)
+ and then Side_Effect_Free
+ (Expression (N), Name_Req, Variable_Ref);
-- An unchecked expression is side effect free if its expression
-- is side effect free.
@@ -9131,10 +10720,11 @@ package body Exp_Util is
-- A literal is side effect free
- when N_Character_Literal |
- N_Integer_Literal |
- N_Real_Literal |
- N_String_Literal =>
+ when N_Character_Literal
+ | N_Integer_Literal
+ | N_Real_Literal
+ | N_String_Literal
+ =>
return True;
-- We consider that anything else has side effects. This is a bit
@@ -9406,6 +10996,172 @@ package body Exp_Util is
end if;
end Type_May_Have_Bit_Aligned_Components;
+ -------------------------------
+ -- Update_Primitives_Mapping --
+ -------------------------------
+
+ procedure Update_Primitives_Mapping
+ (Inher_Id : Entity_Id;
+ Subp_Id : Entity_Id)
+ is
+ begin
+ Update_Primitives_Mapping_Of_Types
+ (Par_Typ => Find_Dispatching_Type (Inher_Id),
+ Deriv_Typ => Find_Dispatching_Type (Subp_Id));
+ end Update_Primitives_Mapping;
+
+ ----------------------------------------
+ -- Update_Primitives_Mapping_Of_Types --
+ ----------------------------------------
+
+ procedure Update_Primitives_Mapping_Of_Types
+ (Par_Typ : Entity_Id;
+ Deriv_Typ : Entity_Id)
+ is
+ procedure Add_Primitive (Prim : Entity_Id);
+ -- Find a primitive in the inheritance/overriding chain starting from
+ -- Prim whose dispatching type is parent type Par_Typ and add a mapping
+ -- between the result and primitive Prim.
+
+ -------------------
+ -- Add_Primitive --
+ -------------------
+
+ procedure Add_Primitive (Prim : Entity_Id) is
+ function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id;
+ -- Return the next ancestor primitive in the inheritance/overriding
+ -- chain of subprogram Subp. Return Empty if no such primitive is
+ -- available.
+
+ ------------------------
+ -- Ancestor_Primitive --
+ ------------------------
+
+ function Ancestor_Primitive (Subp : Entity_Id) return Entity_Id is
+ Inher_Prim : constant Entity_Id := Alias (Subp);
+ Over_Prim : constant Entity_Id := Overridden_Operation (Subp);
+
+ begin
+ -- The current subprogram overrides an ancestor primitive
+
+ if Present (Over_Prim) then
+ return Over_Prim;
+
+ -- The current subprogram is an internally generated alias of an
+ -- inherited ancestor primitive.
+
+ elsif Present (Inher_Prim) then
+ return Inher_Prim;
+
+ -- Otherwise the current subprogram is the root of the inheritance
+ -- or overriding chain.
+
+ else
+ return Empty;
+ end if;
+ end Ancestor_Primitive;
+
+ -- Local variables
+
+ Par_Prim : Entity_Id;
+
+ -- Start of processing for Add_Primitive
+
+ begin
+ -- Inspect both the inheritance chain through the Alias attribute and
+ -- the overriding chain through the Overridden_Operation looking for
+ -- an ancestor primitive with the appropriate dispatching type.
+
+ Par_Prim := Prim;
+ while Present (Par_Prim) loop
+ exit when Find_Dispatching_Type (Par_Prim) = Par_Typ;
+ Par_Prim := Ancestor_Primitive (Par_Prim);
+ end loop;
+
+ -- Create a mapping of the form:
+
+ -- Parent type primitive -> derived type primitive
+
+ if Present (Par_Prim) then
+ Primitives_Mapping.Set (Par_Prim, Prim);
+ end if;
+ end Add_Primitive;
+
+ -- Local variables
+
+ Deriv_Prim : Entity_Id;
+ Par_Prim : Entity_Id;
+ Par_Prims : Elist_Id;
+ Prim_Elmt : Elmt_Id;
+
+ -- Start of processing for Update_Primitives_Mapping_Of_Types
+
+ begin
+ -- Nothing to do if there are no types to work with
+
+ if No (Par_Typ) or else No (Deriv_Typ) then
+ return;
+
+ -- Nothing to do if the mapping already exists
+
+ elsif Primitives_Mapping.Get (Par_Typ) = Deriv_Typ then
+ return;
+ end if;
+
+ -- Create a mapping of the form:
+
+ -- Parent type -> Derived type
+
+ -- to prevent any subsequent attempts to produce the same relations.
+
+ Primitives_Mapping.Set (Par_Typ, Deriv_Typ);
+
+ -- Inspect the primitives of the derived type and determine whether they
+ -- relate to the primitives of the parent type. If there is a meaningful
+ -- relation, create a mapping of the form:
+
+ -- Parent type primitive -> Derived type primitive
+
+ if Present (Direct_Primitive_Operations (Deriv_Typ)) then
+ Prim_Elmt := First_Elmt (Direct_Primitive_Operations (Deriv_Typ));
+ while Present (Prim_Elmt) loop
+ Deriv_Prim := Node (Prim_Elmt);
+
+ if Is_Subprogram (Deriv_Prim)
+ and then Find_Dispatching_Type (Deriv_Prim) = Deriv_Typ
+ then
+ Add_Primitive (Deriv_Prim);
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ end if;
+
+ -- If the parent operation is an interface operation, the overriding
+ -- indicator is not present. Instead, we get from the interface
+ -- operation the primitive of the current type that implements it.
+
+ if Is_Interface (Par_Typ) then
+ Par_Prims := Collect_Primitive_Operations (Par_Typ);
+
+ if Present (Par_Prims) then
+ Prim_Elmt := First_Elmt (Par_Prims);
+
+ while Present (Prim_Elmt) loop
+ Par_Prim := Node (Prim_Elmt);
+ Deriv_Prim :=
+ Find_Primitive_Covering_Interface (Deriv_Typ, Par_Prim);
+
+ if Present (Deriv_Prim) then
+ Primitives_Mapping.Set (Par_Prim, Deriv_Prim);
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ end if;
+ end if;
+ end Update_Primitives_Mapping_Of_Types;
+
----------------------------------
-- Within_Case_Or_If_Expression --
----------------------------------
diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index 1357b3b1a9..584c2df6ba 100644
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -238,6 +238,52 @@ package Exp_Util is
-- must be a free statement. If flag Is_Allocate is set, the generated
-- routine is allocate, deallocate otherwise.
+ function Build_Abort_Undefer_Block
+ (Loc : Source_Ptr;
+ Stmts : List_Id;
+ Context : Node_Id) return Node_Id;
+ -- Wrap statements Stmts in a block where the AT END handler contains a
+ -- call to Abort_Undefer_Direct. Context is the node which prompted the
+ -- inlining of the abort undefer routine. Note that this routine does
+ -- 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);
+ -- 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.
+
+ function Build_DIC_Call
+ (Loc : Source_Ptr;
+ Obj_Id : Entity_Id;
+ Typ : Entity_Id) return Node_Id;
+ -- Build a call to the DIC procedure of type Typ with Obj_Id as the actual
+ -- parameter.
+
+ procedure Build_DIC_Procedure_Body (Typ : Entity_Id);
+ -- Create the body of the procedure which verifies the assertion expression
+ -- of pragma Default_Initial_Condition at run time.
+
+ procedure Build_DIC_Procedure_Declaration (Typ : Entity_Id);
+ -- Create the declaration of the procedure which verifies the assertion
+ -- expression of pragma Default_Initial_Condition at run time.
+
+ procedure Build_Procedure_Form (N : Node_Id);
+ -- Create a procedure declaration which emulates the behavior of a function
+ -- that returns an array type, for C-compatible generation.
+
function Build_Runtime_Call (Loc : Source_Ptr; RE : RE_Id) return Node_Id;
-- Build an N_Procedure_Call_Statement calling the given runtime entity.
-- The call has no parameters. The first argument provides the location
@@ -276,6 +322,35 @@ package Exp_Util is
-- is false, the call is for a stand-alone object, and the generated
-- function itself must do its own cleanups.
+ procedure Build_Transient_Object_Statements
+ (Obj_Decl : Node_Id;
+ Fin_Call : out Node_Id;
+ Hook_Assign : out Node_Id;
+ Hook_Clear : out Node_Id;
+ Hook_Decl : out Node_Id;
+ Ptr_Decl : out Node_Id;
+ Finalize_Obj : Boolean := True);
+ -- Subsidiary to the processing of transient objects in transient scopes,
+ -- if expressions, case expressions, expression_with_action nodes, array
+ -- aggregates, and record aggregates. Obj_Decl denotes the declaration of
+ -- the transient object. Generate the following nodes:
+ --
+ -- * Fin_Call - the call to [Deep_]Finalize which cleans up the transient
+ -- object if flag Finalize_Obj is set to True, or finalizes the hook when
+ -- the flag is False.
+ --
+ -- * Hook_Assign - the assignment statement which captures a reference to
+ -- the transient object in the hook.
+ --
+ -- * Hook_Clear - the assignment statement which resets the hook to null
+ --
+ -- * Hook_Decl - the declaration of the hook object
+ --
+ -- * Ptr_Decl - the full type declaration of the hook type
+ --
+ -- These nodes are inserted in specific places depending on the context by
+ -- the various Process_Transient_xxx routines.
+
procedure Check_Float_Op_Overflow (N : Node_Id);
-- Called where we could have a floating-point binary operator where we
-- must check for infinities if we are operating in Check_Float_Overflow
@@ -469,13 +544,6 @@ package Exp_Util is
-- Ada 2005 (AI-251): Given a type T implementing the interface Iface,
-- return the record component containing the tag of Iface.
- function Find_Primitive_Operations
- (T : Entity_Id;
- Name : Name_Id) return Node_Id;
- -- Return a reference to a primitive operation with given name. If
- -- operation is overloaded, the node carries the corresponding set
- -- of overloaded interpretations.
-
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
@@ -529,19 +597,25 @@ package Exp_Util is
-- Note: currently this function does not scan the private part, that seems
-- like a potential bug ???
+ type Force_Evaluation_Mode is (Relaxed, Strict);
+
procedure Force_Evaluation
(Exp : Node_Id;
Name_Req : Boolean := False;
Related_Id : Entity_Id := Empty;
Is_Low_Bound : Boolean := False;
- Is_High_Bound : Boolean := False);
+ Is_High_Bound : Boolean := False;
+ Mode : Force_Evaluation_Mode := Relaxed);
-- Force the evaluation of the expression right away. Similar behavior
-- to Remove_Side_Effects when Variable_Ref is set to TRUE. That is to
-- say, it removes the side effects and captures the values of the
-- variables. Remove_Side_Effects guarantees that multiple evaluations
-- of the same expression won't generate multiple side effects, whereas
-- Force_Evaluation further guarantees that all evaluations will yield
- -- the same result.
+ -- the same result. If Mode is Relaxed then calls to this subprogram have
+ -- no effect if Exp is side-effect free; if Mode is Strict and Exp is not
+ -- a static expression then no side-effect check is performed on Exp and
+ -- temporaries are unconditionally generated.
--
-- Related_Id denotes the entity of the context where Expr appears. Flags
-- Is_Low_Bound and Is_High_Bound specify whether the expression to check
@@ -864,13 +938,14 @@ package Exp_Util is
-- associated with Var, and if found, remove and return that call node.
procedure Remove_Side_Effects
- (Exp : Node_Id;
- Name_Req : Boolean := False;
- Renaming_Req : Boolean := False;
- Variable_Ref : Boolean := False;
- Related_Id : Entity_Id := Empty;
- Is_Low_Bound : Boolean := False;
- Is_High_Bound : Boolean := False);
+ (Exp : Node_Id;
+ Name_Req : Boolean := False;
+ Renaming_Req : Boolean := False;
+ Variable_Ref : Boolean := False;
+ Related_Id : Entity_Id := Empty;
+ Is_Low_Bound : Boolean := False;
+ Is_High_Bound : Boolean := False;
+ Check_Side_Effects : Boolean := True);
-- Given the node for a subexpression, this function replaces the node if
-- necessary by an equivalent subexpression that is guaranteed to be side
-- effect free. This is done by extracting any actions that could cause
@@ -883,7 +958,8 @@ package Exp_Util is
-- expression. If Variable_Ref is set to True, a variable is considered as
-- side effect (used in implementing Force_Evaluation). Note: after call to
-- Remove_Side_Effects, it is safe to call New_Copy_Tree to obtain a copy
- -- of the resulting expression.
+ -- of the resulting expression. If Check_Side_Effects is set to True then
+ -- no action is performed if Exp is known to be side-effect free.
--
-- Related_Id denotes the entity of the context where Expr appears. Flags
-- Is_Low_Bound and Is_High_Bound specify whether the expression to check
@@ -980,7 +1056,7 @@ package Exp_Util is
(L : List_Id;
Name_Req : Boolean := False;
Variable_Ref : Boolean := False) return Boolean;
- -- Determines if all elements of the list L are side effect free. Name_Req
+ -- Determines if all elements of the list L are side-effect free. Name_Req
-- and Variable_Ref are as described above.
procedure Silly_Boolean_Array_Not_Test (N : Node_Id; T : Entity_Id);
@@ -1012,6 +1088,21 @@ package Exp_Util is
-- is conservative, in that a result of False is decisive. A result of True
-- means that such a component may or may not be present.
+ procedure Update_Primitives_Mapping
+ (Inher_Id : Entity_Id;
+ Subp_Id : Entity_Id);
+ -- Map primitive operations of the parent type to the corresponding
+ -- operations of the descendant. Note that the descendant type may not be
+ -- frozen yet, so we cannot use the dispatch table directly. This is called
+ -- when elaborating a contract for a subprogram, and when freezing a type
+ -- extension to verify legality rules on inherited conditions.
+
+ procedure Update_Primitives_Mapping_Of_Types
+ (Par_Typ : Entity_Id;
+ Deriv_Typ : Entity_Id);
+ -- Map the primitive operations of parent type Par_Typ to the corresponding
+ -- primitives of derived type Deriv_Typ.
+
function Within_Case_Or_If_Expression (N : Node_Id) return Boolean;
-- Determine whether arbitrary node N is within a case or an if expression
diff --git a/gcc/ada/expander.adb b/gcc/ada/expander.adb
index 4aa20d6f41..23dd919715 100644
--- a/gcc/ada/expander.adb
+++ b/gcc/ada/expander.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -41,6 +41,7 @@ with Exp_Ch11; use Exp_Ch11;
with Exp_Ch12; use Exp_Ch12;
with Exp_Ch13; use Exp_Ch13;
with Exp_Prag; use Exp_Prag;
+with Ghost; use Ghost;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
@@ -76,7 +77,13 @@ package body Expander is
-- Expand --
------------
+ -- WARNING: This routine manages Ghost regions. Return statements must be
+ -- replaced by gotos which jump to the end of the routine and restore the
+ -- Ghost mode.
+
procedure Expand (N : Node_Id) is
+ Mode : Ghost_Mode_Type;
+
begin
-- If we were analyzing a default expression (or other spec expression)
-- the Full_Analysis flag must be off. If we are in expansion mode then
@@ -88,6 +95,11 @@ package body Expander is
and then (Full_Analysis or else not Expander_Active)
and then not (Inside_A_Generic and then Expander_Active));
+ -- Establish the Ghost mode of the context to ensure that any generated
+ -- nodes during expansion are marked as Ghost.
+
+ Set_Ghost_Mode (N, Mode);
+
-- The GNATprove_Mode flag indicates that a light expansion for formal
-- verification should be used. This expansion is never done inside
-- generics, because otherwise, this breaks the name resolution
@@ -105,7 +117,7 @@ package body Expander is
-- needed, and in general cannot be done correctly, in this mode, so
-- we are all done.
- return;
+ goto Leave;
-- There are three reasons for the Expander_Active flag to be false
@@ -140,7 +152,7 @@ package body Expander is
Pop_Scope;
end if;
- return;
+ goto Leave;
else
begin
@@ -151,7 +163,6 @@ package body Expander is
-- corresponding expand routines.
case Nkind (N) is
-
when N_Abort_Statement =>
Expand_N_Abort_Statement (N);
@@ -204,6 +215,9 @@ package body Expander is
when N_Delay_Until_Statement =>
Expand_N_Delay_Until_Statement (N);
+ when N_Delta_Aggregate =>
+ Expand_N_Delta_Aggregate (N);
+
when N_Entry_Body =>
Expand_N_Entry_Body (N);
@@ -478,12 +492,11 @@ package body Expander is
when others =>
null;
-
end case;
exception
when RE_Not_Available =>
- return;
+ goto Leave;
end;
-- Set result as analyzed and then do a possible transient wrap. The
@@ -496,21 +509,27 @@ package body Expander is
if Scope_Is_Transient and then N = Node_To_Be_Wrapped then
case Nkind (N) is
- when N_Statement_Other_Than_Procedure_Call |
- N_Procedure_Call_Statement =>
+ when N_Procedure_Call_Statement
+ | N_Statement_Other_Than_Procedure_Call
+ =>
Wrap_Transient_Statement (N);
- when N_Object_Declaration |
- N_Object_Renaming_Declaration |
- N_Subtype_Declaration =>
+ when N_Object_Declaration
+ | N_Object_Renaming_Declaration
+ | N_Subtype_Declaration
+ =>
Wrap_Transient_Declaration (N);
- when others => Wrap_Transient_Expression (N);
+ when others =>
+ Wrap_Transient_Expression (N);
end case;
end if;
Debug_A_Exit ("expanding ", N, " (done)");
end if;
+
+ <<Leave>>
+ Restore_Ghost_Mode (Mode);
end Expand;
---------------------------
diff --git a/gcc/ada/expect.c b/gcc/ada/expect.c
index 4da70180b7..a19ec56119 100644
--- a/gcc/ada/expect.c
+++ b/gcc/ada/expect.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2001-2015, AdaCore *
+ * Copyright (C) 2001-2016, AdaCore *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -388,7 +388,9 @@ __gnat_expect_poll (int *fd,
int max_fd = 0;
int ready;
int i;
+#ifdef __hpux__
int received;
+#endif
*dead_process = 0;
@@ -413,14 +415,18 @@ __gnat_expect_poll (int *fd,
if (ready > 0)
{
+#ifdef __hpux__
received = 0;
+#endif
for (i = 0; i < num_fd; i++)
{
if (FD_ISSET (fd[i], &rset))
{
is_set[i] = 1;
+#ifdef __hpux__
received = 1;
+#endif
}
else
is_set[i] = 0;
diff --git a/gcc/ada/fe.h b/gcc/ada/fe.h
index e9c37217e9..6d31ae1a56 100644
--- a/gcc/ada/fe.h
+++ b/gcc/ada/fe.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2015, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2016, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -226,6 +226,7 @@ extern Boolean Is_Others_Aggregate (Node_Id);
/* sem_aux: */
#define Ancestor_Subtype sem_aux__ancestor_subtype
+#define Constant_Value sem_aux__constant_value
#define First_Discriminant sem_aux__first_discriminant
#define First_Stored_Discriminant sem_aux__first_stored_discriminant
#define First_Subtype sem_aux__first_subtype
@@ -233,6 +234,7 @@ extern Boolean Is_Others_Aggregate (Node_Id);
#define Is_Derived_Type sem_aux__is_derived_type
extern Entity_Id Ancestor_Subtype (Entity_Id);
+extern Node_Id Constant_Value (Entity_Id);
extern Entity_Id First_Discriminant (Entity_Id);
extern Entity_Id First_Stored_Discriminant (Entity_Id);
extern Entity_Id First_Subtype (Entity_Id);
diff --git a/gcc/ada/fname.adb b/gcc/ada/fname.adb
index 0bea5a0ba1..e17aa346bd 100644
--- a/gcc/ada/fname.adb
+++ b/gcc/ada/fname.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -134,14 +134,9 @@ package body Fname is
Name_Len := Name_Len - 4;
end if;
- -- Definitely false if longer than 12 characters (8.3)
-
- if Name_Len > 8 then
- return False;
-
-- Definitely predefined if prefix is a- i- or s- followed by letter
- elsif Name_Len >= 3
+ if Name_Len >= 3
and then Name_Buffer (2) = '-'
and then (Name_Buffer (1) = 'a'
or else
@@ -153,6 +148,11 @@ package body Fname is
Name_Buffer (3) in 'A' .. 'Z')
then
return True;
+
+ -- Definitely false if longer than 12 characters (8.3)
+
+ elsif Name_Len > 8 then
+ return False;
end if;
-- Otherwise check against special list, first padding to 8 characters
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 93fd53cc37..4d8e52cee7 100644
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -23,51 +23,52 @@
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
-with Atree; use Atree;
-with Checks; use Checks;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Elists; use Elists;
-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;
-with Fname; use Fname;
-with Ghost; use Ghost;
-with Layout; use Layout;
-with Lib; use Lib;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Opt; use Opt;
-with Restrict; use Restrict;
-with Rident; use Rident;
-with Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Cat; use Sem_Cat;
-with Sem_Ch6; use Sem_Ch6;
-with Sem_Ch7; use Sem_Ch7;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Ch13; use Sem_Ch13;
-with Sem_Eval; use Sem_Eval;
-with Sem_Mech; use Sem_Mech;
-with Sem_Prag; use Sem_Prag;
-with Sem_Res; use Sem_Res;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
-with Stand; use Stand;
-with Targparm; use Targparm;
-with Tbuild; use Tbuild;
-with Ttypes; use Ttypes;
-with Uintp; use Uintp;
-with Urealp; use Urealp;
-with Warnsw; use Warnsw;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Checks; use Checks;
+with Contracts; use Contracts;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Elists; use Elists;
+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;
+with Fname; use Fname;
+with Ghost; use Ghost;
+with Layout; use Layout;
+with Lib; use Lib;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Restrict; use Restrict;
+with Rident; use Rident;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Cat; use Sem_Cat;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch7; use Sem_Ch7;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Eval; use Sem_Eval;
+with Sem_Mech; use Sem_Mech;
+with Sem_Prag; use Sem_Prag;
+with Sem_Res; use Sem_Res;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Snames; use Snames;
+with Stand; use Stand;
+with Targparm; use Targparm;
+with Tbuild; use Tbuild;
+with Ttypes; use Ttypes;
+with Uintp; use Uintp;
+with Urealp; use Urealp;
+with Warnsw; use Warnsw;
package body Freeze is
@@ -108,6 +109,14 @@ package body Freeze is
-- Comp_ADC_Present is set True if the component has a Scalar_Storage_Order
-- attribute definition clause.
+ procedure Check_Debug_Info_Needed (T : Entity_Id);
+ -- As each entity is frozen, this routine is called to deal with the
+ -- setting of Debug_Info_Needed for the entity. This flag is set if
+ -- the entity comes from source, or if we are in Debug_Generated_Code
+ -- mode or if the -gnatdV debug flag is set. However, it never sets
+ -- the flag if Debug_Info_Off is set. This procedure also ensures that
+ -- subsidiary entities have the flag set as required.
+
procedure Check_Expression_Function (N : Node_Id; Nam : Entity_Id);
-- When an expression function is frozen by a use of it, the expression
-- itself is frozen. Check that the expression does not include references
@@ -119,6 +128,11 @@ package body Freeze is
-- 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
@@ -186,14 +200,6 @@ package body Freeze is
-- the default component alignment from the scope stack values if the
-- alignment is otherwise not specified.
- procedure Check_Debug_Info_Needed (T : Entity_Id);
- -- As each entity is frozen, this routine is called to deal with the
- -- setting of Debug_Info_Needed for the entity. This flag is set if
- -- the entity comes from source, or if we are in Debug_Generated_Code
- -- mode or if the -gnatdV debug flag is set. However, it never sets
- -- the flag if Debug_Info_Off is set. This procedure also ensures that
- -- subsidiary entities have the flag set as required.
-
procedure Set_SSO_From_Default (T : Entity_Id);
-- T is a record or array type that is being frozen. If it is a base type,
-- and if SSO_Set_Low/High_By_Default is set, then Reverse_Storage order
@@ -745,9 +751,9 @@ package body Freeze is
procedure Check_Compile_Time_Size (T : Entity_Id) is
procedure Set_Small_Size (T : Entity_Id; S : Uint);
- -- Sets the compile time known size (32 bits or less) in the Esize
- -- field, of T checking for a size clause that was given which attempts
- -- to give a smaller size, and also checking for an alignment clause.
+ -- Sets the compile time known size (64 bits or less) in the RM_Size
+ -- field of T, checking for a size clause that was given which attempts
+ -- to give a smaller size.
function Size_Known (T : Entity_Id) return Boolean;
-- Recursive function that does all the work
@@ -765,7 +771,7 @@ package body Freeze is
procedure Set_Small_Size (T : Entity_Id; S : Uint) is
begin
- if S > 32 then
+ if S > 64 then
return;
-- Check for bad size clause given
@@ -800,14 +806,12 @@ package body Freeze is
if Size_Known_At_Compile_Time (T) then
return True;
- -- Always True for scalar types. This is true even for generic formal
- -- scalar types. We used to return False in the latter case, but the
- -- size is known at compile time, even in the template, we just do
- -- not know the exact size but that's not the point of this routine.
+ -- Always True for elementary types, even generic formal elementary
+ -- types. We used to return False in the latter case, but the size
+ -- is known at compile time, even in the template, we just do not
+ -- know the exact size but that's not the point of this routine.
- elsif Is_Scalar_Type (T)
- or else Is_Task_Type (T)
- then
+ elsif Is_Elementary_Type (T) or else Is_Task_Type (T) then
return True;
-- Array types
@@ -817,8 +821,8 @@ package body Freeze is
-- String literals always have known size, and we can set it
if Ekind (T) = E_String_Literal_Subtype then
- Set_Small_Size (T, Component_Size (T)
- * String_Literal_Length (T));
+ Set_Small_Size
+ (T, Component_Size (T) * String_Literal_Length (T));
return True;
-- Unconstrained types never have known at compile time size
@@ -839,10 +843,10 @@ package body Freeze is
end if;
-- Check for all indexes static, and also compute possible size
- -- (in case it is less than 32 and may be packable).
+ -- (in case it is not greater than 64 and may be packable).
declare
- Esiz : Uint := Component_Size (T);
+ Size : Uint := Component_Size (T);
Dim : Uint;
begin
@@ -869,24 +873,19 @@ package body Freeze is
Dim := Expr_Value (High) - Expr_Value (Low) + 1;
if Dim >= 0 then
- Esiz := Esiz * Dim;
+ Size := Size * Dim;
else
- Esiz := Uint_0;
+ Size := Uint_0;
end if;
end if;
Next_Index (Index);
end loop;
- Set_Small_Size (T, Esiz);
+ Set_Small_Size (T, Size);
return True;
end;
- -- Access types always have known at compile time sizes
-
- elsif Is_Access_Type (T) then
- return True;
-
-- For non-generic private types, go to underlying type if present
elsif Is_Private_Type (T)
@@ -1074,11 +1073,10 @@ package body Freeze is
if Packed_Size_Known then
- -- We can only deal with elementary types, since for
- -- non-elementary components, alignment enters into the
- -- picture, and we don't know enough to handle proper
- -- alignment in this context. Packed arrays count as
- -- elementary if the representation is a modular type.
+ -- We can deal with elementary types, small packed arrays
+ -- if the representation is a modular type and also small
+ -- record types (if the size is not greater than 64, but
+ -- the condition is checked by Set_Small_Size).
if Is_Elementary_Type (Ctyp)
or else (Is_Array_Type (Ctyp)
@@ -1086,33 +1084,14 @@ package body Freeze is
(Packed_Array_Impl_Type (Ctyp))
and then Is_Modular_Integer_Type
(Packed_Array_Impl_Type (Ctyp)))
+ or else Is_Record_Type (Ctyp)
then
- -- Packed size unknown if we have an atomic/VFA type
- -- or a by-reference type, since the back end knows
- -- how these are layed out.
-
- if Is_Atomic_Or_VFA (Ctyp)
- or else Is_By_Reference_Type (Ctyp)
- then
- Packed_Size_Known := False;
-
-- If RM_Size is known and static, then we can keep
- -- accumulating the packed size
-
- elsif Known_Static_RM_Size (Ctyp) then
+ -- accumulating the packed size.
- -- A little glitch, to be removed sometime ???
- -- gigi does not understand zero sizes yet.
+ if Known_Static_RM_Size (Ctyp) then
- if RM_Size (Ctyp) = Uint_0 then
- Packed_Size_Known := False;
-
- -- Normal case where we can keep accumulating the
- -- packed array size.
-
- else
- Packed_Size := Packed_Size + RM_Size (Ctyp);
- end if;
+ Packed_Size := Packed_Size + RM_Size (Ctyp);
-- If we have a field whose RM_Size is not known then
-- we can't figure out the packed size here.
@@ -1121,8 +1100,7 @@ package body Freeze is
Packed_Size_Known := False;
end if;
- -- If we have a non-elementary type we can't figure out
- -- the packed array size (alignment issues).
+ -- For other types we can't figure out the packed size
else
Packed_Size_Known := False;
@@ -1189,10 +1167,13 @@ package body Freeze is
ADC : Node_Id;
Comp_ADC_Present : out Boolean)
is
- Comp_Type : Entity_Id;
+ Comp_Base : Entity_Id;
Comp_ADC : Node_Id;
+ Encl_Base : Entity_Id;
Err_Node : Node_Id;
+ Component_Aliased : Boolean;
+
Comp_Byte_Aligned : Boolean;
-- Set for the record case, True if Comp starts on a byte boundary
-- (in which case it is allowed to have different storage order).
@@ -1201,14 +1182,12 @@ package body Freeze is
-- Set True when the component is a nested composite, and it does not
-- have the same scalar storage order as Encl_Type.
- Component_Aliased : Boolean;
-
begin
-- Record case
if Present (Comp) then
Err_Node := Comp;
- Comp_Type := Etype (Comp);
+ Comp_Base := Etype (Comp);
if Is_Tag (Comp) then
Comp_Byte_Aligned := True;
@@ -1233,32 +1212,42 @@ package body Freeze is
else
Err_Node := Encl_Type;
- Comp_Type := Component_Type (Encl_Type);
+ Comp_Base := Component_Type (Encl_Type);
Component_Aliased := Has_Aliased_Components (Encl_Type);
end if;
-- Note: the Reverse_Storage_Order flag is set on the base type, but
-- the attribute definition clause is attached to the first subtype.
+ -- Also, if the base type is incomplete or private, go to full view
+ -- if known
- Comp_Type := Base_Type (Comp_Type);
- Comp_ADC := Get_Attribute_Definition_Clause
- (First_Subtype (Comp_Type),
- Attribute_Scalar_Storage_Order);
+ Encl_Base := Base_Type (Encl_Type);
+ if Present (Underlying_Type (Encl_Base)) then
+ Encl_Base := Underlying_Type (Encl_Base);
+ end if;
+
+ Comp_Base := Base_Type (Comp_Base);
+ if Present (Underlying_Type (Comp_Base)) then
+ Comp_Base := Underlying_Type (Comp_Base);
+ end if;
+
+ Comp_ADC :=
+ Get_Attribute_Definition_Clause
+ (First_Subtype (Comp_Base), Attribute_Scalar_Storage_Order);
Comp_ADC_Present := Present (Comp_ADC);
-- Case of record or array component: check storage order compatibility.
-- But, if the record has Complex_Representation, then it is treated as
-- a scalar in the back end so the storage order is irrelevant.
- if (Is_Record_Type (Comp_Type)
- and then not Has_Complex_Representation (Comp_Type))
- or else Is_Array_Type (Comp_Type)
+ if (Is_Record_Type (Comp_Base)
+ and then not Has_Complex_Representation (Comp_Base))
+ or else Is_Array_Type (Comp_Base)
then
Comp_SSO_Differs :=
- Reverse_Storage_Order (Encl_Type)
- /=
- Reverse_Storage_Order (Comp_Type);
+ Reverse_Storage_Order (Encl_Base) /=
+ Reverse_Storage_Order (Comp_Base);
-- Parent and extension must have same storage order
@@ -1269,43 +1258,44 @@ package body Freeze is
& "parent", Err_Node);
end if;
- -- If enclosing composite has explicit SSO then nested composite must
- -- have explicit SSO as well.
-
- elsif Present (ADC) and then No (Comp_ADC) then
- Error_Msg_N ("nested composite must have explicit scalar "
- & "storage order", Err_Node);
-
-- If component and composite SSO differs, check that component
- -- falls on byte boundaries and isn't packed.
+ -- falls on byte boundaries and isn't bit packed.
elsif Comp_SSO_Differs then
-- Component SSO differs from enclosing composite:
- -- Reject if component is a packed array, as it may be represented
+ -- Reject if component is a bit-packed array, as it is represented
-- as a scalar internally.
- if Is_Packed_Array (Comp_Type) then
+ if Is_Bit_Packed_Array (Comp_Base) then
Error_Msg_N
- ("type of packed component must have same scalar "
- & "storage order as enclosing composite", Err_Node);
+ ("type of packed component must have same scalar storage "
+ & "order as enclosing composite", Err_Node);
- -- Reject if composite is a packed array, as it may be rewritten
+ -- Reject if composite is a bit-packed array, as it is rewritten
-- into an array of scalars.
- elsif Is_Packed_Array (Encl_Type) then
- Error_Msg_N ("type of packed array must have same scalar "
- & "storage order as component", Err_Node);
+ elsif Is_Bit_Packed_Array (Encl_Base) then
+ Error_Msg_N
+ ("type of packed array must have same scalar storage order "
+ & "as component", Err_Node);
-- Reject if not byte aligned
- elsif Is_Record_Type (Encl_Type)
- and then not Comp_Byte_Aligned
+ 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);
+
+ -- Warn if specified only for the outer composite
+
+ elsif Present (ADC) and then No (Comp_ADC) then
+ Error_Msg_NE
+ ("scalar storage order specified for & does not apply to "
+ & "component?", Err_Node, Encl_Base);
end if;
end if;
@@ -1314,8 +1304,8 @@ package body Freeze is
elsif Present (ADC) and then Component_Aliased then
Error_Msg_N
- ("aliased component not permitted for type with "
- & "explicit Scalar_Storage_Order", Err_Node);
+ ("aliased component not permitted for type with explicit "
+ & "Scalar_Storage_Order", Err_Node);
end if;
end Check_Component_Storage_Order;
@@ -1342,8 +1332,6 @@ package body Freeze is
-------------------------------
procedure Check_Expression_Function (N : Node_Id; Nam : Entity_Id) is
- Decl : Node_Id;
-
function Find_Constant (Nod : Node_Id) return Traverse_Result;
-- Function to search for deferred constant
@@ -1366,6 +1354,7 @@ package body Freeze is
N_Object_Declaration
and then not Is_Imported (Entity (Nod))
and then not Has_Completion (Entity (Nod))
+ and then not Is_Frozen (Entity (Nod))
then
Error_Msg_NE
("premature use of& in call or instance", N, Entity (Nod));
@@ -1385,6 +1374,10 @@ package body Freeze is
procedure Check_Deferred is new Traverse_Proc (Find_Constant);
+ -- Local variables
+
+ Decl : Node_Id;
+
-- Start of processing for Check_Expression_Function
begin
@@ -1397,6 +1390,96 @@ package body Freeze is
end if;
end Check_Expression_Function;
+ --------------------------------
+ -- Check_Inherited_Conditions --
+ --------------------------------
+
+ procedure Check_Inherited_Conditions (R : Entity_Id) is
+ Prim_Ops : constant Elist_Id := Primitive_Operations (R);
+ A_Post : Node_Id;
+ A_Pre : Node_Id;
+ Op_Node : Elmt_Id;
+ Par_Prim : Entity_Id;
+ Prim : Entity_Id;
+
+ begin
+ 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.
+
+ if Present (Overridden_Operation (Prim))
+ and then Comes_From_Source (Prim)
+ then
+ Update_Primitives_Mapping (Overridden_Operation (Prim), Prim);
+
+ -- In SPARK mode this is where we can collect the inherited
+ -- conditions, because we do not create the Check pragmas that
+ -- normally convey the the modified class-wide conditions on
+ -- overriding operations.
+
+ if SPARK_Mode = On then
+
+ -- Analyze the contract items of the parent operation, before
+ -- they are rewritten when inherited.
+
+ Analyze_Entry_Or_Subprogram_Contract
+ (Overridden_Operation (Prim));
+
+ -- Now verify the legality of inherited contracts for LSP
+ -- conformance.
+
+ Collect_Inherited_Class_Wide_Conditions (Prim);
+ end if;
+ end if;
+
+ Next_Elmt (Op_Node);
+ end loop;
+
+ -- In all cases, we examine inherited operations to check whether they
+ -- require a wrapper to handle inherited conditions that call other
+ -- primitives, so that LSP can be verified/enforced.
+
+ -- Wrapper construction TBD.
+
+ Op_Node := First_Elmt (Prim_Ops);
+ while Present (Op_Node) loop
+ Prim := Node (Op_Node);
+ if not Comes_From_Source (Prim) and then Present (Alias (Prim)) then
+ Par_Prim := Alias (Prim);
+
+ -- Analyze the contract items of the parent operation, before
+ -- they are rewritten when inherited.
+
+ Analyze_Entry_Or_Subprogram_Contract (Par_Prim);
+
+ A_Pre := Get_Pragma (Par_Prim, Pragma_Precondition);
+
+ if Present (A_Pre) and then Class_Present (A_Pre) then
+ Build_Class_Wide_Expression
+ (Prag => New_Copy_Tree (A_Pre),
+ Subp => Prim,
+ Par_Subp => Par_Prim,
+ Adjust_Sloc => False);
+ end if;
+
+ A_Post := Get_Pragma (Par_Prim, Pragma_Postcondition);
+
+ if Present (A_Post) and then Class_Present (A_Post) then
+ Build_Class_Wide_Expression
+ (Prag => New_Copy_Tree (A_Post),
+ Subp => Prim,
+ Par_Subp => Par_Prim,
+ Adjust_Sloc => False);
+ end if;
+ end if;
+
+ Next_Elmt (Op_Node);
+ end loop;
+ end Check_Inherited_Conditions;
+
----------------------------
-- Check_Strict_Alignment --
----------------------------
@@ -1608,9 +1691,6 @@ package body Freeze is
-- as they are generated.
procedure Freeze_All (From : Entity_Id; After : in out Node_Id) is
- E : Entity_Id;
- Decl : Node_Id;
-
procedure Freeze_All_Ent (From : Entity_Id; After : in out Node_Id);
-- This is the internal recursive routine that does freezing of entities
-- (but NOT the analysis of default expressions, which should not be
@@ -1668,9 +1748,9 @@ package body Freeze is
and then not Is_Frozen (E)
then
Push_Scope (E);
+
Install_Visible_Declarations (E);
Install_Private_Declarations (E);
-
Freeze_All (First_Entity (E), After);
End_Package_Scope (E);
@@ -1683,8 +1763,8 @@ package body Freeze is
end if;
elsif Ekind (E) in Task_Kind
- and then Nkind_In (Parent (E), N_Task_Type_Declaration,
- N_Single_Task_Declaration)
+ and then Nkind_In (Parent (E), N_Single_Task_Declaration,
+ N_Task_Type_Declaration)
then
Push_Scope (E);
Freeze_All (First_Entity (E), After);
@@ -1783,10 +1863,10 @@ package body Freeze is
-- current package, but this body does not freeze incomplete
-- types that may be declared in this private part.
- if (Nkind_In (Bod, N_Subprogram_Body,
- N_Entry_Body,
+ if (Nkind_In (Bod, N_Entry_Body,
N_Package_Body,
N_Protected_Body,
+ N_Subprogram_Body,
N_Task_Body)
or else Nkind (Bod) in N_Body_Stub)
and then
@@ -1805,6 +1885,12 @@ package body Freeze is
end loop;
end Freeze_All_Ent;
+ -- Local variables
+
+ Decl : Node_Id;
+ E : Entity_Id;
+ Item : Entity_Id;
+
-- Start of processing for Freeze_All
begin
@@ -1845,33 +1931,28 @@ package body Freeze is
elsif Nkind (Decl) = N_Subprogram_Declaration
and then Present (Corresponding_Body (Decl))
and then
- Nkind (Unit_Declaration_Node (Corresponding_Body (Decl)))
- = N_Subprogram_Renaming_Declaration
+ Nkind (Unit_Declaration_Node (Corresponding_Body (Decl))) =
+ N_Subprogram_Renaming_Declaration
then
Build_And_Analyze_Renamed_Body
(Decl, Corresponding_Body (Decl), After);
end if;
end if;
- elsif Ekind (E) in Task_Kind
- and then Nkind_In (Parent (E), N_Task_Type_Declaration,
- N_Single_Task_Declaration)
- then
- declare
- Ent : Entity_Id;
+ -- Freeze the default expressions of entries, entry families, and
+ -- protected subprograms.
- begin
- Ent := First_Entity (E);
- while Present (Ent) loop
- if Is_Entry (Ent)
- and then not Default_Expressions_Processed (Ent)
- then
- Process_Default_Expressions (Ent, After);
- end if;
+ elsif Is_Concurrent_Type (E) then
+ Item := First_Entity (E);
+ while Present (Item) loop
+ if (Is_Entry (Item) or else Is_Subprogram (Item))
+ and then not Default_Expressions_Processed (Item)
+ then
+ Process_Default_Expressions (Item, After);
+ end if;
- Next_Entity (Ent);
- end loop;
- end;
+ Next_Entity (Item);
+ end loop;
end if;
-- Historical note: We used to create a finalization master for an
@@ -1908,8 +1989,17 @@ package body Freeze is
-- Freeze_Before --
-------------------
- procedure Freeze_Before (N : Node_Id; T : Entity_Id) is
- Freeze_Nodes : constant List_Id := Freeze_Entity (T, N);
+ procedure Freeze_Before
+ (N : Node_Id;
+ T : Entity_Id;
+ Do_Freeze_Profile : Boolean := True)
+ is
+ -- Freeze T, then insert the generated Freeze nodes before the node N.
+ -- Flag Freeze_Profile is used when T is an overloadable entity, and
+ -- indicates whether its profile should be frozen at the same time.
+
+ Freeze_Nodes : constant List_Id :=
+ Freeze_Entity (T, N, Do_Freeze_Profile);
begin
if Ekind (T) = E_Function then
@@ -1925,7 +2015,15 @@ package body Freeze is
-- Freeze_Entity --
-------------------
- function Freeze_Entity (E : Entity_Id; N : Node_Id) return List_Id is
+ -- WARNING: This routine manages Ghost regions. Return statements must be
+ -- replaced by gotos which jump to the end of the routine and restore the
+ -- Ghost mode.
+
+ function Freeze_Entity
+ (E : Entity_Id;
+ N : Node_Id;
+ Do_Freeze_Profile : Boolean := True) return List_Id
+ is
Loc : constant Source_Ptr := Sloc (N);
Atype : Entity_Id;
Comp : Entity_Id;
@@ -1936,9 +2034,6 @@ package body Freeze is
Has_Default_Initialization : Boolean := False;
-- This flag gets set to true for a variable with default initialization
- Late_Freezing : Boolean := False;
- -- Used to detect attempt to freeze function declared in another unit
-
Result : List_Id := No_List;
-- List of freezing actions, left at No_List if none
@@ -1957,6 +2052,13 @@ package body Freeze is
-- which is the current instance type can only be applied when the type
-- is limited.
+ procedure Check_Suspicious_Convention (Rec_Type : Entity_Id);
+ -- Give a warning for pragma Convention with language C or C++ applied
+ -- to a discriminated record type. This is suppressed for the unchecked
+ -- union case, since the whole point in this case is interface C. We
+ -- also do not generate this within instantiations, since we will have
+ -- generated a message on the template.
+
procedure Check_Suspicious_Modulus (Utype : Entity_Id);
-- Give warning for modulus of 8, 16, 32, or 64 given as an explicit
-- integer literal without an explicit corresponding size clause. The
@@ -1975,9 +2077,8 @@ package body Freeze is
function Freeze_Profile (E : Entity_Id) return Boolean;
-- Freeze formals and return type of subprogram. If some type in the
- -- profile is a limited view, freezing of the entity will take place
- -- elsewhere, and the function returns False. This routine will be
- -- modified if and when we can implement AI05-019 efficiently ???
+ -- profile is incomplete and we are in an instance, freezing of the
+ -- entity will take place elsewhere, and the function returns False.
procedure Freeze_Record_Type (Rec : Entity_Id);
-- Freeze record type, including freezing component types, and freezing
@@ -1987,15 +2088,11 @@ package body Freeze is
-- Determine whether an arbitrary entity is subject to Boolean aspect
-- Import and its value is specified as True.
- procedure Late_Freeze_Subprogram (E : Entity_Id);
- -- Following AI05-151, a function can return a limited view of a type
- -- declared elsewhere. In that case the function cannot be frozen at
- -- the end of its enclosing package. If its first use is in a different
- -- unit, it cannot be frozen there, but if the call is legal the full
- -- view of the return type is available and the subprogram can now be
- -- frozen. However the freeze node cannot be inserted at the point of
- -- call, but rather must go in the package holding the function, so that
- -- the backend can process it in the proper context.
+ procedure Inherit_Freeze_Node
+ (Fnod : Node_Id;
+ Typ : Entity_Id);
+ -- Set type Typ's freeze node to refer to Fnode. This routine ensures
+ -- that any attributes attached to Typ's original node are preserved.
procedure Wrap_Imported_Subprogram (E : Entity_Id);
-- If E is an entity for an imported subprogram with pre/post-conditions
@@ -2160,7 +2257,8 @@ package body Freeze is
return OK;
end if;
- when others => return OK;
+ when others =>
+ return OK;
end case;
end Process;
@@ -2179,6 +2277,49 @@ package body Freeze is
end if;
end Check_Current_Instance;
+ ---------------------------------
+ -- Check_Suspicious_Convention --
+ ---------------------------------
+
+ procedure Check_Suspicious_Convention (Rec_Type : Entity_Id) is
+ begin
+ if Has_Discriminants (Rec_Type)
+ and then Is_Base_Type (Rec_Type)
+ and then not Is_Unchecked_Union (Rec_Type)
+ and then (Convention (Rec_Type) = Convention_C
+ or else
+ Convention (Rec_Type) = Convention_CPP)
+ and then Comes_From_Source (Rec_Type)
+ and then not In_Instance
+ and then not Has_Warnings_Off (Rec_Type)
+ then
+ declare
+ Cprag : constant Node_Id :=
+ Get_Rep_Pragma (Rec_Type, Name_Convention);
+ A2 : Node_Id;
+
+ begin
+ if Present (Cprag) then
+ A2 := Next (First (Pragma_Argument_Associations (Cprag)));
+
+ if Convention (Rec_Type) = Convention_C then
+ Error_Msg_N
+ ("?x?discriminated record has no direct equivalent in "
+ & "C", A2);
+ else
+ Error_Msg_N
+ ("?x?discriminated record has no direct equivalent in "
+ & "C++", A2);
+ end if;
+
+ Error_Msg_NE
+ ("\?x?use of convention for type& is dubious",
+ A2, Rec_Type);
+ end if;
+ end;
+ end if;
+ end Check_Suspicious_Convention;
+
------------------------------
-- Check_Suspicious_Modulus --
------------------------------
@@ -2304,6 +2445,26 @@ package body Freeze is
Set_Has_Unchecked_Union (Arr);
end if;
+ -- The array type requires its own invariant procedure in order to
+ -- verify the component invariant over all elements. In GNATprove
+ -- mode, the component invariants are checked by other means. They
+ -- should not be added to the array type invariant procedure, so
+ -- that the procedure can be used to check the array type
+ -- invariants if any.
+
+ if Has_Invariants (Component_Type (Arr))
+ and then not GNATprove_Mode
+ then
+ Set_Has_Own_Invariants (Arr);
+
+ -- The array type is an implementation base type. Propagate the
+ -- same property to the first subtype.
+
+ if Is_Itype (Arr) then
+ Set_Has_Own_Invariants (First_Subtype (Arr));
+ end if;
+ end if;
+
-- Warn for pragma Pack overriding foreign convention
if Has_Foreign_Convention (Ctyp)
@@ -2385,7 +2546,7 @@ package body Freeze is
end if;
end if;
- -- Case of component size that may result in packing
+ -- Case of component size that may result in bit packing
if 1 <= Csiz and then Csiz <= 64 then
declare
@@ -2450,42 +2611,55 @@ package body Freeze is
end if;
end if;
- -- Actual packing is not needed for 8, 16, 32, 64. Also
- -- not needed for 24 if alignment is 1.
-
- if Csiz = 8
- or else Csiz = 16
- or else Csiz = 32
- or else Csiz = 64
- or else (Csiz = 24 and then Alignment (Ctyp) = 1)
- then
- -- Here the array was requested to be packed, but
- -- the packing request had no effect, so Is_Packed
- -- is reset.
-
- -- Note: semantically this means that we lose track
- -- of the fact that a derived type inherited a pragma
- -- Pack that was non- effective, but that seems fine.
+ -- Bit packing is never needed for 8, 16, 32, 64
- -- We regard a Pack pragma as a request to set a
- -- representation characteristic, and this request
- -- may be ignored.
+ if Addressable (Csiz) then
- Set_Is_Packed (Base_Type (Arr), False);
- Set_Is_Bit_Packed_Array (Base_Type (Arr), False);
+ -- If the Esize of the component is known and equal to
+ -- the component size then even packing is not needed.
if Known_Static_Esize (Component_Type (Arr))
and then Esize (Component_Type (Arr)) = Csiz
then
+ -- Here the array was requested to be packed, but
+ -- the packing request had no effect whatsoever,
+ -- so flag Is_Packed is reset.
+
+ -- Note: semantically this means that we lose track
+ -- of the fact that a derived type inherited pragma
+ -- Pack that was non-effective, but that is fine.
+
+ -- We regard a Pack pragma as a request to set a
+ -- representation characteristic, and this request
+ -- may be ignored.
+
+ Set_Is_Packed (Base_Type (Arr), False);
Set_Has_Non_Standard_Rep (Base_Type (Arr), False);
+ else
+ Set_Is_Packed (Base_Type (Arr), True);
+ Set_Has_Non_Standard_Rep (Base_Type (Arr), True);
end if;
- -- In all other cases, packing is indeed needed
+ Set_Is_Bit_Packed_Array (Base_Type (Arr), False);
+
+ -- Bit packing is not needed for multiples of the storage
+ -- unit if the type is composite because the back end can
+ -- byte pack composite types.
+
+ elsif Csiz mod System_Storage_Unit = 0
+ and then Is_Composite_Type (Ctyp)
+ then
+
+ Set_Is_Packed (Base_Type (Arr), True);
+ Set_Has_Non_Standard_Rep (Base_Type (Arr), True);
+ Set_Is_Bit_Packed_Array (Base_Type (Arr), False);
+
+ -- In all other cases, bit packing is needed
else
+ Set_Is_Packed (Base_Type (Arr), True);
Set_Has_Non_Standard_Rep (Base_Type (Arr), True);
Set_Is_Bit_Packed_Array (Base_Type (Arr), True);
- Set_Is_Packed (Base_Type (Arr), True);
end if;
end;
end if;
@@ -2686,7 +2860,7 @@ package body Freeze is
if Is_Bit_Packed_Array (Arr) then
- -- Check number of elements for bit packed arrays that come from
+ -- Check number of elements for bit-packed arrays that come from
-- source and have compile time known ranges. The bit-packed
-- arrays circuitry does not support arrays with more than
-- Integer'Last + 1 elements, and when this restriction is
@@ -2768,7 +2942,7 @@ package body Freeze is
-- If any of the index types was an enumeration type with a non-
-- standard rep clause, then we indicate that the array type is
- -- always packed (even if it is not bit packed).
+ -- always packed (even if it is not bit-packed).
if Non_Standard_Enum then
Set_Has_Non_Standard_Rep (Base_Type (Arr));
@@ -2777,12 +2951,14 @@ package body Freeze is
Set_Component_Alignment_If_Not_Set (Arr);
- -- If the array is packed, we must create the packed array type to be
- -- used to actually implement the type. This is only needed for real
- -- array types (not for string literal types, since they are present
- -- only for the front end).
+ -- If the array is packed and bit-packed or packed to eliminate holes
+ -- in the non-contiguous enumeration index types, we must create the
+ -- packed array type to be used to actually implement the type. This
+ -- is only needed for real array types (not for string literal types,
+ -- since they are present only for the front end).
if Is_Packed (Arr)
+ and then (Is_Bit_Packed_Array (Arr) or else Non_Standard_Enum)
and then Ekind (Arr) /= E_String_Literal_Subtype
then
Create_Packed_Array_Impl_Type (Arr);
@@ -3285,23 +3461,15 @@ package body Freeze is
if Ekind (E) = E_Function then
- -- Check whether function is declared elsewhere.
-
- Late_Freezing :=
- Get_Source_Unit (E) /= Get_Source_Unit (N)
- and then Returns_Limited_View (E)
- and then not In_Open_Scopes (Scope (E));
-
-- Freeze return type
R_Type := Etype (E);
- -- AI05-0151: the return type may have been incomplete
- -- at the point of declaration. Replace it with the full
- -- view, unless the current type is a limited view. In
- -- that case the full view is in a different unit, and
- -- gigi finds the non-limited view after the other unit
- -- is elaborated.
+ -- AI05-0151: the return type may have been incomplete at the
+ -- point of declaration. Replace it with the full view, unless the
+ -- current type is a limited view. In that case the full view is
+ -- in a different unit, and gigi finds the non-limited view after
+ -- the other unit is elaborated.
if Ekind (R_Type) = E_Incomplete_Type
and then Present (Full_View (R_Type))
@@ -3309,24 +3477,6 @@ package body Freeze is
then
R_Type := Full_View (R_Type);
Set_Etype (E, R_Type);
-
- -- If the return type is a limited view and the non-limited
- -- view is still incomplete, the function has to be frozen at a
- -- later time. If the function is abstract there is no place at
- -- which the full view will become available, and no code to be
- -- generated for it, so mark type as frozen.
-
- elsif Ekind (R_Type) = E_Incomplete_Type
- and then From_Limited_With (R_Type)
- and then Ekind (Non_Limited_View (R_Type)) = E_Incomplete_Type
- then
- if Is_Abstract_Subprogram (E) then
- null;
- else
- Set_Is_Frozen (E, False);
- Set_Returns_Limited_View (E);
- return False;
- end if;
end if;
Freeze_And_Append (R_Type, N, Result);
@@ -3346,8 +3496,9 @@ package body Freeze is
and then not Has_Warnings_Off (E)
and then not Has_Warnings_Off (R_Type)
then
- Error_Msg_N ("?x?return type of& does not "
- & "correspond to C pointer!", E);
+ Error_Msg_N
+ ("?x?return type of& does not correspond to C pointer!",
+ E);
-- Check suspicious return of boolean
@@ -3463,8 +3614,8 @@ package body Freeze is
and then Convention (E) /= Convention_Intrinsic
- -- Assume that ASM interface knows what it is doing. This deals
- -- with unsigned.ads in the AAMP back end.
+ -- Assume that ASM interface knows what it is doing. This deals
+ -- with e.g. unsigned.ads in the AAMP back end.
and then Convention (E) /= Convention_Assembler
then
@@ -3491,39 +3642,49 @@ package body Freeze is
Junk : Boolean;
pragma Warnings (Off, Junk);
- Rec_Pushed : Boolean := False;
- -- Set True if the record type scope Rec has been pushed on the scope
- -- stack. Needed for the analysis of delayed aspects specified to the
- -- components of Rec.
+ Aliased_Component : Boolean := False;
+ -- Set True if we find at least one component which is aliased. This
+ -- is used to prevent Implicit_Packing of the record, since packing
+ -- cannot modify the size of alignment of an aliased component.
- SSO_ADC : Node_Id;
- -- Scalar_Storage_Order attribute definition clause for the record
+ All_Elem_Components : Boolean := True;
+ -- Set False if we encounter a component of a composite type
- Unplaced_Component : Boolean := False;
- -- Set True if we find at least one component with no component
- -- clause (used to warn about useless Pack pragmas).
+ All_Sized_Components : Boolean := True;
+ -- Set False if we encounter a component with unknown RM_Size
+
+ All_Storage_Unit_Components : Boolean := True;
+ -- Set False if we encounter a component of a composite type whose
+ -- RM_Size is not a multiple of the storage unit.
+
+ Elem_Component_Total_Esize : Uint := Uint_0;
+ -- Accumulates total Esize values of all elementary components. Used
+ -- for processing of Implicit_Packing.
Placed_Component : Boolean := False;
-- Set True if we find at least one component with a component
-- clause (used to warn about useless Bit_Order pragmas, and also
-- to detect cases where Implicit_Packing may have an effect).
- Aliased_Component : Boolean := False;
- -- Set True if we find at least one component which is aliased. This
- -- is used to prevent Implicit_Packing of the record, since packing
- -- cannot modify the size of alignment of an aliased component.
+ Rec_Pushed : Boolean := False;
+ -- Set True if the record type scope Rec has been pushed on the scope
+ -- stack. Needed for the analysis of delayed aspects specified to the
+ -- components of Rec.
+
+ Sized_Component_Total_RM_Size : Uint := Uint_0;
+ -- Accumulates total RM_Size values of all sized components. Used
+ -- for processing of Implicit_Packing.
+
+ SSO_ADC : Node_Id;
+ -- Scalar_Storage_Order attribute definition clause for the record
SSO_ADC_Component : Boolean := False;
-- Set True if we find at least one component whose type has a
-- Scalar_Storage_Order attribute definition clause.
- All_Scalar_Components : Boolean := True;
- -- Set False if we encounter a component of a non-scalar type
-
- Scalar_Component_Total_RM_Size : Uint := Uint_0;
- Scalar_Component_Total_Esize : Uint := Uint_0;
- -- Accumulates total RM_Size values and total Esize values of all
- -- scalar components. Used for processing of Implicit_Packing.
+ Unplaced_Component : Boolean := False;
+ -- Set True if we find at least one component with no component
+ -- clause (used to warn about useless Pack pragmas).
function Check_Allocator (N : Node_Id) return Node_Id;
-- If N is an allocator, possibly wrapped in one or more level of
@@ -3818,13 +3979,22 @@ package body Freeze is
-- this stage we might be dealing with a real component, or with
-- an implicit subtype declaration.
- if not Is_Scalar_Type (Etype (Comp)) then
- All_Scalar_Components := False;
+ if Known_Static_RM_Size (Etype (Comp)) then
+ Sized_Component_Total_RM_Size :=
+ Sized_Component_Total_RM_Size + RM_Size (Etype (Comp));
+
+ if Is_Elementary_Type (Etype (Comp)) then
+ Elem_Component_Total_Esize :=
+ Elem_Component_Total_Esize + Esize (Etype (Comp));
+ else
+ All_Elem_Components := False;
+
+ if RM_Size (Etype (Comp)) mod System_Storage_Unit /= 0 then
+ All_Storage_Unit_Components := False;
+ end if;
+ end if;
else
- Scalar_Component_Total_RM_Size :=
- Scalar_Component_Total_RM_Size + RM_Size (Etype (Comp));
- Scalar_Component_Total_Esize :=
- Scalar_Component_Total_Esize + Esize (Etype (Comp));
+ All_Sized_Components := False;
end if;
-- If the component is an Itype with Delayed_Freeze and is either
@@ -4094,10 +4264,14 @@ package body Freeze is
("\??since no component clauses were specified", ADC);
-- Here is where we do the processing to adjust component clauses
- -- for reversed bit order, when not using reverse SSO.
+ -- for reversed bit order, when not using reverse SSO. If an error
+ -- has been reported on Rec already (such as SSO incompatible with
+ -- bit order), don't bother adjusting as this may generate extra
+ -- noise.
elsif Reverse_Bit_Order (Rec)
and then not Reverse_Storage_Order (Rec)
+ and then not Error_Posted (Rec)
then
Adjust_Record_For_Reverse_Bit_Order (Rec);
@@ -4171,7 +4345,8 @@ package body Freeze is
Freeze_And_Append (Corresponding_Remote_Type (Rec), N, Result);
end if;
- -- Check for controlled components and unchecked unions.
+ -- Check for controlled components, unchecked unions, and type
+ -- invariants.
Comp := First_Component (Rec);
while Present (Comp) loop
@@ -4200,6 +4375,22 @@ package body Freeze is
Set_Has_Unchecked_Union (Rec);
end if;
+ -- The record type requires its own invariant procedure in
+ -- order to verify the invariant of each individual component.
+ -- Do not consider internal components such as _parent because
+ -- parent class-wide invariants are always inherited.
+ -- In GNATprove mode, the component invariants are checked by
+ -- other means. They should not be added to the record type
+ -- invariant procedure, so that the procedure can be used to
+ -- check the recordy type invariants if any.
+
+ if Comes_From_Source (Comp)
+ and then Has_Invariants (Etype (Comp))
+ and then not GNATprove_Mode
+ then
+ Set_Has_Own_Invariants (Rec);
+ end if;
+
-- Scan component declaration for likely misuses of current
-- instance, either in a constraint or a default expression.
@@ -4223,7 +4414,7 @@ package body Freeze is
-- component clauses, where we must check the size. This is not done
-- till the freeze point since for fixed-point types, we do not know
-- the size until the type is frozen. Similar processing applies to
- -- bit packed arrays.
+ -- bit-packed arrays.
if Is_First_Subtype (Rec) then
Comp := First_Component (Rec);
@@ -4243,46 +4434,6 @@ package body Freeze is
end loop;
end if;
- -- Generate warning for applying C or C++ convention to a record
- -- with discriminants. This is suppressed for the unchecked union
- -- case, since the whole point in this case is interface C. We also
- -- do not generate this within instantiations, since we will have
- -- generated a message on the template.
-
- if Has_Discriminants (E)
- and then not Is_Unchecked_Union (E)
- and then (Convention (E) = Convention_C
- or else
- Convention (E) = Convention_CPP)
- and then Comes_From_Source (E)
- and then not In_Instance
- and then not Has_Warnings_Off (E)
- and then not Has_Warnings_Off (Base_Type (E))
- then
- declare
- Cprag : constant Node_Id := Get_Rep_Pragma (E, Name_Convention);
- A2 : Node_Id;
-
- begin
- if Present (Cprag) then
- A2 := Next (First (Pragma_Argument_Associations (Cprag)));
-
- if Convention (E) = Convention_C then
- Error_Msg_N
- ("?x?variant record has no direct equivalent in C",
- A2);
- else
- Error_Msg_N
- ("?x?variant record has no direct equivalent in C++",
- A2);
- end if;
-
- Error_Msg_NE
- ("\?x?use of convention for type& is dubious", A2, E);
- end if;
- end;
- end if;
-
-- See if Size is too small as is (and implicit packing might help)
if not Is_Packed (Rec)
@@ -4295,26 +4446,35 @@ package body Freeze is
and then not Aliased_Component
- -- Must have size clause and all scalar components
+ -- Must have size clause and all sized components
and then Has_Size_Clause (Rec)
- and then All_Scalar_Components
+ and then All_Sized_Components
-- Do not try implicit packing on records with discriminants, too
-- complicated, especially in the variant record case.
and then not Has_Discriminants (Rec)
- -- We can implicitly pack if the specified size of the record is
- -- less than the sum of the object sizes (no point in packing if
- -- this is not the case).
+ -- We want to implicitly pack if the specified size of the record
+ -- is less than the sum of the object sizes (no point in packing
+ -- if this is not the case), if we can compute it, i.e. if we have
+ -- only elementary components. Otherwise, we have at least one
+ -- composite component and we want to implicitly pack only if bit
+ -- packing is required for it, as we are sure in this case that
+ -- the back end cannot do the expected layout without packing.
- and then RM_Size (Rec) < Scalar_Component_Total_Esize
+ and then
+ ((All_Elem_Components
+ and then RM_Size (Rec) < Elem_Component_Total_Esize)
+ or else
+ (not All_Elem_Components
+ and then not All_Storage_Unit_Components))
-- And the total RM size cannot be greater than the specified size
-- since otherwise packing will not get us where we have to be.
- and then RM_Size (Rec) >= Scalar_Component_Total_RM_Size
+ and then RM_Size (Rec) >= Sized_Component_Total_RM_Size
-- Never do implicit packing in CodePeer or SPARK modes since
-- we don't do any packing in these modes, since this generates
@@ -4535,6 +4695,13 @@ package body Freeze is
end loop;
end;
end if;
+
+ -- For a derived tagged type, check whether inherited primitives
+ -- might require a wrapper to handle class-wide conditions.
+
+ if Is_Tagged_Type (Rec) and then Is_Derived_Type (Rec) then
+ Check_Inherited_Conditions (Rec);
+ end if;
end Freeze_Record_Type;
-------------------------------
@@ -4570,24 +4737,59 @@ package body Freeze is
return False;
end Has_Boolean_Aspect_Import;
- ----------------------------
- -- Late_Freeze_Subprogram --
- ----------------------------
+ -------------------------
+ -- Inherit_Freeze_Node --
+ -------------------------
- procedure Late_Freeze_Subprogram (E : Entity_Id) is
- Spec : constant Node_Id :=
- Specification (Unit_Declaration_Node (Scope (E)));
- Decls : List_Id;
+ procedure Inherit_Freeze_Node
+ (Fnod : Node_Id;
+ Typ : Entity_Id)
+ is
+ Typ_Fnod : constant Node_Id := Freeze_Node (Typ);
begin
- if Present (Private_Declarations (Spec)) then
- Decls := Private_Declarations (Spec);
- else
- Decls := Visible_Declarations (Spec);
- end if;
+ Set_Freeze_Node (Typ, Fnod);
+ Set_Entity (Fnod, Typ);
+
+ -- The input type had an existing node. Propagate relevant attributes
+ -- from the old freeze node to the inherited freeze node.
+
+ -- ??? if both freeze nodes have attributes, would they differ?
+
+ if Present (Typ_Fnod) then
- Append_List (Result, Decls);
- end Late_Freeze_Subprogram;
+ -- Attribute Access_Types_To_Process
+
+ if Present (Access_Types_To_Process (Typ_Fnod))
+ and then No (Access_Types_To_Process (Fnod))
+ then
+ Set_Access_Types_To_Process (Fnod,
+ Access_Types_To_Process (Typ_Fnod));
+ end if;
+
+ -- Attribute Actions
+
+ if Present (Actions (Typ_Fnod)) and then No (Actions (Fnod)) then
+ Set_Actions (Fnod, Actions (Typ_Fnod));
+ end if;
+
+ -- Attribute First_Subtype_Link
+
+ if Present (First_Subtype_Link (Typ_Fnod))
+ and then No (First_Subtype_Link (Fnod))
+ then
+ Set_First_Subtype_Link (Fnod, First_Subtype_Link (Typ_Fnod));
+ end if;
+
+ -- Attribute TSS_Elist
+
+ if Present (TSS_Elist (Typ_Fnod))
+ and then No (TSS_Elist (Fnod))
+ then
+ Set_TSS_Elist (Fnod, TSS_Elist (Typ_Fnod));
+ end if;
+ end if;
+ end Inherit_Freeze_Node;
------------------------------
-- Wrap_Imported_Subprogram --
@@ -4625,14 +4827,65 @@ package body Freeze is
-- for the subprogram body that calls the inner procedure.
procedure Wrap_Imported_Subprogram (E : Entity_Id) is
+ function Copy_Import_Pragma return Node_Id;
+ -- Obtain a copy of the Import_Pragma which belongs to subprogram E
+
+ ------------------------
+ -- Copy_Import_Pragma --
+ ------------------------
+
+ function Copy_Import_Pragma return Node_Id is
+
+ -- The subprogram should have an import pragma, otherwise it does
+ -- need a wrapper.
+
+ Prag : constant Node_Id := Import_Pragma (E);
+ pragma Assert (Present (Prag));
+
+ -- Save all semantic fields of the pragma
+
+ Save_Asp : constant Node_Id := Corresponding_Aspect (Prag);
+ Save_From : constant Boolean := From_Aspect_Specification (Prag);
+ Save_Prag : constant Node_Id := Next_Pragma (Prag);
+ Save_Rep : constant Node_Id := Next_Rep_Item (Prag);
+
+ Result : Node_Id;
+
+ begin
+ -- Reset all semantic fields. This avoids a potential infinite
+ -- loop when the pragma comes from an aspect as the duplication
+ -- will copy the aspect, then copy the corresponding pragma and
+ -- so on.
+
+ Set_Corresponding_Aspect (Prag, Empty);
+ Set_From_Aspect_Specification (Prag, False);
+ Set_Next_Pragma (Prag, Empty);
+ Set_Next_Rep_Item (Prag, Empty);
+
+ Result := Copy_Separate_Tree (Prag);
+
+ -- Restore the original semantic fields
+
+ Set_Corresponding_Aspect (Prag, Save_Asp);
+ Set_From_Aspect_Specification (Prag, Save_From);
+ Set_Next_Pragma (Prag, Save_Prag);
+ Set_Next_Rep_Item (Prag, Save_Rep);
+
+ return Result;
+ end Copy_Import_Pragma;
+
+ -- Local variables
+
Loc : constant Source_Ptr := Sloc (E);
CE : constant Name_Id := Chars (E);
- Spec : Node_Id;
- Parms : List_Id;
- Stmt : Node_Id;
- Iprag : Node_Id;
Bod : Node_Id;
Forml : Entity_Id;
+ Parms : List_Id;
+ Prag : Node_Id;
+ Spec : Node_Id;
+ Stmt : Node_Id;
+
+ -- Start of processing for Wrap_Imported_Subprogram
begin
-- Nothing to do if not imported
@@ -4655,18 +4908,14 @@ package body Freeze is
-- generates the right visibility, and that is exactly what the
-- calls to Copy_Separate_Tree give us.
- -- Acquire copy of Inline pragma, and indicate that it does not
- -- come from an aspect, as it applies to an internal entity.
-
- Iprag := Copy_Separate_Tree (Import_Pragma (E));
- Set_From_Aspect_Specification (Iprag, False);
+ Prag := Copy_Import_Pragma;
-- Fix up spec to be not imported any more
- Set_Is_Imported (E, False);
- Set_Interface_Name (E, Empty);
Set_Has_Completion (E, False);
Set_Import_Pragma (E, Empty);
+ Set_Interface_Name (E, Empty);
+ Set_Is_Imported (E, False);
-- Grab the subprogram declaration and specification
@@ -4706,13 +4955,12 @@ package body Freeze is
Copy_Separate_Tree (Spec),
Declarations => New_List (
Make_Subprogram_Declaration (Loc,
- Specification =>
- Copy_Separate_Tree (Spec)),
- Iprag),
+ Specification => Copy_Separate_Tree (Spec)),
+ Prag),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Stmt),
- End_Label => Make_Identifier (Loc, CE)));
+ Statements => New_List (Stmt),
+ End_Label => Make_Identifier (Loc, CE)));
-- Append the body to freeze result
@@ -4734,7 +4982,7 @@ package body Freeze is
-- Local variables
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
+ Mode : Ghost_Mode_Type;
-- Start of processing for Freeze_Entity
@@ -4743,7 +4991,7 @@ package body Freeze is
-- now to ensure that any nodes generated during freezing are properly
-- flagged as Ghost.
- Set_Ghost_Mode_From_Entity (E);
+ Set_Ghost_Mode (E, Mode);
-- We are going to test for various reasons why this entity need not be
-- frozen here, but in the case of an Itype that's defined within a
@@ -4760,8 +5008,12 @@ package body Freeze is
-- Do not freeze if already frozen since we only need one freeze node
if Is_Frozen (E) then
- Ghost_Mode := Save_Ghost_Mode;
- return No_List;
+ Result := No_List;
+ goto Leave;
+
+ elsif Ekind (E) = E_Generic_Package then
+ Result := Freeze_Generic_Entities (E);
+ goto Leave;
-- It is improper to freeze an external entity within a generic because
-- its freeze node will appear in a non-valid context. The entity will
@@ -4775,8 +5027,8 @@ package body Freeze is
Analyze_Aspects_At_Freeze_Point (E);
end if;
- Ghost_Mode := Save_Ghost_Mode;
- return No_List;
+ Result := No_List;
+ goto Leave;
-- AI05-0213: A formal incomplete type does not freeze the actual. In
-- the instance, the same applies to the subtype renaming the actual.
@@ -4786,20 +5038,20 @@ package body Freeze is
and then No (Full_View (Base_Type (E)))
and then Ada_Version >= Ada_2012
then
- Ghost_Mode := Save_Ghost_Mode;
- return No_List;
+ Result := No_List;
+ goto Leave;
-- Formal subprograms are never frozen
elsif Is_Formal_Subprogram (E) then
- Ghost_Mode := Save_Ghost_Mode;
- return No_List;
+ Result := No_List;
+ goto Leave;
-- Generic types are never frozen as they lack delayed semantic checks
elsif Is_Generic_Type (E) then
- Ghost_Mode := Save_Ghost_Mode;
- return No_List;
+ Result := No_List;
+ goto Leave;
-- Do not freeze a global entity within an inner scope created during
-- expansion. A call to subprogram E within some internal procedure
@@ -4832,8 +5084,8 @@ package body Freeze is
then
exit;
else
- Ghost_Mode := Save_Ghost_Mode;
- return No_List;
+ Result := No_List;
+ goto Leave;
end if;
end if;
@@ -4868,16 +5120,10 @@ package body Freeze is
end loop;
if No (S) then
- Ghost_Mode := Save_Ghost_Mode;
- return No_List;
+ Result := No_List;
+ goto Leave;
end if;
end;
-
- elsif Ekind (E) = E_Generic_Package then
- Result := Freeze_Generic_Entities (E);
-
- Ghost_Mode := Save_Ghost_Mode;
- return Result;
end if;
-- Add checks to detect proper initialization of scalars that may appear
@@ -4950,17 +5196,17 @@ package body Freeze is
-- any extra formal parameters are created since we now know
-- whether the subprogram will use a foreign convention.
- -- In Ada 2012, freezing a subprogram does not always freeze
- -- the corresponding profile (see AI05-019). An attribute
- -- reference is not a freezing point of the profile.
+ -- In Ada 2012, freezing a subprogram does not always freeze the
+ -- corresponding profile (see AI05-019). An attribute reference
+ -- is not a freezing point of the profile. Flag Do_Freeze_Profile
+ -- indicates whether the profile should be frozen now.
-- Other constructs that should not freeze ???
-- This processing doesn't apply to internal entities (see below)
- if not Is_Internal (E) then
+ if not Is_Internal (E) and then Do_Freeze_Profile then
if not Freeze_Profile (E) then
- Ghost_Mode := Save_Ghost_Mode;
- return Result;
+ goto Leave;
end if;
end if;
@@ -4982,12 +5228,6 @@ package body Freeze is
Freeze_Subprogram (E);
end if;
- if Late_Freezing then
- Late_Freeze_Subprogram (E);
- Ghost_Mode := Save_Ghost_Mode;
- return No_List;
- end if;
-
-- If warning on suspicious contracts then check for the case of
-- a postcondition other than False for a No_Return subprogram.
@@ -5001,9 +5241,10 @@ package body Freeze is
begin
while Present (Prag) loop
- if Nam_In (Pragma_Name (Prag), Name_Post,
- Name_Postcondition,
- Name_Refined_Post)
+ if Nam_In (Pragma_Name_Unmapped (Prag),
+ Name_Post,
+ Name_Postcondition,
+ Name_Refined_Post)
then
Exp :=
Expression
@@ -5140,6 +5381,9 @@ package body Freeze is
-- trigger the analysis of aspect expressions, so in this case we
-- want to continue the freezing process.
+ -- Is_Generic_Unit (Scope (E)) is dubious here, do we want instead
+ -- In_Generic_Scope (E)???
+
if Present (Scope (E))
and then Is_Generic_Unit (Scope (E))
and then
@@ -5147,8 +5391,8 @@ package body Freeze is
and then not Has_Delayed_Freeze (E))
then
Check_Compile_Time_Size (E);
- Ghost_Mode := Save_Ghost_Mode;
- return No_List;
+ Result := No_List;
+ goto Leave;
end if;
-- Check for error of Type_Invariant'Class applied to an untagged
@@ -5162,8 +5406,7 @@ package body Freeze is
and then not Is_Tagged_Type (E)
then
Error_Msg_NE
- ("Type_Invariant''Class cannot be specified for &",
- Prag, E);
+ ("Type_Invariant''Class cannot be specified for &", Prag, E);
Error_Msg_N
("\can only be specified for a tagged type", Prag);
end if;
@@ -5177,7 +5420,7 @@ package body Freeze is
if Is_Concurrent_Type (E) then
Error_Msg_N ("ghost type & cannot be concurrent", E);
- -- A Ghost type cannot be effectively volatile (SPARK RM 6.9(8))
+ -- A Ghost type cannot be effectively volatile (SPARK RM 6.9(7))
elsif Is_Effectively_Volatile (E) then
Error_Msg_N ("ghost type & cannot be volatile", E);
@@ -5188,20 +5431,20 @@ package body Freeze is
if E /= Base_Type (E) then
- -- Before we do anything else, a specialized test for the case of
- -- a size given for an array where the array needs to be packed,
- -- but was not so the size cannot be honored. This is the case
- -- where implicit packing may apply. The reason we do this so
- -- early is that if we have implicit packing, the layout of the
- -- base type is affected, so we must do this before we freeze
- -- the base type.
+ -- Before we do anything else, a specific test for the case of a
+ -- size given for an array where the array would need to be packed
+ -- in order for the size to be honored, but is not. This is the
+ -- case where implicit packing may apply. The reason we do this so
+ -- early is that, if we have implicit packing, the layout of the
+ -- base type is affected, so we must do this before we freeze the
+ -- base type.
-- We could do this processing only if implicit packing is enabled
-- since in all other cases, the error would be caught by the back
-- end. However, we choose to do the check even if we do not have
-- implicit packing enabled, since this allows us to give a more
- -- useful error message (advising use of pragmas Implicit_Packing
- -- or Pack).
+ -- useful error message (advising use of pragma Implicit_Packing
+ -- or pragma Pack).
if Is_Array_Type (E) then
declare
@@ -5214,7 +5457,8 @@ package body Freeze is
Hi : Node_Id;
Indx : Node_Id;
- Num_Elmts : Uint;
+ Dim : Uint;
+ Num_Elmts : Uint := Uint_1;
-- Number of elements in array
begin
@@ -5230,13 +5474,21 @@ package body Freeze is
-- a chance to freeze the base type (and it is that freeze
-- action that causes stuff to be inherited).
+ -- The conditions on the size are identical to those used in
+ -- Freeze_Array_Type to set the Is_Packed flag.
+
if Has_Size_Clause (E)
and then Known_Static_RM_Size (E)
and then not Is_Packed (E)
and then not Has_Pragma_Pack (E)
and then not Has_Component_Size_Clause (E)
and then Known_Static_RM_Size (Ctyp)
- and then RM_Size (Ctyp) < 64
+ and then Rsiz <= 64
+ and then not (Addressable (Rsiz)
+ and then Known_Static_Esize (Ctyp)
+ and then Esize (Ctyp) = Rsiz)
+ and then not (Rsiz mod System_Storage_Unit = 0
+ and then Is_Composite_Type (Ctyp))
and then not Is_Limited_Composite (E)
and then not Is_Packed (Root_Type (E))
and then not Has_Component_Size_Clause (Root_Type (E))
@@ -5244,7 +5496,6 @@ package body Freeze is
then
-- Compute number of elements in array
- Num_Elmts := Uint_1;
Indx := First_Index (E);
while Present (Indx) loop
Get_Index_Bounds (Indx, Lo, Hi);
@@ -5256,57 +5507,39 @@ package body Freeze is
goto No_Implicit_Packing;
end if;
- Num_Elmts :=
- Num_Elmts *
- UI_Max (Uint_0,
- Expr_Value (Hi) - Expr_Value (Lo) + 1);
+ Dim := Expr_Value (Hi) - Expr_Value (Lo) + 1;
+
+ if Dim >= 0 then
+ Num_Elmts := Num_Elmts * Dim;
+ else
+ Num_Elmts := Uint_0;
+ end if;
+
Next_Index (Indx);
end loop;
-- What we are looking for here is the situation where
-- the RM_Size given would be exactly right if there was
- -- a pragma Pack (resulting in the component size being
- -- the same as the RM_Size). Furthermore, the component
- -- type size must be an odd size (not a multiple of
- -- storage unit). If the component RM size is an exact
- -- number of storage units that is a power of two, the
- -- array is not packed and has a standard representation.
-
- if RM_Size (E) = Num_Elmts * Rsiz
- and then Rsiz mod System_Storage_Unit /= 0
- then
+ -- a pragma Pack, resulting in the component size being
+ -- the RM_Size of the component type.
+
+ if RM_Size (E) = Num_Elmts * Rsiz then
+
-- For implicit packing mode, just set the component
- -- size silently.
+ -- size and Freeze_Array_Type will do the rest.
if Implicit_Packing then
- Set_Component_Size (Btyp, Rsiz);
- Set_Is_Bit_Packed_Array (Btyp);
- Set_Is_Packed (Btyp);
- Set_Has_Non_Standard_Rep (Btyp);
+ Set_Component_Size (Btyp, Rsiz);
- -- Otherwise give an error message
+ -- Otherwise give an error message
else
Error_Msg_NE
("size given for& too small", SZ, E);
Error_Msg_N -- CODEFIX
- ("\use explicit pragma Pack "
- & "or use pragma Implicit_Packing", SZ);
+ ("\use explicit pragma Pack or use pragma "
+ & "Implicit_Packing", SZ);
end if;
-
- elsif RM_Size (E) = Num_Elmts * Rsiz
- and then Implicit_Packing
- and then
- (Rsiz / System_Storage_Unit = 1
- or else
- Rsiz / System_Storage_Unit = 2
- or else
- Rsiz / System_Storage_Unit = 4)
- then
- -- Not a packed array, but indicate the desired
- -- component size, for the back-end.
-
- Set_Component_Size (Btyp, Rsiz);
end if;
end if;
end;
@@ -5429,8 +5662,7 @@ package body Freeze is
if not Is_Frozen (Root_Type (E)) then
Set_Is_Frozen (E, False);
- Ghost_Mode := Save_Ghost_Mode;
- return Result;
+ goto Leave;
end if;
-- The equivalent type associated with a class-wide subtype needs
@@ -5477,11 +5709,17 @@ package body Freeze is
-- for the case of a private type with record extension (we will do
-- that later when the full type is frozen).
- elsif Ekind_In (E, E_Record_Type, E_Record_Subtype)
- and then not (Present (Scope (E))
- and then Is_Generic_Unit (Scope (E)))
- then
- Freeze_Record_Type (E);
+ elsif Ekind_In (E, E_Record_Type, E_Record_Subtype) then
+ if not In_Generic_Scope (E) then
+ Freeze_Record_Type (E);
+ end if;
+
+ -- Report a warning if a discriminated record base type has a
+ -- convention with language C or C++ applied to it. This check is
+ -- done even within generic scopes (but not in instantiations),
+ -- which is why we don't do it as part of Freeze_Record_Type.
+
+ Check_Suspicious_Convention (E);
-- For a concurrent type, freeze corresponding record type. This does
-- not correspond to any specific rule in the RM, but the record type
@@ -5565,8 +5803,7 @@ package body Freeze is
and then not Present (Full_View (E))
then
Set_Is_Frozen (E, False);
- Ghost_Mode := Save_Ghost_Mode;
- return Result;
+ goto Leave;
-- Case of full view present
@@ -5604,9 +5841,9 @@ package body Freeze is
F_Node := Freeze_Node (Full);
if Present (F_Node) then
- Set_Freeze_Node (Full_View (E), F_Node);
- Set_Entity (F_Node, Full_View (E));
-
+ Inherit_Freeze_Node
+ (Fnod => F_Node,
+ Typ => Full_View (E));
else
Set_Has_Delayed_Freeze (Full_View (E), False);
Set_Freeze_Node (Full_View (E), Empty);
@@ -5617,9 +5854,9 @@ package body Freeze is
F_Node := Freeze_Node (Full_View (E));
if Present (F_Node) then
- Set_Freeze_Node (E, F_Node);
- Set_Entity (F_Node, E);
-
+ Inherit_Freeze_Node
+ (Fnod => F_Node,
+ Typ => E);
else
-- {Incomplete,Private}_Subtypes with Full_Views
-- constrained by discriminants.
@@ -5657,8 +5894,7 @@ package body Freeze is
Set_RM_Size (E, RM_Size (Full_View (E)));
end if;
- Ghost_Mode := Save_Ghost_Mode;
- return Result;
+ goto Leave;
-- Case of underlying full view present
@@ -5676,9 +5912,9 @@ package body Freeze is
F_Node := Freeze_Node (Underlying_Full_View (E));
if Present (F_Node) then
- Set_Freeze_Node (E, F_Node);
- Set_Entity (F_Node, E);
-
+ Inherit_Freeze_Node
+ (Fnod => F_Node,
+ Typ => E);
else
Set_Has_Delayed_Freeze (E, False);
Set_Freeze_Node (E, Empty);
@@ -5687,8 +5923,7 @@ package body Freeze is
Check_Debug_Info_Needed (E);
- Ghost_Mode := Save_Ghost_Mode;
- return Result;
+ goto Leave;
-- Case of no full view present. If entity is derived or subtype,
-- it is safe to freeze, correctness depends on the frozen status
@@ -5701,8 +5936,8 @@ package body Freeze is
else
Set_Is_Frozen (E, False);
- Ghost_Mode := Save_Ghost_Mode;
- return No_List;
+ Result := No_List;
+ goto Leave;
end if;
-- For access subprogram, freeze types of all formals, the return
@@ -5749,8 +5984,7 @@ package body Freeze is
-- generic processing), so we never need freeze nodes for them.
if Is_Generic_Type (E) then
- Ghost_Mode := Save_Ghost_Mode;
- return Result;
+ goto Leave;
end if;
-- Some special processing for non-generic types to complete
@@ -6299,9 +6533,7 @@ package body Freeze is
-- subtypes can only be elaborated after the type itself, and they
-- need an itype reference.
- if Ekind (E) = E_Record_Type
- and then Has_Discriminants (E)
- then
+ if Ekind (E) = E_Record_Type and then Has_Discriminants (E) then
declare
Comp : Entity_Id;
IR : Node_Id;
@@ -6365,7 +6597,8 @@ package body Freeze is
end if;
end if;
- Ghost_Mode := Save_Ghost_Mode;
+ <<Leave>>
+ Restore_Ghost_Mode (Mode);
return Result;
end Freeze_Entity;
@@ -6634,10 +6867,10 @@ package body Freeze is
Desig_Typ := Find_Aggregate_Component_Desig_Type;
end if;
- when N_Selected_Component |
- N_Indexed_Component |
- N_Slice =>
-
+ when N_Indexed_Component
+ | N_Selected_Component
+ | N_Slice
+ =>
if Is_Access_Type (Etype (Prefix (N))) then
Desig_Typ := Designated_Type (Etype (Prefix (N)));
end if;
@@ -6849,35 +7082,37 @@ package body Freeze is
-- is a statement or declaration and we can insert the freeze node
-- before it.
- when N_Block_Statement |
- N_Entry_Body |
- N_Package_Body |
- N_Package_Specification |
- N_Protected_Body |
- N_Subprogram_Body |
- N_Task_Body => exit;
+ when N_Block_Statement
+ | N_Entry_Body
+ | N_Package_Body
+ | N_Package_Specification
+ | N_Protected_Body
+ | N_Subprogram_Body
+ | N_Task_Body
+ =>
+ exit;
-- The expander is allowed to define types in any statements list,
-- so any of the following parent nodes also mark a freezing point
-- if the actual node is in a list of statements or declarations.
- when N_Abortable_Part |
- N_Accept_Alternative |
- N_And_Then |
- N_Case_Statement_Alternative |
- N_Compilation_Unit_Aux |
- N_Conditional_Entry_Call |
- N_Delay_Alternative |
- N_Elsif_Part |
- N_Entry_Call_Alternative |
- N_Exception_Handler |
- N_Extended_Return_Statement |
- N_Freeze_Entity |
- N_If_Statement |
- N_Or_Else |
- N_Selective_Accept |
- N_Triggering_Alternative =>
-
+ when N_Abortable_Part
+ | N_Accept_Alternative
+ | N_And_Then
+ | N_Case_Statement_Alternative
+ | N_Compilation_Unit_Aux
+ | N_Conditional_Entry_Call
+ | N_Delay_Alternative
+ | N_Elsif_Part
+ | N_Entry_Call_Alternative
+ | N_Exception_Handler
+ | N_Extended_Return_Statement
+ | N_Freeze_Entity
+ | N_If_Statement
+ | N_Or_Else
+ | N_Selective_Accept
+ | N_Triggering_Alternative
+ =>
exit when Is_List_Member (P);
-- Freeze nodes produced by an expression coming from the Actions
@@ -7488,18 +7723,37 @@ package body Freeze is
-- Check for shaving
if Comes_From_Source (Typ) then
- if Orig_Lo < Expr_Value_R (Lo) then
- Error_Msg_N
- ("declared low bound of type & is outside type range??", Typ);
- Error_Msg_N
- ("\low bound adjusted up by delta (RM 3.5.9(13))??", Typ);
- end if;
- if Orig_Hi > Expr_Value_R (Hi) then
- Error_Msg_N
- ("declared high bound of type & is outside type range??", Typ);
- Error_Msg_N
- ("\high bound adjusted down by delta (RM 3.5.9(13))??", Typ);
+ -- In SPARK mode the given bounds must be strictly representable
+
+ if SPARK_Mode = On then
+ if Orig_Lo < Expr_Value_R (Lo) then
+ Error_Msg_NE
+ ("declared low bound of type & is outside type range",
+ Lo, Typ);
+ end if;
+
+ if Orig_Hi > Expr_Value_R (Hi) then
+ Error_Msg_NE
+ ("declared high bound of type & is outside type range",
+ Hi, Typ);
+ end if;
+
+ else
+ if Orig_Lo < Expr_Value_R (Lo) then
+ Error_Msg_N
+ ("declared low bound of type & is outside type range??", Typ);
+ Error_Msg_N
+ ("\low bound adjusted up by delta (RM 3.5.9(13))??", Typ);
+ end if;
+
+ if Orig_Hi > Expr_Value_R (Hi) then
+ Error_Msg_N
+ ("declared high bound of type & is outside type range??",
+ Typ);
+ Error_Msg_N
+ ("\high bound adjusted down by delta (RM 3.5.9(13))??", Typ);
+ end if;
end if;
end if;
end Freeze_Fixed_Point_Type;
@@ -7698,8 +7952,61 @@ package body Freeze is
-----------------------
procedure Freeze_Subprogram (E : Entity_Id) is
- Retype : Entity_Id;
+ procedure Set_Profile_Convention (Subp_Id : Entity_Id);
+ -- Set the conventions of all anonymous access-to-subprogram formals and
+ -- result subtype of subprogram Subp_Id to the convention of Subp_Id.
+
+ ----------------------------
+ -- Set_Profile_Convention --
+ ----------------------------
+
+ procedure Set_Profile_Convention (Subp_Id : Entity_Id) is
+ Conv : constant Convention_Id := Convention (Subp_Id);
+
+ procedure Set_Type_Convention (Typ : Entity_Id);
+ -- Set the convention of anonymous access-to-subprogram type Typ and
+ -- its designated type to Conv.
+
+ -------------------------
+ -- Set_Type_Convention --
+ -------------------------
+
+ procedure Set_Type_Convention (Typ : Entity_Id) is
+ begin
+ -- Set the convention on both the anonymous access-to-subprogram
+ -- type and the subprogram type it points to because both types
+ -- participate in conformance-related checks.
+
+ if Ekind (Typ) = E_Anonymous_Access_Subprogram_Type then
+ Set_Convention (Typ, Conv);
+ Set_Convention (Designated_Type (Typ), Conv);
+ end if;
+ end Set_Type_Convention;
+
+ -- Local variables
+
+ Formal : Entity_Id;
+
+ -- Start of processing for Set_Profile_Convention
+
+ begin
+ Formal := First_Formal (Subp_Id);
+ while Present (Formal) loop
+ Set_Type_Convention (Etype (Formal));
+ Next_Formal (Formal);
+ end loop;
+
+ if Ekind (Subp_Id) = E_Function then
+ Set_Type_Convention (Etype (Subp_Id));
+ end if;
+ end Set_Profile_Convention;
+
+ -- Local variables
+
F : Entity_Id;
+ Retype : Entity_Id;
+
+ -- Start of processing for Freeze_Subprogram
begin
-- Subprogram may not have an address clause unless it is imported
@@ -7707,8 +8014,7 @@ package body Freeze is
if Present (Address_Clause (E)) then
if not Is_Imported (E) then
Error_Msg_N
- ("address clause can only be given " &
- "for imported subprogram",
+ ("address clause can only be given for imported subprogram",
Name (Address_Clause (E)));
end if;
end if;
@@ -7739,8 +8045,8 @@ package body Freeze is
-- referenced data may change even if the address value does not.
-- Note that if the programmer gave an explicit Pure_Function pragma,
- -- then we believe the programmer, and leave the subprogram Pure.
- -- We also suppress this check on run-time files.
+ -- then we believe the programmer, and leave the subprogram Pure. We
+ -- also suppress this check on run-time files.
if Is_Pure (E)
and then Is_Subprogram (E)
@@ -7750,6 +8056,20 @@ package body Freeze is
Check_Function_With_Address_Parameter (E);
end if;
+ -- Ensure that all anonymous access-to-subprogram types inherit the
+ -- convention of their related subprogram (RM 6.3.1 13.1/3). This is
+ -- not done for a defaulted convention Ada because those types also
+ -- default to Ada. Convention Protected must not be propagated when
+ -- the subprogram is an entry because this would be illegal. The only
+ -- way to force convention Protected on these kinds of types is to
+ -- include keyword "protected" in the access definition.
+
+ if Convention (E) /= Convention_Ada
+ and then Convention (E) /= Convention_Protected
+ then
+ Set_Profile_Convention (E);
+ end if;
+
-- For non-foreign convention subprograms, this is where we create
-- the extra formals (for accessibility level and constrained bit
-- information). We delay this till the freeze point precisely so
@@ -7856,6 +8176,16 @@ package body Freeze is
then
Check_Overriding_Indicator (E, Empty, Is_Primitive (E));
end if;
+
+ if Modify_Tree_For_C
+ and then Nkind (Parent (E)) = N_Function_Specification
+ and then Is_Array_Type (Etype (E))
+ and then Is_Constrained (Etype (E))
+ and then not Is_Unchecked_Conversion_Instance (E)
+ and then not Rewritten_For_C (E)
+ then
+ Build_Procedure_Form (Unit_Declaration_Node (E));
+ end if;
end Freeze_Subprogram;
----------------------
@@ -8013,7 +8343,7 @@ package body Freeze is
-- Else construct and analyze the body of a wrapper procedure
-- that contains an object declaration to hold the expression.
- -- Given that this is done only to complete the analysis, it
+ -- Given that this is done only to complete the analysis, it is
-- simpler to build a procedure than a function which might
-- involve secondary stack expansion.
@@ -8284,7 +8614,7 @@ package body Freeze is
-- Add friendly warning if initialization comes from a packed array
-- component.
- if Is_Record_Type (Typ) then
+ if Is_Record_Type (Typ) then
declare
Comp : Entity_Id;
diff --git a/gcc/ada/freeze.ads b/gcc/ada/freeze.ads
index f11347d5ed..079d7132ab 100644
--- a/gcc/ada/freeze.ads
+++ b/gcc/ada/freeze.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -151,15 +151,15 @@ package Freeze is
-- fact Gigi decides it is known, but the opposite situation can never
-- occur.
--
- -- Size is known at compile time, but the actual value of the size is
- -- not known to the front end or is definitely 32 or more. In this case
- -- Size_Known_At_Compile_Time is set, but the Esize field is left set
+ -- Size is known at compile time, but the actual value of the size is not
+ -- known to the front end or is definitely greater than 64. In this case,
+ -- Size_Known_At_Compile_Time is set, but the RM_Size field is left set
-- to zero (to be set by Gigi).
--
-- Size is known at compile time, and the actual value of the size is
- -- known to the front end and is less than 32. In this case, the flag
- -- Size_Known_At_Compile_Time is set, and in addition Esize is set to
- -- the required size, allowing for possible front end packing of an
+ -- known to the front end and is not greater than 64. In this case, the
+ -- flag Size_Known_At_Compile_Time is set, and in addition RM_Size is set
+ -- to the required size, allowing for possible front end packing of an
-- array using this type as a component type.
--
-- Note: the flag Size_Known_At_Compile_Time is used to determine if the
@@ -187,13 +187,18 @@ package Freeze is
-- If Initialization_Statements (E) is an N_Compound_Statement, insert its
-- actions in the enclosing list and reset the attribute.
- function Freeze_Entity (E : Entity_Id; N : Node_Id) return List_Id;
+ function Freeze_Entity
+ (E : Entity_Id;
+ N : Node_Id;
+ Do_Freeze_Profile : Boolean := True) return List_Id;
-- Freeze an entity, and return Freeze nodes, to be inserted at the point
-- of call. N is a node whose source location corresponds to the freeze
-- point. This is used in placing warning messages in the situation where
-- it appears that a type has been frozen too early, e.g. when a primitive
-- operation is declared after the freezing point of its tagged type.
- -- Returns No_List if no freeze nodes needed.
+ -- Returns No_List if no freeze nodes needed. Parameter Do_Freeze_Profile
+ -- is used when E is a subprogram, and determines whether the profile of
+ -- the subprogram should be frozen as well.
procedure Freeze_All (From : Entity_Id; After : in out Node_Id);
-- Before a non-instance body, or at the end of a declarative part,
@@ -209,8 +214,13 @@ package Freeze is
-- in the scope. It is used to prevent a quadratic traversal over already
-- frozen entities.
- procedure Freeze_Before (N : Node_Id; T : Entity_Id);
- -- Freeze T then Insert the generated Freeze nodes before the node N
+ procedure Freeze_Before
+ (N : Node_Id;
+ T : Entity_Id;
+ Do_Freeze_Profile : Boolean := True);
+ -- Freeze T then Insert the generated Freeze nodes before the node N. Flag
+ -- Do_Freeze_Profile is used when T is an overloadable entity and indicates
+ -- whether its profile should be frozen at the same time.
procedure Freeze_Expression (N : Node_Id);
-- Freezes the required entities when the Expression N causes freezing.
diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb
index 723096ccc1..612f55484f 100644
--- a/gcc/ada/frontend.adb
+++ b/gcc/ada/frontend.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -30,8 +30,8 @@ with Checks;
with CStand;
with Debug; use Debug;
with Elists;
-with Exp_Ch6;
with Exp_Dbug;
+with Exp_Unst;
with Fmap;
with Fname.UF;
with Ghost; use Ghost;
@@ -90,7 +90,6 @@ begin
Checks.Initialize;
Sem_Warn.Initialize;
Prep.Initialize;
- Exp_Ch6.Initialize;
if Generate_SCIL then
SCIL_LL.Initialize;
@@ -411,14 +410,20 @@ begin
-- Comment needed for ASIS mode test and GNATprove mode test???
+ pragma Assert
+ (Operating_Mode = Generate_Code
+ or else Operating_Mode = Check_Semantics);
+
if Operating_Mode = Generate_Code
- or else (Operating_Mode = Check_Semantics
- and then (ASIS_Mode or GNATprove_Mode))
+ or else (ASIS_Mode or GNATprove_Mode)
then
Instantiate_Bodies;
end if;
- if Operating_Mode = Generate_Code then
+ -- Analyze inlined bodies and check elaboration rules in GNATprove
+ -- mode as well as during compilation.
+
+ if Operating_Mode = Generate_Code or else GNATprove_Mode then
if Inline_Processing_Required then
Analyze_Inlined_Bodies;
end if;
@@ -440,7 +445,7 @@ begin
-- At this stage we can unnest subprogram bodies if required
- Exp_Ch6.Unnest_Subprograms;
+ Exp_Unst.Unnest_Subprograms (Cunit (Main_Unit));
-- List library units if requested
@@ -458,7 +463,7 @@ begin
end if;
end if;
- -- Qualify all entity names in inner packages, package bodies, etc.
+ -- Qualify all entity names in inner packages, package bodies, etc
Exp_Dbug.Qualify_All_Entity_Names;
diff --git a/gcc/ada/g-arrspl.adb b/gcc/ada/g-arrspl.adb
index 2984bb8ed6..f3eaf809f9 100644
--- a/gcc/ada/g-arrspl.adb
+++ b/gcc/ada/g-arrspl.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -294,7 +294,6 @@ package body GNAT.Array_Split is
exit when K > Count_Sep;
case Mode is
-
when Single =>
-- In this mode just set start to character next to the
@@ -313,7 +312,6 @@ package body GNAT.Array_Split is
exit when K > Count_Sep
or else S.D.Indexes (K) > S.D.Indexes (K - 1) + 1;
end loop;
-
end case;
end loop;
diff --git a/gcc/ada/g-awk.adb b/gcc/ada/g-awk.adb
index 6f58e46a58..5771100b67 100644
--- a/gcc/ada/g-awk.adb
+++ b/gcc/ada/g-awk.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2014, AdaCore --
+-- Copyright (C) 2000-2016, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -974,7 +974,6 @@ package body GNAT.AWK is
Split_Line (Session);
case Callbacks is
-
when None =>
exit;
@@ -985,7 +984,6 @@ package body GNAT.AWK is
when Pass_Through =>
Filter_Active := Apply_Filters (Session);
exit;
-
end case;
end loop;
end Get_Line;
diff --git a/gcc/ada/g-byorma.ads b/gcc/ada/g-byorma.ads
index 46db6e475e..a58006e6dc 100644
--- a/gcc/ada/g-byorma.ads
+++ b/gcc/ada/g-byorma.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2006-2013, AdaCore --
+-- Copyright (C) 2006-2016, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -32,7 +32,7 @@
-- This package provides a procedure for reading and interpreting the BOM
-- (byte order mark) used to publish the encoding method for a string (for
-- example, a UTF-8 encoded file in windows will start with the appropriate
--- BOM sequence to signal UTF-8 encoding.
+-- BOM sequence to signal UTF-8 encoding).
-- There are two cases
diff --git a/gcc/ada/g-calend.ads b/gcc/ada/g-calend.ads
index 4234061e72..3559130e1f 100644
--- a/gcc/ada/g-calend.ads
+++ b/gcc/ada/g-calend.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -39,7 +39,7 @@
-- Second_Duration. Other functions are to access more advanced values like
-- Day_Of_Week, Day_In_Year and Week_In_Year.
-with Ada.Calendar;
+with Ada.Calendar.Formatting;
with Interfaces.C;
package GNAT.Calendar is
@@ -175,9 +175,11 @@ private
-- Robert G. Tantzen.
No_Time : constant Ada.Calendar.Time :=
- Ada.Calendar.Time_Of
+ Ada.Calendar.Formatting.Time_Of
(Ada.Calendar.Year_Number'First,
Ada.Calendar.Month_Number'First,
- Ada.Calendar.Day_Number'First);
+ Ada.Calendar.Day_Number'First,
+ Time_Zone => 0);
+ -- Use Time_Zone => 0 to be the same binary representation in any timezone
end GNAT.Calendar;
diff --git a/gcc/ada/g-catiio.adb b/gcc/ada/g-catiio.adb
index c0ccb4b796..772a70b883 100644
--- a/gcc/ada/g-catiio.adb
+++ b/gcc/ada/g-catiio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2014, AdaCore --
+-- Copyright (C) 1999-2016, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -500,7 +500,6 @@ package body GNAT.Calendar.Time_IO is
when others =>
raise Picture_Error with
"unknown format character in picture string";
-
end case;
-- Skip past % and format character
diff --git a/gcc/ada/g-comlin.adb b/gcc/ada/g-comlin.adb
index 172edaf889..ef76fee3f6 100644
--- a/gcc/ada/g-comlin.adb
+++ b/gcc/ada/g-comlin.adb
@@ -56,7 +56,7 @@ package body GNAT.Command_Line is
(Variable : out Parameter_Type;
Arg_Num : Positive;
First : Positive;
- Last : Positive;
+ Last : Natural;
Extra : Character := ASCII.NUL);
pragma Inline (Set_Parameter);
-- Set the parameter that will be returned by Parameter below
@@ -483,18 +483,22 @@ package body GNAT.Command_Line is
end if;
case Switch (Switch'Last) is
- when ':' =>
+ when ':' =>
Parameter_Type := Parameter_With_Optional_Space;
Switch_Last := Switch'Last - 1;
- when '=' =>
+
+ when '=' =>
Parameter_Type := Parameter_With_Space_Or_Equal;
Switch_Last := Switch'Last - 1;
- when '!' =>
+
+ when '!' =>
Parameter_Type := Parameter_No_Space;
Switch_Last := Switch'Last - 1;
- when '?' =>
+
+ when '?' =>
Parameter_Type := Parameter_Optional;
Switch_Last := Switch'Last - 1;
+
when others =>
Parameter_Type := Parameter_None;
Switch_Last := Switch'Last;
@@ -621,7 +625,7 @@ package body GNAT.Command_Line is
-- If we are on a new item, test if this might be a switch
if Parser.Current_Index = Arg'First then
- if Arg (Arg'First) /= Parser.Switch_Character then
+ if Arg = "" or else Arg (Arg'First) /= Parser.Switch_Character then
-- If it isn't a switch, return it immediately. We also know it
-- isn't the parameter to a previous switch, since that has
@@ -705,7 +709,7 @@ package body GNAT.Command_Line is
(if Concatenate then Parser.Current_Index else Arg'Last);
end if;
- if Switches (Switches'First) = '*' then
+ if Switches /= "" and then Switches (Switches'First) = '*' then
-- Always prepend the switch character, so that users know
-- that this comes from a switch on the command line. This
@@ -1061,7 +1065,9 @@ package body GNAT.Command_Line is
Section_Num := Section_Num + 1;
for Index in 1 .. Parser.Arg_Count loop
- if Argument (Parser, Index)(1) = Parser.Switch_Character
+ pragma Assert (Argument (Parser, Index)'First = 1);
+ if Argument (Parser, Index) /= ""
+ and then Argument (Parser, Index)(1) = Parser.Switch_Character
and then
Argument (Parser, Index) = Parser.Switch_Character &
Section_Delimiters
@@ -1127,7 +1133,7 @@ package body GNAT.Command_Line is
(Variable : out Parameter_Type;
Arg_Num : Positive;
First : Positive;
- Last : Positive;
+ Last : Natural;
Extra : Character := ASCII.NUL)
is
begin
@@ -2066,7 +2072,9 @@ package body GNAT.Command_Line is
Found_In_Config := True;
return False;
- when Parameter_No_Space | Parameter_Optional =>
+ when Parameter_No_Space
+ | Parameter_Optional
+ =>
Callback (Switch (Switch'First .. Last),
"", Switch (Param .. Switch'Last), Index);
Found_In_Config := True;
@@ -3073,6 +3081,7 @@ package body GNAT.Command_Line is
Free (Config.Switches (S).Long_Switch);
Free (Config.Switches (S).Help);
Free (Config.Switches (S).Section);
+ Free (Config.Switches (S).Argument);
end loop;
Unchecked_Free (Config.Switches);
@@ -3404,7 +3413,6 @@ package body GNAT.Command_Line is
Config.Switches (Index).String_Output.all :=
new String'(Parameter);
return;
-
end case;
end if;
diff --git a/gcc/ada/g-comlin.ads b/gcc/ada/g-comlin.ads
index 283bf47d4f..f7585085ac 100644
--- a/gcc/ada/g-comlin.ads
+++ b/gcc/ada/g-comlin.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2015, AdaCore --
+-- Copyright (C) 1999-2016, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1030,7 +1030,7 @@ private
type Parameter_Type is record
Arg_Num : Positive;
First : Positive;
- Last : Positive;
+ Last : Natural;
Extra : Character;
end record;
diff --git a/gcc/ada/g-debpoo.adb b/gcc/ada/g-debpoo.adb
index c5664a9939..9f8d57cd72 100644
--- a/gcc/ada/g-debpoo.adb
+++ b/gcc/ada/g-debpoo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -101,6 +101,9 @@ package body GNAT.Debug_Pools is
-- If True, protects Deallocate against releasing memory allocated before
-- System_Memory_Debug_Pool_Enabled was set.
+ Traceback_Count : Byte_Count := 0;
+ -- Total number of traceback elements
+
---------------------------
-- Back Trace Hash Table --
---------------------------
@@ -332,6 +335,10 @@ package body GNAT.Debug_Pools is
pragma Inline (Set_Valid);
-- Mark the address Storage as being under control of the memory pool
-- (if Value is True), or not (if Value is False).
+
+ Validity_Count : Byte_Count := 0;
+ -- Total number of validity elements
+
end Validity;
use Validity;
@@ -630,6 +637,7 @@ package body GNAT.Debug_Pools is
Frees => 0,
Total_Frees => 0,
Next => null);
+ Traceback_Count := Traceback_Count + 1;
Backtrace_Htable.Set (Elem);
else
@@ -845,6 +853,7 @@ package body GNAT.Debug_Pools is
if Value then
Ptr := new Validity_Bits;
+ Validity_Count := Validity_Count + 1;
Ptr.Valid :=
To_Pointer (Alloc (size_t (Max_Validity_Byte_Index)));
Validy_Htable.Set (Block_Number, Ptr);
@@ -1180,7 +1189,10 @@ package body GNAT.Debug_Pools is
begin
while Tmp /= System.Null_Address
- and then Total_Freed < Pool.Minimum_To_Free
+ and then
+ not (Total_Freed > Pool.Minimum_To_Free
+ and Pool.Logically_Deallocated <
+ Byte_Count (Pool.Maximum_Logically_Freed_Memory))
loop
Header := Header_Of (Tmp);
@@ -1188,12 +1200,12 @@ package body GNAT.Debug_Pools is
-- referenced anywhere, we can free it physically.
if Ignore_Marks or else not Marked (Tmp) then
-
declare
pragma Suppress (All_Checks);
-- Suppress the checks on this section. If they are overflow
-- errors, it isn't critical, and we'd rather avoid a
-- Constraint_Error in that case.
+
begin
-- Note that block_size < zero for freed blocks
@@ -1238,7 +1250,7 @@ package body GNAT.Debug_Pools is
Header_Of (Previous).Next := Next;
end if;
- Tmp := Next;
+ Tmp := Next;
else
Previous := Tmp;
@@ -1908,22 +1920,28 @@ package body GNAT.Debug_Pools is
-- Sorted array for the biggest memory users
begin
- New_Line;
+ Put_Line ("");
+
case Sort is
- when Memory_Usage | All_Reports =>
+ when All_Reports
+ | Memory_Usage
+ =>
Put_Line (Size'Img & " biggest memory users at this time:");
Put_Line ("Results include bytes and chunks still allocated");
Grand_Total := Float (Pool.Current_Water_Mark);
+
when Allocations_Count =>
Put_Line (Size'Img & " biggest number of live allocations:");
Put_Line ("Results include bytes and chunks still allocated");
Grand_Total := Float (Pool.Current_Water_Mark);
+
when Sort_Total_Allocs =>
Put_Line (Size'Img & " biggest number of allocations:");
Put_Line ("Results include total bytes and chunks allocated,");
Put_Line ("even if no longer allocated - Deallocations are"
& " ignored");
Grand_Total := Float (Pool.Allocated);
+
when Marked_Blocks =>
Put_Line ("Special blocks marked by Mark_Traceback");
Grand_Total := 0.0;
@@ -1952,16 +1970,22 @@ package body GNAT.Debug_Pools is
Bigger := Max (M) = null;
if not Bigger then
case Sort is
- when Memory_Usage | All_Reports =>
- Bigger :=
- Max (M).Total - Max (M).Total_Frees <
- Elem.Total - Elem.Total_Frees;
- when Allocations_Count =>
- Bigger :=
- Max (M).Count - Max (M).Frees
- < Elem.Count - Elem.Frees;
- when Sort_Total_Allocs | Marked_Blocks =>
- Bigger := Max (M).Count < Elem.Count;
+ when All_Reports
+ | Memory_Usage
+ =>
+ Bigger :=
+ Max (M).Total - Max (M).Total_Frees
+ < Elem.Total - Elem.Total_Frees;
+
+ when Allocations_Count =>
+ Bigger :=
+ Max (M).Count - Max (M).Frees
+ < Elem.Count - Elem.Frees;
+
+ when Marked_Blocks
+ | Sort_Total_Allocs
+ =>
+ Bigger := Max (M).Count < Elem.Count;
end case;
end if;
@@ -1989,35 +2013,52 @@ package body GNAT.Debug_Pools is
P : Percent;
begin
case Sort is
- when Memory_Usage | Allocations_Count | All_Reports =>
+ when All_Reports
+ | Allocations_Count
+ | Memory_Usage
+ =>
Total := Max (M).Total - Max (M).Total_Frees;
+
when Sort_Total_Allocs =>
Total := Max (M).Total;
+
when Marked_Blocks =>
Total := Byte_Count (Max (M).Count);
end case;
P := Percent (100.0 * Float (Total) / Grand_Total);
- if Sort = Marked_Blocks then
- Put (P'Img & "%:"
- & Max (M).Count'Img & " chunks /"
- & Integer (Grand_Total)'Img & " at");
- else
- Put (P'Img & "%:" & Total'Img & " bytes in"
- & Max (M).Count'Img & " chunks at");
- end if;
+ case Sort is
+ when Memory_Usage | Allocations_Count | All_Reports =>
+ declare
+ Count : constant Natural :=
+ Max (M).Count - Max (M).Frees;
+ begin
+ Put (P'Img & "%:" & Total'Img & " bytes in"
+ & Count'Img & " chunks at");
+ end;
+ when Sort_Total_Allocs =>
+ Put (P'Img & "%:" & Total'Img & " bytes in"
+ & Max (M).Count'Img & " chunks at");
+ when Marked_Blocks =>
+ Put (P'Img & "%:"
+ & Max (M).Count'Img & " chunks /"
+ & Integer (Grand_Total)'Img & " at");
+ end case;
end;
for J in Max (M).Traceback'Range loop
- Put (Image_C (PC_For (Max (M).Traceback (J))));
+ Put (" " & Image_C (PC_For (Max (M).Traceback (J))));
end loop;
- New_Line;
+ Put_Line ("");
end loop;
end Do_Report;
begin
+ Put_Line ("Traceback elements allocated: " & Traceback_Count'Img);
+ Put_Line ("Validity elements allocated: " & Validity_Count'Img);
+ Put_Line ("");
Put_Line ("Ada Allocs:" & Pool.Allocated'Img
& " bytes in" & Pool.Alloc_Count'Img & " chunks");
@@ -2041,7 +2082,6 @@ package body GNAT.Debug_Pools is
when others =>
Do_Report (Report);
end case;
-
end Dump;
-----------------
@@ -2053,7 +2093,6 @@ package body GNAT.Debug_Pools is
Size : Positive;
Report : Report_Type := All_Reports)
is
-
procedure Internal is new Dump
(Put_Line => Stdout_Put_Line,
Put => Stdout_Put);
diff --git a/gcc/ada/g-diopit.adb b/gcc/ada/g-diopit.adb
index dabea22616..65bd65c022 100644
--- a/gcc/ada/g-diopit.adb
+++ b/gcc/ada/g-diopit.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2015, AdaCore --
+-- Copyright (C) 2001-2016, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -140,9 +140,9 @@ package body GNAT.Directory_Operations.Iteration is
(Directory : String;
File_Pattern : String;
Suffix_Pattern : String);
- -- Read entries in Directory and call user's callback if the entry
- -- match File_Pattern and Suffix_Pattern is empty otherwise it will go
- -- down one more directory level by calling Next_Level routine above.
+ -- Read entries in Directory and call user's callback if the entry match
+ -- File_Pattern and Suffix_Pattern is empty; otherwise go down one more
+ -- directory level by calling Next_Level routine below.
procedure Next_Level
(Current_Path : String;
diff --git a/gcc/ada/g-dynhta.adb b/gcc/ada/g-dynhta.adb
index 449ac17dec..10931cc7d2 100644
--- a/gcc/ada/g-dynhta.adb
+++ b/gcc/ada/g-dynhta.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2015, AdaCore --
+-- Copyright (C) 2002-2016, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -57,8 +57,8 @@ package body GNAT.Dynamic_HTables is
-- Get --
---------
- function Get (T : Instance; K : Key) return Elmt_Ptr is
- Elmt : Elmt_Ptr;
+ function Get (T : Instance; K : Key) return Elmt_Ptr is
+ Elmt : Elmt_Ptr;
begin
if T = null then
@@ -224,7 +224,7 @@ package body GNAT.Dynamic_HTables is
-- Get --
---------
- function Get (T : Instance; K : Key) return Element is
+ function Get (T : Instance; K : Key) return Element is
Tmp : Elmt_Ptr;
begin
diff --git a/gcc/ada/g-dyntab.adb b/gcc/ada/g-dyntab.adb
index e5e41c927a..a74697dffb 100644
--- a/gcc/ada/g-dyntab.adb
+++ b/gcc/ada/g-dyntab.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2014, AdaCore --
+-- Copyright (C) 2000-2016, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -32,33 +32,23 @@
pragma Compiler_Unit_Warning;
with GNAT.Heap_Sort_G;
-with System; use System;
-with System.Memory; use System.Memory;
-with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
package body GNAT.Dynamic_Tables is
- Min : constant Integer := Integer (Table_Low_Bound);
- -- Subscript of the minimum entry in the currently allocated table
+ Empty : constant Table_Ptr :=
+ Empty_Table_Array_Ptr_To_Table_Ptr (Empty_Table_Array'Access);
-----------------------
-- Local Subprograms --
-----------------------
- procedure Reallocate (T : in out Instance);
- -- Reallocate the existing table according to the current value stored
- -- in Max. Works correctly to do an initial allocation if the table
- -- is currently null.
-
- pragma Warnings (Off);
- -- These unchecked conversions are in fact safe, since they never
- -- generate improperly aliased pointer values.
-
- function To_Address is new Ada.Unchecked_Conversion (Table_Ptr, Address);
- function To_Pointer is new Ada.Unchecked_Conversion (Address, Table_Ptr);
-
- pragma Warnings (On);
+ procedure Grow (T : in out Instance; New_Last : Table_Count_Type);
+ -- This is called when we are about to set the value of Last to a value
+ -- that is larger than Last_Allocated. This reallocates the table to the
+ -- larger size, as indicated by New_Last. At the time this is called,
+ -- T.P.Last is still the old value.
--------------
-- Allocate --
@@ -66,11 +56,9 @@ package body GNAT.Dynamic_Tables is
procedure Allocate (T : in out Instance; Num : Integer := 1) is
begin
- T.P.Last_Val := T.P.Last_Val + Num;
+ -- Note that Num can be negative
- if T.P.Last_Val > T.P.Max then
- Reallocate (T);
- end if;
+ Set_Last (T, T.P.Last + Table_Index_Type'Base (Num));
end Allocate;
------------
@@ -79,7 +67,7 @@ package body GNAT.Dynamic_Tables is
procedure Append (T : in out Instance; New_Val : Table_Component_Type) is
begin
- Set_Item (T, Table_Index_Type (T.P.Last_Val + 1), New_Val);
+ Set_Item (T, T.P.Last + 1, New_Val);
end Append;
----------------
@@ -99,9 +87,18 @@ package body GNAT.Dynamic_Tables is
procedure Decrement_Last (T : in out Instance) is
begin
- T.P.Last_Val := T.P.Last_Val - 1;
+ Allocate (T, -1);
end Decrement_Last;
+ -----------
+ -- First --
+ -----------
+
+ function First return Table_Index_Type is
+ begin
+ return Table_Low_Bound;
+ end First;
+
--------------
-- For_Each --
--------------
@@ -109,7 +106,7 @@ package body GNAT.Dynamic_Tables is
procedure For_Each (Table : Instance) is
Quit : Boolean := False;
begin
- for Index in Table_Low_Bound .. Table_Index_Type (Table.P.Last_Val) loop
+ for Index in Table_Low_Bound .. Table.P.Last loop
Action (Index, Table.Table (Index), Quit);
exit when Quit;
end loop;
@@ -120,23 +117,119 @@ package body GNAT.Dynamic_Tables is
----------
procedure Free (T : in out Instance) is
+ subtype Alloc_Type is Table_Type (First .. T.P.Last_Allocated);
+ type Alloc_Ptr is access all Alloc_Type;
+
+ procedure Free is new Ada.Unchecked_Deallocation (Alloc_Type, Alloc_Ptr);
+ function To_Alloc_Ptr is
+ new Ada.Unchecked_Conversion (Table_Ptr, Alloc_Ptr);
+
+ Temp : Alloc_Ptr := To_Alloc_Ptr (T.Table);
+
begin
- Free (To_Address (T.Table));
- T.Table := null;
- T.P.Length := 0;
+ if T.Table = Empty then
+ pragma Assert (T.P.Last_Allocated = First - 1);
+ pragma Assert (T.P.Last = First - 1);
+ null;
+ else
+ Free (Temp);
+ T.Table := Empty;
+ T.P.Last_Allocated := First - 1;
+ T.P.Last := First - 1;
+ end if;
end Free;
+ ----------
+ -- Grow --
+ ----------
+
+ procedure Grow (T : in out Instance; New_Last : Table_Count_Type) is
+
+ -- Note: Type Alloc_Ptr below needs to be declared locally so we know
+ -- the bounds. That means that the collection is local, so is finalized
+ -- when leaving Grow. That's why this package doesn't support controlled
+ -- types; the table elements would be finalized prematurely. An Ada
+ -- implementation would also be within its rights to reclaim the
+ -- storage. Fortunately, GNAT doesn't do that.
+
+ pragma Assert (not T.Locked);
+ pragma Assert (New_Last > T.P.Last_Allocated);
+
+ subtype Table_Length_Type is Table_Index_Type'Base
+ range 0 .. Table_Index_Type'Base'Last;
+
+ Old_Last_Allocated : constant Table_Count_Type := T.P.Last_Allocated;
+ Old_Allocated_Length : constant Table_Length_Type :=
+ Old_Last_Allocated - First + 1;
+
+ New_Length : constant Table_Length_Type := New_Last - First + 1;
+ New_Allocated_Length : Table_Length_Type;
+
+ begin
+ if T.Table = Empty then
+ New_Allocated_Length := Table_Length_Type (Table_Initial);
+ else
+ New_Allocated_Length :=
+ Table_Length_Type
+ (Long_Long_Integer (Old_Allocated_Length) *
+ (100 + Long_Long_Integer (Table_Increment)) / 100);
+ end if;
+
+ -- Make sure it really did grow
+
+ if New_Allocated_Length <= Old_Allocated_Length then
+ New_Allocated_Length := Old_Allocated_Length + 10;
+ end if;
+
+ if New_Allocated_Length <= New_Length then
+ New_Allocated_Length := New_Length + 10;
+ end if;
+
+ pragma Assert (New_Allocated_Length > Old_Allocated_Length);
+ pragma Assert (New_Allocated_Length > New_Length);
+
+ T.P.Last_Allocated := First + New_Allocated_Length - 1;
+
+ declare
+ subtype Old_Alloc_Type is Table_Type (First .. Old_Last_Allocated);
+ type Old_Alloc_Ptr is access all Old_Alloc_Type;
+
+ procedure Free is
+ new Ada.Unchecked_Deallocation (Old_Alloc_Type, Old_Alloc_Ptr);
+ function To_Old_Alloc_Ptr is
+ new Ada.Unchecked_Conversion (Table_Ptr, Old_Alloc_Ptr);
+
+ subtype Alloc_Type is
+ Table_Type (First .. First + New_Allocated_Length - 1);
+ type Alloc_Ptr is access all Alloc_Type;
+
+ function To_Table_Ptr is
+ new Ada.Unchecked_Conversion (Alloc_Ptr, Table_Ptr);
+
+ Old_Table : Old_Alloc_Ptr := To_Old_Alloc_Ptr (T.Table);
+ New_Table : constant Alloc_Ptr := new Alloc_Type;
+
+ begin
+ if T.Table /= Empty then
+ New_Table (First .. T.P.Last) := Old_Table (First .. T.P.Last);
+ Free (Old_Table);
+ end if;
+
+ T.Table := To_Table_Ptr (New_Table);
+ end;
+
+ pragma Assert (New_Last <= T.P.Last_Allocated);
+ pragma Assert (T.Table /= null);
+ pragma Assert (T.Table /= Empty);
+ end Grow;
+
--------------------
-- Increment_Last --
--------------------
procedure Increment_Last (T : in out Instance) is
begin
- T.P.Last_Val := T.P.Last_Val + 1;
-
- if T.P.Last_Val > T.P.Max then
- Reallocate (T);
- end if;
+ Allocate (T, 1);
end Increment_Last;
----------
@@ -144,100 +237,57 @@ package body GNAT.Dynamic_Tables is
----------
procedure Init (T : in out Instance) is
- Old_Length : constant Integer := T.P.Length;
-
begin
- T.P.Last_Val := Min - 1;
- T.P.Max := Min + Table_Initial - 1;
- T.P.Length := T.P.Max - Min + 1;
-
- -- If table is same size as before (happens when table is never
- -- expanded which is a common case), then simply reuse it. Note
- -- that this also means that an explicit Init call right after
- -- the implicit one in the package body is harmless.
-
- if Old_Length = T.P.Length then
- return;
-
- -- Otherwise we can use Reallocate to get a table of the right size.
- -- Note that Reallocate works fine to allocate a table of the right
- -- initial size when it is first allocated.
-
- else
- Reallocate (T);
- end if;
+ Free (T);
end Init;
----------
-- Last --
----------
- function Last (T : Instance) return Table_Index_Type is
+ function Last (T : Instance) return Table_Count_Type is
begin
- return Table_Index_Type (T.P.Last_Val);
+ return T.P.Last;
end Last;
- ----------------
- -- Reallocate --
- ----------------
-
- procedure Reallocate (T : in out Instance) is
- New_Length : Integer;
- New_Size : size_t;
+ -------------
+ -- Release --
+ -------------
+ procedure Release (T : in out Instance) is
+ pragma Assert (not T.Locked);
+ Old_Last_Allocated : constant Table_Count_Type := T.P.Last_Allocated;
begin
- if T.P.Max < T.P.Last_Val then
-
- -- Now increment table length until it is sufficiently large. Use
- -- the increment value or 10, which ever is larger (the reason
- -- for the use of 10 here is to ensure that the table does really
- -- increase in size (which would not be the case for a table of
- -- length 10 increased by 3% for instance). Do the intermediate
- -- calculation in Long_Long_Integer to avoid overflow.
-
- while T.P.Max < T.P.Last_Val loop
- New_Length :=
- Integer
- (Long_Long_Integer (T.P.Length) *
- (100 + Long_Long_Integer (Table_Increment)) / 100);
-
- if New_Length > T.P.Length then
- T.P.Length := New_Length;
- else
- T.P.Length := T.P.Length + 10;
- end if;
-
- T.P.Max := Min + T.P.Length - 1;
- end loop;
- end if;
+ if T.P.Last /= T.P.Last_Allocated then
+ pragma Assert (T.P.Last < T.P.Last_Allocated);
+ pragma Assert (T.Table /= Empty);
- New_Size :=
- size_t ((T.P.Max - Min + 1) *
- (Table_Type'Component_Size / Storage_Unit));
+ declare
+ subtype Old_Alloc_Type is Table_Type (First .. Old_Last_Allocated);
+ type Old_Alloc_Ptr is access all Old_Alloc_Type;
- if T.Table = null then
- T.Table := To_Pointer (Alloc (New_Size));
+ procedure Free is
+ new Ada.Unchecked_Deallocation (Old_Alloc_Type, Old_Alloc_Ptr);
+ function To_Old_Alloc_Ptr is
+ new Ada.Unchecked_Conversion (Table_Ptr, Old_Alloc_Ptr);
- elsif New_Size > 0 then
- T.Table :=
- To_Pointer (Realloc (Ptr => To_Address (T.Table),
- Size => New_Size));
- end if;
+ subtype Alloc_Type is
+ Table_Type (First .. First + T.P.Last - 1);
+ type Alloc_Ptr is access all Alloc_Type;
- if T.P.Length /= 0 and then T.Table = null then
- raise Storage_Error;
- end if;
- end Reallocate;
+ function To_Table_Ptr is
+ new Ada.Unchecked_Conversion (Alloc_Ptr, Table_Ptr);
- -------------
- -- Release --
- -------------
+ Old_Table : Old_Alloc_Ptr := To_Old_Alloc_Ptr (T.Table);
+ New_Table : constant Alloc_Ptr := new Alloc_Type'(Old_Table.all);
+ begin
+ T.P.Last_Allocated := T.P.Last;
+ Free (Old_Table);
+ T.Table := To_Table_Ptr (New_Table);
+ end;
+ end if;
- procedure Release (T : in out Instance) is
- begin
- T.P.Length := T.P.Last_Val - Integer (Table_Low_Bound) + 1;
- T.P.Max := T.P.Last_Val;
- Reallocate (T);
+ pragma Assert (T.P.Last = T.P.Last_Allocated);
end Release;
--------------
@@ -245,60 +295,18 @@ package body GNAT.Dynamic_Tables is
--------------
procedure Set_Item
- (T : in out Instance;
- Index : Table_Index_Type;
- Item : Table_Component_Type)
+ (T : in out Instance;
+ Index : Valid_Table_Index_Type;
+ Item : Table_Component_Type)
is
- -- If Item is a value within the current allocation, and we are going to
- -- reallocate, then we must preserve an intermediate copy here before
- -- calling Increment_Last. Otherwise, if Table_Component_Type is passed
- -- by reference, we are going to end up copying from storage that might
- -- have been deallocated from Increment_Last calling Reallocate.
-
- subtype Allocated_Table_T is
- Table_Type (T.Table'First .. Table_Index_Type (T.P.Max + 1));
- -- A constrained table subtype one element larger than the currently
- -- allocated table.
-
- Allocated_Table_Address : constant System.Address :=
- T.Table.all'Address;
- -- Used for address clause below (we can't use non-static expression
- -- Table.all'Address directly in the clause because some older versions
- -- of the compiler do not allow it).
-
- Allocated_Table : Allocated_Table_T;
- pragma Import (Ada, Allocated_Table);
- pragma Suppress (Range_Check, On => Allocated_Table);
- for Allocated_Table'Address use Allocated_Table_Address;
- -- Allocated_Table represents the currently allocated array, plus one
- -- element (the supplementary element is used to have a convenient way
- -- to the address just past the end of the current allocation). Range
- -- checks are suppressed because this unit uses direct calls to
- -- System.Memory for allocation, and this can yield misaligned storage
- -- (and we cannot rely on the bootstrap compiler supporting specifically
- -- disabling alignment checks, so we need to suppress all range checks).
- -- It is safe to suppress this check here because we know that a
- -- (possibly misaligned) object of that type does actually exist at that
- -- address.
- -- ??? We should really improve the allocation circuitry here to
- -- guarantee proper alignment.
-
- Need_Realloc : constant Boolean := Integer (Index) > T.P.Max;
- -- True if this operation requires storage reallocation (which may
- -- involve moving table contents around).
-
+ Item_Copy : constant Table_Component_Type := Item;
begin
- -- If we're going to reallocate, check whether Item references an
- -- element of the currently allocated table.
-
- if Need_Realloc
- and then Allocated_Table'Address <= Item'Address
- and then Item'Address <
- Allocated_Table (Table_Index_Type (T.P.Max + 1))'Address
- then
- -- If so, save a copy on the stack because Increment_Last will
- -- reallocate storage and might deallocate the current table.
+ -- If Set_Last is going to reallocate the table, we make a copy of Item,
+ -- in case the call was "Set_Item (T, X, T.Table (Y));", and Item is
+ -- passed by reference. Without the copy, we would deallocate the array
+ -- containing Item, leaving a dangling pointer.
+ if Index > T.P.Last_Allocated then
declare
Item_Copy : constant Table_Component_Type := Item;
begin
@@ -306,34 +314,28 @@ package body GNAT.Dynamic_Tables is
T.Table (Index) := Item_Copy;
end;
- else
- -- Here we know that either we won't reallocate (case of Index < Max)
- -- or that Item is not in the currently allocated table.
-
- if Integer (Index) > T.P.Last_Val then
- Set_Last (T, Index);
- end if;
+ return;
+ end if;
- T.Table (Index) := Item;
+ if Index > T.P.Last then
+ Set_Last (T, Index);
end if;
+
+ T.Table (Index) := Item_Copy;
end Set_Item;
--------------
-- Set_Last --
--------------
- procedure Set_Last (T : in out Instance; New_Val : Table_Index_Type) is
+ procedure Set_Last (T : in out Instance; New_Val : Table_Count_Type) is
+ pragma Assert (not T.Locked);
begin
- if Integer (New_Val) < T.P.Last_Val then
- T.P.Last_Val := Integer (New_Val);
-
- else
- T.P.Last_Val := Integer (New_Val);
-
- if T.P.Last_Val > T.P.Max then
- Reallocate (T);
- end if;
+ if New_Val > T.P.Last_Allocated then
+ Grow (T, New_Val);
end if;
+
+ T.P.Last := New_Val;
end Set_Last;
----------------
@@ -341,13 +343,12 @@ package body GNAT.Dynamic_Tables is
----------------
procedure Sort_Table (Table : in out Instance) is
-
Temp : Table_Component_Type;
-- A temporary position to simulate index 0
-- Local subprograms
- function Index_Of (Idx : Natural) return Table_Index_Type;
+ function Index_Of (Idx : Natural) return Table_Index_Type'Base;
-- Return index of Idx'th element of table
function Lower_Than (Op1, Op2 : Natural) return Boolean;
@@ -362,11 +363,11 @@ package body GNAT.Dynamic_Tables is
-- Index_Of --
--------------
- function Index_Of (Idx : Natural) return Table_Index_Type is
+ function Index_Of (Idx : Natural) return Table_Index_Type'Base is
J : constant Integer'Base :=
- Table_Index_Type'Pos (First) + Idx - 1;
+ Table_Index_Type'Base'Pos (First) + Idx - 1;
begin
- return Table_Index_Type'Val (J);
+ return Table_Index_Type'Base'Val (J);
end Index_Of;
----------
@@ -401,8 +402,7 @@ package body GNAT.Dynamic_Tables is
else
return
- Lt (Table.Table (Index_Of (Op1)),
- Table.Table (Index_Of (Op2)));
+ Lt (Table.Table (Index_Of (Op1)), Table.Table (Index_Of (Op2)));
end if;
end Lower_Than;
diff --git a/gcc/ada/g-dyntab.ads b/gcc/ada/g-dyntab.ads
index 59d993200a..eb7181565d 100644
--- a/gcc/ada/g-dyntab.ads
+++ b/gcc/ada/g-dyntab.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2015, AdaCore --
+-- Copyright (C) 2000-2016, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -41,40 +41,49 @@
-- instances of the table, while an instantiation of GNAT.Table creates a
-- single instance of the table type.
--- Note that this interface should remain synchronized with those in
--- GNAT.Table and the GNAT compiler source unit Table to keep as much
--- coherency as possible between these three related units.
+-- Note that these three interfaces should remain synchronized to keep as much
+-- coherency as possible among these three related units:
+--
+-- GNAT.Dynamic_Tables
+-- GNAT.Table
+-- Table (the compiler unit)
pragma Compiler_Unit_Warning;
+with Ada.Unchecked_Conversion;
+
generic
type Table_Component_Type is private;
type Table_Index_Type is range <>;
Table_Low_Bound : Table_Index_Type;
- Table_Initial : Positive;
- Table_Increment : Natural;
+ Table_Initial : Positive := 8;
+ Table_Increment : Natural := 100;
package GNAT.Dynamic_Tables is
- -- Table_Component_Type and Table_Index_Type specify the type of the
- -- array, Table_Low_Bound is the lower bound. Table_Index_Type must be an
- -- integer type. The effect is roughly to declare:
+ -- Table_Component_Type and Table_Index_Type specify the type of the array,
+ -- Table_Low_Bound is the lower bound. The effect is roughly to declare:
-- Table : array (Table_Low_Bound .. <>) of Table_Component_Type;
- -- Note: since the upper bound can be one less than the lower
- -- bound for an empty array, the table index type must be able
- -- to cover this range, e.g. if the lower bound is 1, then the
- -- Table_Index_Type should be Natural rather than Positive.
+ -- The lower bound of Table_Index_Type is ignored.
+
+ pragma Assert (Table_Low_Bound /= Table_Index_Type'Base'First);
+
+ function First return Table_Index_Type;
+ pragma Inline (First);
+ -- Export First as synonym for Table_Low_Bound (parallel with use of Last)
- -- Table_Component_Type may be any Ada type, except that controlled
- -- types are not supported. Note however that default initialization
- -- will NOT occur for array components.
+ subtype Valid_Table_Index_Type is Table_Index_Type'Base
+ range Table_Low_Bound .. Table_Index_Type'Base'Last;
+ subtype Table_Count_Type is Table_Index_Type'Base
+ range Table_Low_Bound - 1 .. Table_Index_Type'Base'Last;
- -- The Table_Initial values controls the allocation of the table when
- -- it is first allocated, either by default, or by an explicit Init
- -- call.
+ -- Table_Component_Type must not be a type with controlled parts.
+
+ -- The Table_Initial value controls the allocation of the table when
+ -- it is first allocated.
-- The Table_Increment value controls the amount of increase, if the
-- table has to be increased in size. The value given is a percentage
@@ -90,97 +99,114 @@ package GNAT.Dynamic_Tables is
-- to take the access of a table element, use Unrestricted_Access.
type Table_Type is
- array (Table_Index_Type range <>) of Table_Component_Type;
+ array (Valid_Table_Index_Type range <>) of Table_Component_Type;
subtype Big_Table_Type is
- Table_Type (Table_Low_Bound .. Table_Index_Type'Last);
+ Table_Type (Table_Low_Bound .. Valid_Table_Index_Type'Last);
-- We work with pointers to a bogus array type that is constrained with
-- the maximum possible range bound. This means that the pointer is a thin
-- pointer, which is more efficient. Since subscript checks in any case
-- must be on the logical, rather than physical bounds, safety is not
- -- compromised by this approach. These types should not be used by the
- -- client.
+ -- compromised by this approach.
+
+ -- To get subscript checking, rename a slice of the Table, like this:
+
+ -- Table : Table_Type renames T.Table (First .. Last (T));
+
+ -- and the refer to components of Table.
type Table_Ptr is access all Big_Table_Type;
for Table_Ptr'Storage_Size use 0;
- -- The table is actually represented as a pointer to allow reallocation.
- -- This type should not be used by the client.
+ -- The table is actually represented as a pointer to allow reallocation
type Table_Private is private;
-- Table private data that is not exported in Instance
+ -- Private use only:
+ subtype Empty_Table_Array_Type is
+ Table_Type (Table_Low_Bound .. Table_Low_Bound - 1);
+ type Empty_Table_Array_Ptr is access all Empty_Table_Array_Type;
+ Empty_Table_Array : aliased Empty_Table_Array_Type;
+ function Empty_Table_Array_Ptr_To_Table_Ptr is
+ new Ada.Unchecked_Conversion (Empty_Table_Array_Ptr, Table_Ptr);
+ -- End private use only. The above are used to initialize Table to point to
+ -- an empty array.
+
type Instance is record
- Table : aliased Table_Ptr := null;
- -- The table itself. The lower bound is the value of Low_Bound.
- -- Logically the upper bound is the current value of Last (although
- -- the actual size of the allocated table may be larger than this).
- -- The program may only access and modify Table entries in the
- -- range First .. Last.
+ Table : aliased Table_Ptr :=
+ Empty_Table_Array_Ptr_To_Table_Ptr (Empty_Table_Array'Access);
+ -- The table itself. The lower bound is the value of First. Logically
+ -- the upper bound is the current value of Last (although the actual
+ -- size of the allocated table may be larger than this). The program may
+ -- only access and modify Table entries in the range First .. Last.
+ --
+ -- It's a good idea to access this via a renaming of a slice, in order
+ -- to ensure bounds checking, as in:
+ --
+ -- Tab : Table_Type renames X.Table (First .. X.Last);
+
+ Locked : Boolean := False;
+ -- Table expansion is permitted only if this switch is set to False. A
+ -- client may set Locked to True, in which case any attempt to expand
+ -- the table will cause an assertion failure. Note that while a table
+ -- is locked, its address in memory remains fixed and unchanging.
P : Table_Private;
end record;
procedure Init (T : in out Instance);
- -- This procedure allocates a new table of size Initial (freeing any
- -- previously allocated larger table). Init must be called before using
- -- the table. Init is convenient in reestablishing a table for new use.
+ -- Reinitializes the table to empty. There is no need to call this before
+ -- using a table; tables default to empty.
- function Last (T : Instance) return Table_Index_Type;
+ function Last (T : Instance) return Table_Count_Type;
pragma Inline (Last);
- -- Returns the current value of the last used entry in the table,
- -- which can then be used as a subscript for Table. Note that the
- -- only way to modify Last is to call the Set_Last procedure. Last
- -- must always be used to determine the logically last entry.
+ -- Returns the current value of the last used entry in the table, which can
+ -- then be used as a subscript for Table.
procedure Release (T : in out Instance);
-- Storage is allocated in chunks according to the values given in the
- -- Initial and Increment parameters. A call to Release releases all
- -- storage that is allocated, but is not logically part of the current
+ -- Table_Initial and Table_Increment parameters. A call to Release releases
+ -- all storage that is allocated, but is not logically part of the current
-- array value. Current array values are not affected by this call.
procedure Free (T : in out Instance);
- -- Free all allocated memory for the table. A call to init is required
- -- before any use of this table after calling Free.
+ -- Same as Init
- First : constant Table_Index_Type := Table_Low_Bound;
- -- Export First as synonym for Low_Bound (parallel with use of Last)
-
- procedure Set_Last (T : in out Instance; New_Val : Table_Index_Type);
+ procedure Set_Last (T : in out Instance; New_Val : Table_Count_Type);
pragma Inline (Set_Last);
- -- This procedure sets Last to the indicated value. If necessary the
- -- table is reallocated to accommodate the new value (i.e. on return
- -- the allocated table has an upper bound of at least Last). If
- -- Set_Last reduces the size of the table, then logically entries are
- -- removed from the table. If Set_Last increases the size of the
- -- table, then new entries are logically added to the table.
+ -- This procedure sets Last to the indicated value. If necessary the table
+ -- is reallocated to accommodate the new value (i.e. on return the
+ -- allocated table has an upper bound of at least Last). If Set_Last
+ -- reduces the size of the table, then logically entries are removed from
+ -- the table. If Set_Last increases the size of the table, then new entries
+ -- are logically added to the table.
procedure Increment_Last (T : in out Instance);
pragma Inline (Increment_Last);
- -- Adds 1 to Last (same as Set_Last (Last + 1)
+ -- Adds 1 to Last (same as Set_Last (Last + 1))
procedure Decrement_Last (T : in out Instance);
pragma Inline (Decrement_Last);
- -- Subtracts 1 from Last (same as Set_Last (Last - 1)
+ -- Subtracts 1 from Last (same as Set_Last (Last - 1))
procedure Append (T : in out Instance; New_Val : Table_Component_Type);
pragma Inline (Append);
+ -- Appends New_Val onto the end of the table
-- Equivalent to:
-- Increment_Last (T);
-- T.Table (T.Last) := New_Val;
- -- i.e. the table size is increased by one, and the given new item
- -- stored in the newly created table element.
procedure Append_All (T : in out Instance; New_Vals : Table_Type);
-- Appends all components of New_Vals
procedure Set_Item
(T : in out Instance;
- Index : Table_Index_Type;
+ Index : Valid_Table_Index_Type;
Item : Table_Component_Type);
pragma Inline (Set_Item);
- -- Put Item in the table at position Index. The table is expanded if
- -- current table length is less than Index and in that case Last is set to
- -- Index. Item will replace any value already present in the table at this
- -- position.
+ -- Put Item in the table at position Index. If Index points to an existing
+ -- item (i.e. it is in the range First .. Last (T)), the item is replaced.
+ -- Otherwise (i.e. Index > Last (T), the table is expanded, and Last is set
+ -- to Index.
procedure Allocate (T : in out Instance; Num : Integer := 1);
pragma Inline (Allocate);
@@ -188,17 +214,17 @@ package GNAT.Dynamic_Tables is
generic
with procedure Action
- (Index : Table_Index_Type;
+ (Index : Valid_Table_Index_Type;
Item : Table_Component_Type;
Quit : in out Boolean) is <>;
procedure For_Each (Table : Instance);
- -- Calls procedure Action for each component of the table Table, or until
- -- one of these calls set Quit to True.
+ -- Calls procedure Action for each component of the table, or until one of
+ -- these calls set Quit to True.
generic
with function Lt (Comp1, Comp2 : Table_Component_Type) return Boolean;
procedure Sort_Table (Table : in out Instance);
- -- This procedure sorts the components of table Table into ascending
+ -- This procedure sorts the components of the table into ascending
-- order making calls to Lt to do required comparisons, and using
-- assignments to move components around. The Lt function returns True
-- if Comp1 is less than Comp2 (in the sense of the desired sort), and
@@ -208,16 +234,16 @@ package GNAT.Dynamic_Tables is
-- in the table is not preserved).
private
+
type Table_Private is record
- Max : Integer;
- -- Subscript of the maximum entry in the currently allocated table
+ Last_Allocated : Table_Count_Type := Table_Low_Bound - 1;
+ -- Subscript of the maximum entry in the currently allocated table.
+ -- Initial value ensures that we initially allocate the table.
- Length : Integer := 0;
- -- Number of entries in currently allocated table. The value of zero
- -- ensures that we initially allocate the table.
+ Last : Table_Count_Type := Table_Low_Bound - 1;
+ -- Current value of Last function
- Last_Val : Integer;
- -- Current value of Last
+ -- Invariant: Last <= Last_Allocated
end record;
end GNAT.Dynamic_Tables;
diff --git a/gcc/ada/g-expect.adb b/gcc/ada/g-expect.adb
index d7e65fb3e4..d7bb2dda37 100644
--- a/gcc/ada/g-expect.adb
+++ b/gcc/ada/g-expect.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2015, AdaCore --
+-- Copyright (C) 2000-2016, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -358,10 +358,14 @@ package body GNAT.Expect is
Expect_Internal (Descriptors, N, Timeout_Tmp, Full_Buffer);
case N is
- when Expect_Internal_Error | Expect_Process_Died =>
+ when Expect_Internal_Error
+ | Expect_Process_Died
+ =>
raise Process_Died;
- when Expect_Timeout | Expect_Full_Buffer =>
+ when Expect_Full_Buffer
+ | Expect_Timeout
+ =>
Result := N;
return;
@@ -514,10 +518,14 @@ package body GNAT.Expect is
Expect_Internal (Descriptors, N, Timeout, Full_Buffer);
case N is
- when Expect_Internal_Error | Expect_Process_Died =>
+ when Expect_Internal_Error
+ | Expect_Process_Died
+ =>
raise Process_Died;
- when Expect_Timeout | Expect_Full_Buffer =>
+ when Expect_Full_Buffer
+ | Expect_Timeout
+ =>
Result := N;
return;
@@ -576,10 +584,14 @@ package body GNAT.Expect is
Expect_Internal (Descriptors, N, Timeout, Full_Buffer);
case N is
- when Expect_Internal_Error | Expect_Process_Died =>
+ when Expect_Internal_Error
+ | Expect_Process_Died
+ =>
raise Process_Died;
- when Expect_Timeout | Expect_Full_Buffer =>
+ when Expect_Full_Buffer
+ | Expect_Timeout
+ =>
Result := N;
return;
@@ -698,7 +710,6 @@ package body GNAT.Expect is
-- If there is no limit to the buffer size
if Descriptors (D).Buffer_Size = 0 then
-
declare
Tmp : String_Access := Descriptors (D).Buffer;
@@ -728,7 +739,7 @@ package body GNAT.Expect is
-- Add what we read to the buffer
if Descriptors (D).Buffer_Index + N >
- Descriptors (D).Buffer_Size
+ Descriptors (D).Buffer_Size
then
-- If the user wants to know when we have
-- read more than the buffer can contain.
diff --git a/gcc/ada/g-forstr.adb b/gcc/ada/g-forstr.adb
index a6ebc91930..5652c11179 100644
--- a/gcc/ada/g-forstr.adb
+++ b/gcc/ada/g-forstr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -698,8 +698,9 @@ package body GNAT.Formatted_String is
S := Strings.Fixed.Index_Non_Blank (Buffer);
E := Buffer'Last;
- when Decimal_Scientific_Float | Decimal_Scientific_Float_Up =>
-
+ when Decimal_Scientific_Float
+ | Decimal_Scientific_Float_Up
+ =>
Put (Buffer, Var, Aft, Exp => 3);
S := Strings.Fixed.Index_Non_Blank (Buffer);
E := Buffer'Last;
@@ -709,8 +710,9 @@ package body GNAT.Formatted_String is
Characters.Handling.To_Lower (Buffer (S .. E));
end if;
- when Shortest_Decimal_Float | Shortest_Decimal_Float_Up =>
-
+ when Shortest_Decimal_Float
+ | Shortest_Decimal_Float_Up
+ =>
-- Without exponent
Put (Buffer, Var, Aft, Exp => 0);
@@ -907,10 +909,10 @@ package body GNAT.Formatted_String is
N'First));
begin
case F.Base is
- when None =>
+ when None =>
null;
- when C_Style =>
+ when C_Style =>
case F.Kind is
when Unsigned_Octal =>
N (P) := 'O';
@@ -933,7 +935,7 @@ package body GNAT.Formatted_String is
null;
end case;
- when Ada_Style =>
+ when Ada_Style =>
case F.Kind is
when Unsigned_Octal =>
if F.Left_Justify then
@@ -945,8 +947,9 @@ package body GNAT.Formatted_String is
N (N'First .. N'First + 1) := "8#";
N (N'Last) := '#';
- when Unsigned_Hexadecimal_Int |
- Unsigned_Hexadecimal_Int_Up =>
+ when Unsigned_Hexadecimal_Int
+ | Unsigned_Hexadecimal_Int_Up
+ =>
if F.Left_Justify then
N (N'First + 3 .. N'Last) := N (N'First .. N'Last - 3);
else
diff --git a/gcc/ada/g-forstr.ads b/gcc/ada/g-forstr.ads
index 94c295c725..88856a35b3 100644
--- a/gcc/ada/g-forstr.ads
+++ b/gcc/ada/g-forstr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,10 +29,22 @@
-- --
------------------------------------------------------------------------------
--- This package add support for formatted string as supported by C printf().
+-- This package add support for formatted string as supported by C printf()
-- A simple usage is:
-
+--
+-- Put_Line (-(+"%s" & "a string"));
+--
+-- or with a constant for the format:
+--
+-- declare
+-- Format : constant Formatted_String := +"%s";
+-- begin
+-- Put_Line (-(Format & "a string"));
+-- end;
+--
+-- Finally a more complex example:
+--
-- declare
-- F : Formatted_String := +"['%c' ; %10d]";
-- C : Character := 'v';
@@ -132,7 +144,12 @@ package GNAT.Formatted_String is
use Ada;
type Formatted_String (<>) is private;
- -- A format string as defined for printf routine
+ -- A format string as defined for printf routine. This string is the
+ -- actual format for all the parameters added with the "&" routines below.
+ -- Note that a Formatted_String object can't be reused as it serves as
+ -- recipient for the final result. That is, each use of "&" will build
+ -- incrementally the final result string which can be retrieved with
+ -- the "-" routine below.
Format_Error : exception;
-- Raised for every mismatch between the parameter and the expected format
diff --git a/gcc/ada/g-locfil.ads b/gcc/ada/g-locfil.ads
index b8213cdb0d..3e52cc0625 100644
--- a/gcc/ada/g-locfil.ads
+++ b/gcc/ada/g-locfil.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2010, AdaCore --
+-- Copyright (C) 1995-2016, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -39,7 +39,7 @@ package GNAT.Lock_Files is
-- Exception raised if file cannot be locked
subtype Path_Name is String;
- -- Pathname is used by all services provided in this unit to specified
+ -- Pathname is used by all services provided in this unit to specify
-- directory name and file name. On DOS based systems both directory
-- separators are handled (i.e. slash and backslash).
diff --git a/gcc/ada/g-mbdira.adb b/gcc/ada/g-mbdira.adb
index 3d026ab524..c5d8c8b729 100644
--- a/gcc/ada/g-mbdira.adb
+++ b/gcc/ada/g-mbdira.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -178,7 +178,7 @@ package body GNAT.MBBS_Discrete_Random is
begin
X1 := Int (Calendar.Year (Now)) * 12 * 31 +
- Int (Calendar.Month (Now) * 31) +
+ Int (Calendar.Month (Now) * 31) +
Int (Calendar.Day (Now));
X2 := Int (Calendar.Seconds (Now) * Duration (1000.0));
diff --git a/gcc/ada/g-memdum.adb b/gcc/ada/g-memdum.adb
index 8aa24a72c7..bee7991ce6 100644
--- a/gcc/ada/g-memdum.adb
+++ b/gcc/ada/g-memdum.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2014, AdaCore --
+-- Copyright (C) 2003-2016, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -133,6 +133,7 @@ package body GNAT.Memory_Dump is
Offset_Buf (4 .. Last - 1);
Line_Buf (AIL - 1 .. AIL) := ": ";
end;
+
when None =>
null;
end case;
diff --git a/gcc/ada/g-pehage.adb b/gcc/ada/g-pehage.adb
index 81370117fc..76ecb02356 100644
--- a/gcc/ada/g-pehage.adb
+++ b/gcc/ada/g-pehage.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2015, AdaCore --
+-- Copyright (C) 2002-2016, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -886,7 +886,8 @@ package body GNAT.Perfect_Hash_Generators is
Length_2 := 0;
when Function_Table_1
- | Function_Table_2 =>
+ | Function_Table_2
+ =>
Item_Size := Type_Size (NV);
Length_1 := T1_Len;
Length_2 := T2_Len;
@@ -1675,6 +1676,7 @@ package body GNAT.Perfect_Hash_Generators is
case Opt is
when CPU_Time =>
Put (File, Type_Img (256));
+
when Memory_Space =>
Put (File, "Natural");
end case;
@@ -1693,6 +1695,7 @@ package body GNAT.Perfect_Hash_Generators is
case Opt is
when CPU_Time =>
Put (File, "C");
+
when Memory_Space =>
Put (File, "Character'Pos");
end case;
@@ -2591,7 +2594,6 @@ package body GNAT.Perfect_Hash_Generators is
when Graph_Table =>
return Get_Graph (J);
-
end case;
end Value;
diff --git a/gcc/ada/g-sechas.adb b/gcc/ada/g-sechas.adb
index 0e70b5dd48..59a598d74c 100644
--- a/gcc/ada/g-sechas.adb
+++ b/gcc/ada/g-sechas.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -253,7 +253,7 @@ package body GNAT.Secure_Hashes is
if Index = First_Index then
-- Message_Length is in bytes, but we need to store it as
- -- a bit count).
+ -- a bit count.
Pad (Index) := Character'Val
(Shift_Left (Message_Length and 16#1f#, 3));
@@ -341,6 +341,20 @@ package body GNAT.Secure_Hashes is
end return;
end HMAC_Initial_Context;
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (Stream : in out Hash_Stream;
+ Item : out Stream_Element_Array;
+ Last : out Stream_Element_Offset)
+ is
+ pragma Unreferenced (Stream, Item, Last);
+ begin
+ raise Program_Error with "Hash_Stream is write-only";
+ end Read;
+
------------
-- Update --
------------
@@ -364,7 +378,6 @@ package body GNAT.Secure_Hashes is
C.M_State.Last := 0;
end if;
end loop;
-
end Update;
------------
@@ -422,6 +435,18 @@ package body GNAT.Secure_Hashes is
return Digest (C);
end Wide_Digest;
+ -----------
+ -- Write --
+ -----------
+
+ procedure Write
+ (Stream : in out Hash_Stream;
+ Item : Stream_Element_Array)
+ is
+ begin
+ Update (Stream.C.all, Item);
+ end Write;
+
end H;
-------------------------
diff --git a/gcc/ada/g-sechas.ads b/gcc/ada/g-sechas.ads
index c00150e17b..33e635ce54 100644
--- a/gcc/ada/g-sechas.ads
+++ b/gcc/ada/g-sechas.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -191,6 +191,12 @@ package GNAT.Secure_Hashes is
-- Wide_Update) on a default initialized Context, followed by Digest
-- on the resulting Context.
+ type Hash_Stream (C : access Context) is
+ new Root_Stream_Type with private;
+ -- Stream wrapper converting Write calls to Update calls on C.
+ -- Arbitrary data structures can thus be conveniently hashed using
+ -- their stream attributes.
+
private
Block_Length : constant Natural := Block_Words * Word_Length;
@@ -215,6 +221,20 @@ package GNAT.Secure_Hashes is
Initial_Context : constant Context (KL => 0) := (others => <>);
-- Initial values are provided by default initialization of Context
+ type Hash_Stream (C : access Context) is
+ new Root_Stream_Type with null record;
+
+ procedure Read
+ (Stream : in out Hash_Stream;
+ Item : out Stream_Element_Array;
+ Last : out Stream_Element_Offset);
+ -- Raise Program_Error: hash streams are write-only
+
+ procedure Write
+ (Stream : in out Hash_Stream;
+ Item : Stream_Element_Array);
+ -- Call Update
+
end H;
end GNAT.Secure_Hashes;
diff --git a/gcc/ada/g-sercom-linux.adb b/gcc/ada/g-sercom-linux.adb
index f12d6ac2a2..4140106c8d 100644
--- a/gcc/ada/g-sercom-linux.adb
+++ b/gcc/ada/g-sercom-linux.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2007-2015, AdaCore --
+-- Copyright (C) 2007-2016, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -239,10 +239,12 @@ package body GNAT.Serial_Communications is
end if;
case Flow is
- when None =>
+ when None =>
null;
- when RTS_CTS =>
+
+ when RTS_CTS =>
Current.c_cflag := Current.c_cflag or CRTSCTS;
+
when Xon_Xoff =>
Current.c_iflag := Current.c_iflag or IXON;
end case;
diff --git a/gcc/ada/g-sercom-mingw.adb b/gcc/ada/g-sercom-mingw.adb
index 292ca8f563..dabbfcfd40 100644
--- a/gcc/ada/g-sercom-mingw.adb
+++ b/gcc/ada/g-sercom-mingw.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2007-2013, AdaCore --
+-- Copyright (C) 2007-2016, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -248,10 +248,24 @@ package body GNAT.Serial_Communications is
Raise_Error ("cannot set comm state");
end if;
- -- Set the timeout status
+ -- Set the timeout status, to honor our spec with respect to read
+ -- timeouts. Always disconnect write timeouts.
+
+ -- Blocking reads - no timeout at all
if Block then
Com_Time_Out := (others => 0);
+
+ -- Non-blocking reads and null timeout - immediate return with what we
+ -- have - set ReadIntervalTimeout to MAXDWORD.
+
+ elsif Timeout = 0.0 then
+ Com_Time_Out :=
+ (ReadIntervalTimeout => DWORD'Last,
+ others => 0);
+
+ -- Non-blocking reads with timeout - set total read timeout accordingly
+
else
Com_Time_Out :=
(ReadTotalTimeoutConstant => DWORD (1000 * Timeout),
diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb
index 59430081c2..07931af601 100644
--- a/gcc/ada/g-socket.adb
+++ b/gcc/ada/g-socket.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2014, AdaCore --
+-- Copyright (C) 2001-2016, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -50,8 +50,6 @@ package body GNAT.Sockets is
package C renames Interfaces.C;
- use type C.int;
-
ENOERROR : constant := 0;
Netdb_Buffer_Size : constant := SOSC.Need_Netdb_Buffer * 1024;
@@ -82,7 +80,7 @@ package body GNAT.Sockets is
(Non_Blocking_IO => SOSC.FIONBIO,
N_Bytes_To_Read => SOSC.FIONREAD);
- Options : constant array (Option_Name) of C.int :=
+ Options : constant array (Specific_Option_Name) of C.int :=
(Keep_Alive => SOSC.SO_KEEPALIVE,
Reuse_Address => SOSC.SO_REUSEADDR,
Broadcast => SOSC.SO_BROADCAST,
@@ -98,7 +96,8 @@ package body GNAT.Sockets is
Multicast_Loop => SOSC.IP_MULTICAST_LOOP,
Receive_Packet_Info => SOSC.IP_PKTINFO,
Send_Timeout => SOSC.SO_SNDTIMEO,
- Receive_Timeout => SOSC.SO_RCVTIMEO);
+ Receive_Timeout => SOSC.SO_RCVTIMEO,
+ Busy_Polling => SOSC.SO_BUSY_POLL);
-- ??? Note: for OpenSolaris, Receive_Packet_Info should be IP_RECVPKTINFO,
-- but for Linux compatibility this constant is the same as IP_PKTINFO.
@@ -150,7 +149,7 @@ package body GNAT.Sockets is
-- Output an array of inet address components in hex or decimal mode
function Is_IP_Address (Name : String) return Boolean;
- -- Return true when Name is an IP address in standard dot notation
+ -- Return true when Name is an IPv4 address in dotted quad notation
procedure Netdb_Lock;
pragma Inline (Netdb_Lock);
@@ -185,9 +184,10 @@ package body GNAT.Sockets is
-- Raise Socket_Error with an exception message describing the error code
-- from errno.
- procedure Raise_Host_Error (H_Error : Integer);
+ procedure Raise_Host_Error (H_Error : Integer; Name : String);
-- Raise Host_Error exception with message describing error code (note
- -- hstrerror seems to be obsolete) from h_errno.
+ -- hstrerror seems to be obsolete) from h_errno. Name is the name
+ -- or address that was being looked up.
procedure Narrow (Item : in out Socket_Set_Type);
-- Update Last as it may be greater than the real last socket
@@ -973,7 +973,7 @@ package body GNAT.Sockets is
Res'Access, Buf'Address, Buflen, Err'Access) /= 0
then
Netdb_Unlock;
- Raise_Host_Error (Integer (Err));
+ Raise_Host_Error (Integer (Err), Image (Address));
end if;
begin
@@ -995,7 +995,8 @@ package body GNAT.Sockets is
function Get_Host_By_Name (Name : String) return Host_Entry_Type is
begin
- -- Detect IP address name and redirect to Inet_Addr
+ -- If the given name actually is the string representation of
+ -- an IP address, use Get_Host_By_Address instead.
if Is_IP_Address (Name) then
return Get_Host_By_Address (Inet_Addr (Name));
@@ -1015,7 +1016,7 @@ package body GNAT.Sockets is
(HN, Res'Access, Buf'Address, Buflen, Err'Access) /= 0
then
Netdb_Unlock;
- Raise_Host_Error (Integer (Err));
+ Raise_Host_Error (Integer (Err), Name);
end if;
return H : constant Host_Entry_Type :=
@@ -1138,9 +1139,10 @@ package body GNAT.Sockets is
-----------------------
function Get_Socket_Option
- (Socket : Socket_Type;
- Level : Level_Type := Socket_Level;
- Name : Option_Name) return Option_Type
+ (Socket : Socket_Type;
+ Level : Level_Type := Socket_Level;
+ Name : Option_Name;
+ Optname : Interfaces.C.int := -1) return Option_Type
is
use SOSC;
use type C.unsigned_char;
@@ -1153,29 +1155,44 @@ package body GNAT.Sockets is
Add : System.Address;
Res : C.int;
Opt : Option_Type (Name);
+ Onm : Interfaces.C.int;
begin
+ if Name in Specific_Option_Name then
+ Onm := Options (Name);
+
+ elsif Optname = -1 then
+ raise Socket_Error with "optname must be specified";
+
+ else
+ Onm := Optname;
+ end if;
+
case Name is
- when Multicast_Loop |
- Multicast_TTL |
- Receive_Packet_Info =>
+ when Multicast_Loop
+ | Multicast_TTL
+ | Receive_Packet_Info
+ =>
Len := V1'Size / 8;
Add := V1'Address;
- when Keep_Alive |
- Reuse_Address |
- Broadcast |
- No_Delay |
- Send_Buffer |
- Receive_Buffer |
- Multicast_If |
- Error =>
+ when Broadcast
+ | Busy_Polling
+ | Error
+ | Generic_Option
+ | Keep_Alive
+ | Multicast_If
+ | No_Delay
+ | Receive_Buffer
+ | Reuse_Address
+ | Send_Buffer
+ =>
Len := V4'Size / 8;
Add := V4'Address;
- when Send_Timeout |
- Receive_Timeout =>
-
+ when Receive_Timeout
+ | Send_Timeout
+ =>
-- The standard argument for SO_RCVTIMEO and SO_SNDTIMEO is a
-- struct timeval, but on Windows it is a milliseconds count in
-- a DWORD.
@@ -1189,19 +1206,19 @@ package body GNAT.Sockets is
Add := VT'Address;
end if;
- when Linger |
- Add_Membership |
- Drop_Membership =>
+ when Add_Membership
+ | Drop_Membership
+ | Linger
+ =>
Len := V8'Size / 8;
Add := V8'Address;
-
end case;
Res :=
C_Getsockopt
(C.int (Socket),
Levels (Level),
- Options (Name),
+ Onm,
Add, Len'Access);
if Res = Failure then
@@ -1209,41 +1226,52 @@ package body GNAT.Sockets is
end if;
case Name is
- when Keep_Alive |
- Reuse_Address |
- Broadcast |
- No_Delay =>
+ when Generic_Option =>
+ Opt.Optname := Onm;
+ Opt.Optval := V4;
+
+ when Broadcast
+ | Keep_Alive
+ | No_Delay
+ | Reuse_Address
+ =>
Opt.Enabled := (V4 /= 0);
- when Linger =>
+ when Busy_Polling =>
+ Opt.Microseconds := Natural (V4);
+
+ when Linger =>
Opt.Enabled := (V8 (V8'First) /= 0);
Opt.Seconds := Natural (V8 (V8'Last));
- when Send_Buffer |
- Receive_Buffer =>
+ when Receive_Buffer
+ | Send_Buffer
+ =>
Opt.Size := Natural (V4);
- when Error =>
+ when Error =>
Opt.Error := Resolve_Error (Integer (V4));
- when Add_Membership |
- Drop_Membership =>
+ when Add_Membership
+ | Drop_Membership
+ =>
To_Inet_Addr (To_In_Addr (V8 (V8'First)), Opt.Multicast_Address);
To_Inet_Addr (To_In_Addr (V8 (V8'Last)), Opt.Local_Interface);
- when Multicast_If =>
+ when Multicast_If =>
To_Inet_Addr (To_In_Addr (V4), Opt.Outgoing_If);
- when Multicast_TTL =>
+ when Multicast_TTL =>
Opt.Time_To_Live := Integer (V1);
- when Multicast_Loop |
- Receive_Packet_Info =>
+ when Multicast_Loop
+ | Receive_Packet_Info
+ =>
Opt.Enabled := (V1 /= 0);
- when Send_Timeout |
- Receive_Timeout =>
-
+ when Receive_Timeout
+ | Send_Timeout
+ =>
if Target_OS = Windows then
-- Timeout is in milliseconds, actual value is 500 ms +
@@ -1502,16 +1530,36 @@ package body GNAT.Sockets is
-------------------
function Is_IP_Address (Name : String) return Boolean is
+ Dots : Natural := 0;
+
begin
+ -- Perform a cursory check for a dotted quad: we must have 1 to 3 dots,
+ -- and there must be at least one digit around each.
+
for J in Name'Range loop
- if Name (J) /= '.'
- and then Name (J) not in '0' .. '9'
- then
+ if Name (J) = '.' then
+
+ -- Check that the dot is not in first or last position, and that
+ -- it is followed by a digit. Note that we already know that it is
+ -- preceded by a digit, or we would have returned earlier on.
+
+ if J in Name'First + 1 .. Name'Last - 1
+ and then Name (J + 1) in '0' .. '9'
+ then
+ Dots := Dots + 1;
+
+ -- Definitely not a proper dotted quad
+
+ else
+ return False;
+ end if;
+
+ elsif Name (J) not in '0' .. '9' then
return False;
end if;
end loop;
- return True;
+ return Dots in 1 .. 3;
end Is_IP_Address;
-------------
@@ -1700,11 +1748,19 @@ package body GNAT.Sockets is
-- Raise_Host_Error --
----------------------
- procedure Raise_Host_Error (H_Error : Integer) is
+ procedure Raise_Host_Error (H_Error : Integer; Name : String) is
+ function Dedot (Value : String) return String is
+ (if Value /= "" and then Value (Value'Last) = '.' then
+ Value (Value'First .. Value'Last - 1)
+ else
+ Value);
+ -- Removes dot at the end of error message
+
begin
raise Host_Error with
Err_Code_Image (H_Error)
- & Host_Error_Messages.Host_Error_Message (H_Error);
+ & Dedot (Host_Error_Messages.Host_Error_Message (H_Error))
+ & ": " & Name;
end Raise_Host_Error;
------------------------
@@ -2237,60 +2293,75 @@ package body GNAT.Sockets is
Len : C.int;
Add : System.Address := Null_Address;
Res : C.int;
+ Onm : C.int;
begin
case Option.Name is
- when Keep_Alive |
- Reuse_Address |
- Broadcast |
- No_Delay =>
+ when Generic_Option =>
+ V4 := Option.Optval;
+ Len := V4'Size / 8;
+ Add := V4'Address;
+
+ when Broadcast
+ | Keep_Alive
+ | No_Delay
+ | Reuse_Address
+ =>
V4 := C.int (Boolean'Pos (Option.Enabled));
Len := V4'Size / 8;
Add := V4'Address;
- when Linger =>
+ when Busy_Polling =>
+ V4 := C.int (Option.Microseconds);
+ Len := V4'Size / 8;
+ Add := V4'Address;
+
+ when Linger =>
V8 (V8'First) := C.int (Boolean'Pos (Option.Enabled));
V8 (V8'Last) := C.int (Option.Seconds);
Len := V8'Size / 8;
Add := V8'Address;
- when Send_Buffer |
- Receive_Buffer =>
+ when Receive_Buffer
+ | Send_Buffer
+ =>
V4 := C.int (Option.Size);
Len := V4'Size / 8;
Add := V4'Address;
- when Error =>
+ when Error =>
V4 := C.int (Boolean'Pos (True));
Len := V4'Size / 8;
Add := V4'Address;
- when Add_Membership |
- Drop_Membership =>
+ when Add_Membership
+ | Drop_Membership
+ =>
V8 (V8'First) := To_Int (To_In_Addr (Option.Multicast_Address));
V8 (V8'Last) := To_Int (To_In_Addr (Option.Local_Interface));
Len := V8'Size / 8;
Add := V8'Address;
- when Multicast_If =>
+ when Multicast_If =>
V4 := To_Int (To_In_Addr (Option.Outgoing_If));
Len := V4'Size / 8;
Add := V4'Address;
- when Multicast_TTL =>
+ when Multicast_TTL =>
V1 := C.unsigned_char (Option.Time_To_Live);
Len := V1'Size / 8;
Add := V1'Address;
- when Multicast_Loop |
- Receive_Packet_Info =>
+ when Multicast_Loop
+ | Receive_Packet_Info
+ =>
V1 := C.unsigned_char (Boolean'Pos (Option.Enabled));
Len := V1'Size / 8;
Add := V1'Address;
- when Send_Timeout |
- Receive_Timeout =>
-
+ when Receive_Timeout
+ | Send_Timeout
+ =>
if Target_OS = Windows then
-- On Windows, the timeout is a DWORD in milliseconds, and
@@ -2314,13 +2385,22 @@ package body GNAT.Sockets is
Len := VT'Size / 8;
Add := VT'Address;
end if;
-
end case;
+ if Option.Name in Specific_Option_Name then
+ Onm := Options (Option.Name);
+
+ elsif Option.Optname = -1 then
+ raise Socket_Error with "optname must be specified";
+
+ else
+ Onm := Option.Optname;
+ end if;
+
Res := C_Setsockopt
(C.int (Socket),
Levels (Level),
- Options (Option.Name),
+ Onm,
Add, Len);
if Res = Failure then
@@ -2461,7 +2541,7 @@ package body GNAT.Sockets is
-- Hostent_H_Addr (E, <index>) may return an address that is
-- not correctly aligned for In_Addr, so we need to use
- -- an intermediate copy operation on a type with an alignemnt
+ -- an intermediate copy operation on a type with an alignment
-- of 1 to recover the value.
subtype Addr_Buf_T is C.char_array (1 .. Addr'Size / 8);
diff --git a/gcc/ada/g-socket.ads b/gcc/ada/g-socket.ads
index ff293decd0..d80f0ad266 100644
--- a/gcc/ada/g-socket.ads
+++ b/gcc/ada/g-socket.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2014, AdaCore --
+-- Copyright (C) 2001-2016, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -373,6 +373,9 @@ package GNAT.Sockets is
-- entities declared therein are not meant for direct access by users,
-- including through this renaming.
+ use type Interfaces.C.int;
+ -- Need visibility on "-" operator so that we can write -1
+
procedure Initialize;
pragma Obsolescent
(Entity => Initialize,
@@ -676,7 +679,8 @@ package GNAT.Sockets is
-- a boolean to enable or disable this option.
type Option_Name is
- (Keep_Alive, -- Enable sending of keep-alive messages
+ (Generic_Option,
+ Keep_Alive, -- Enable sending of keep-alive messages
Reuse_Address, -- Allow bind to reuse local address
Broadcast, -- Enable datagram sockets to recv/send broadcasts
Send_Buffer, -- Set/get the maximum socket send buffer in bytes
@@ -691,10 +695,17 @@ package GNAT.Sockets is
Multicast_Loop, -- Sent multicast packets are looped to local socket
Receive_Packet_Info, -- Receive low level packet info as ancillary data
Send_Timeout, -- Set timeout value for output
- Receive_Timeout); -- Set timeout value for input
+ Receive_Timeout, -- Set timeout value for input
+ Busy_Polling); -- Set busy polling mode
+ subtype Specific_Option_Name is
+ Option_Name range Keep_Alive .. Option_Name'Last;
type Option_Type (Name : Option_Name := Keep_Alive) is record
case Name is
+ when Generic_Option =>
+ Optname : Interfaces.C.int := -1;
+ Optval : Interfaces.C.int;
+
when Keep_Alive |
Reuse_Address |
Broadcast |
@@ -711,6 +722,9 @@ package GNAT.Sockets is
null;
end case;
+ when Busy_Polling =>
+ Microseconds : Natural;
+
when Send_Buffer |
Receive_Buffer =>
Size : Natural;
@@ -876,10 +890,12 @@ package GNAT.Sockets is
-- No_Sock_Addr on error (e.g. socket closed or not locally bound).
function Get_Socket_Option
- (Socket : Socket_Type;
- Level : Level_Type := Socket_Level;
- Name : Option_Name) return Option_Type;
- -- Get the options associated with a socket. Raises Socket_Error on error
+ (Socket : Socket_Type;
+ Level : Level_Type := Socket_Level;
+ Name : Option_Name;
+ Optname : Interfaces.C.int := -1) return Option_Type;
+ -- Get the options associated with a socket. Raises Socket_Error on error.
+ -- Optname identifies specific option when Name is Generic_Option.
procedure Listen_Socket
(Socket : Socket_Type;
@@ -1005,7 +1021,11 @@ package GNAT.Sockets is
-- Same interface as Ada.Streams.Stream_IO
function Stream (Socket : Socket_Type) return Stream_Access;
- -- Create a stream associated with an already connected stream-based socket
+ -- Create a stream associated with a connected stream-based socket.
+ -- Note: keep in mind that the default stream attributes for composite
+ -- types perform separate Read/Write operations for each component,
+ -- recursively. If performance is an issue, you may want to consider
+ -- introducing a buffering stage.
function Stream
(Socket : Socket_Type;
@@ -1107,7 +1127,10 @@ package GNAT.Sockets is
--
-- Note that two different Socket_Set_Type objects must be passed as
-- R_Socket_Set and W_Socket_Set (even if they denote the same set of
- -- Sockets), or some event may be lost.
+ -- Sockets), or some event may be lost. Also keep in mind that this
+ -- procedure modifies the passed socket sets to indicate which sockets
+ -- actually had events upon return. The socket set therefore has to
+ -- be reset by the caller for further calls.
--
-- Socket_Error is raised when the select(2) system call returns an error
-- condition, or when a read error occurs on the signalling socket used for
diff --git a/gcc/ada/g-socthi-mingw.adb b/gcc/ada/g-socthi-mingw.adb
index e8ee6dcc63..6ce2fb6cc4 100644
--- a/gcc/ada/g-socthi-mingw.adb
+++ b/gcc/ada/g-socthi-mingw.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2014, AdaCore --
+-- Copyright (C) 2001-2016, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -43,7 +43,6 @@ with System.Storage_Elements; use System.Storage_Elements;
package body GNAT.Sockets.Thin is
use type C.unsigned;
- use type C.int;
WSAData_Dummy : array (1 .. 512) of C.int;
@@ -570,62 +569,60 @@ package body GNAT.Sockets.Thin is
begin
case Errno is
- when EINTR => Errm := Error_Messages (N_EINTR);
- when EBADF => Errm := Error_Messages (N_EBADF);
- when EACCES => Errm := Error_Messages (N_EACCES);
- when EFAULT => Errm := Error_Messages (N_EFAULT);
- when EINVAL => Errm := Error_Messages (N_EINVAL);
- when EMFILE => Errm := Error_Messages (N_EMFILE);
- when EWOULDBLOCK => Errm := Error_Messages (N_EWOULDBLOCK);
- when EINPROGRESS => Errm := Error_Messages (N_EINPROGRESS);
- when EALREADY => Errm := Error_Messages (N_EALREADY);
- when ENOTSOCK => Errm := Error_Messages (N_ENOTSOCK);
- when EDESTADDRREQ => Errm := Error_Messages (N_EDESTADDRREQ);
- when EMSGSIZE => Errm := Error_Messages (N_EMSGSIZE);
- when EPROTOTYPE => Errm := Error_Messages (N_EPROTOTYPE);
- when ENOPROTOOPT => Errm := Error_Messages (N_ENOPROTOOPT);
- when EPROTONOSUPPORT => Errm := Error_Messages (N_EPROTONOSUPPORT);
- when ESOCKTNOSUPPORT => Errm := Error_Messages (N_ESOCKTNOSUPPORT);
- when EOPNOTSUPP => Errm := Error_Messages (N_EOPNOTSUPP);
- when EPFNOSUPPORT => Errm := Error_Messages (N_EPFNOSUPPORT);
- when EAFNOSUPPORT => Errm := Error_Messages (N_EAFNOSUPPORT);
- when EADDRINUSE => Errm := Error_Messages (N_EADDRINUSE);
- when EADDRNOTAVAIL => Errm := Error_Messages (N_EADDRNOTAVAIL);
- when ENETDOWN => Errm := Error_Messages (N_ENETDOWN);
- when ENETUNREACH => Errm := Error_Messages (N_ENETUNREACH);
- when ENETRESET => Errm := Error_Messages (N_ENETRESET);
- when ECONNABORTED => Errm := Error_Messages (N_ECONNABORTED);
- when ECONNRESET => Errm := Error_Messages (N_ECONNRESET);
- when ENOBUFS => Errm := Error_Messages (N_ENOBUFS);
- when EISCONN => Errm := Error_Messages (N_EISCONN);
- when ENOTCONN => Errm := Error_Messages (N_ENOTCONN);
- when ESHUTDOWN => Errm := Error_Messages (N_ESHUTDOWN);
- when ETOOMANYREFS => Errm := Error_Messages (N_ETOOMANYREFS);
- when ETIMEDOUT => Errm := Error_Messages (N_ETIMEDOUT);
- when ECONNREFUSED => Errm := Error_Messages (N_ECONNREFUSED);
- when ELOOP => Errm := Error_Messages (N_ELOOP);
- when ENAMETOOLONG => Errm := Error_Messages (N_ENAMETOOLONG);
- when EHOSTDOWN => Errm := Error_Messages (N_EHOSTDOWN);
- when EHOSTUNREACH => Errm := Error_Messages (N_EHOSTUNREACH);
+ when EINTR => Errm := Error_Messages (N_EINTR);
+ when EBADF => Errm := Error_Messages (N_EBADF);
+ when EACCES => Errm := Error_Messages (N_EACCES);
+ when EFAULT => Errm := Error_Messages (N_EFAULT);
+ when EINVAL => Errm := Error_Messages (N_EINVAL);
+ when EMFILE => Errm := Error_Messages (N_EMFILE);
+ when EWOULDBLOCK => Errm := Error_Messages (N_EWOULDBLOCK);
+ when EINPROGRESS => Errm := Error_Messages (N_EINPROGRESS);
+ when EALREADY => Errm := Error_Messages (N_EALREADY);
+ when ENOTSOCK => Errm := Error_Messages (N_ENOTSOCK);
+ when EDESTADDRREQ => Errm := Error_Messages (N_EDESTADDRREQ);
+ when EMSGSIZE => Errm := Error_Messages (N_EMSGSIZE);
+ when EPROTOTYPE => Errm := Error_Messages (N_EPROTOTYPE);
+ when ENOPROTOOPT => Errm := Error_Messages (N_ENOPROTOOPT);
+ when EPROTONOSUPPORT => Errm := Error_Messages (N_EPROTONOSUPPORT);
+ when ESOCKTNOSUPPORT => Errm := Error_Messages (N_ESOCKTNOSUPPORT);
+ when EOPNOTSUPP => Errm := Error_Messages (N_EOPNOTSUPP);
+ when EPFNOSUPPORT => Errm := Error_Messages (N_EPFNOSUPPORT);
+ when EAFNOSUPPORT => Errm := Error_Messages (N_EAFNOSUPPORT);
+ when EADDRINUSE => Errm := Error_Messages (N_EADDRINUSE);
+ when EADDRNOTAVAIL => Errm := Error_Messages (N_EADDRNOTAVAIL);
+ when ENETDOWN => Errm := Error_Messages (N_ENETDOWN);
+ when ENETUNREACH => Errm := Error_Messages (N_ENETUNREACH);
+ when ENETRESET => Errm := Error_Messages (N_ENETRESET);
+ when ECONNABORTED => Errm := Error_Messages (N_ECONNABORTED);
+ when ECONNRESET => Errm := Error_Messages (N_ECONNRESET);
+ when ENOBUFS => Errm := Error_Messages (N_ENOBUFS);
+ when EISCONN => Errm := Error_Messages (N_EISCONN);
+ when ENOTCONN => Errm := Error_Messages (N_ENOTCONN);
+ when ESHUTDOWN => Errm := Error_Messages (N_ESHUTDOWN);
+ when ETOOMANYREFS => Errm := Error_Messages (N_ETOOMANYREFS);
+ when ETIMEDOUT => Errm := Error_Messages (N_ETIMEDOUT);
+ when ECONNREFUSED => Errm := Error_Messages (N_ECONNREFUSED);
+ when ELOOP => Errm := Error_Messages (N_ELOOP);
+ when ENAMETOOLONG => Errm := Error_Messages (N_ENAMETOOLONG);
+ when EHOSTDOWN => Errm := Error_Messages (N_EHOSTDOWN);
+ when EHOSTUNREACH => Errm := Error_Messages (N_EHOSTUNREACH);
-- Windows-specific error codes
- when WSASYSNOTREADY => Errm := Error_Messages (N_WSASYSNOTREADY);
+ when WSASYSNOTREADY => Errm := Error_Messages (N_WSASYSNOTREADY);
when WSAVERNOTSUPPORTED =>
Errm := Error_Messages (N_WSAVERNOTSUPPORTED);
- when WSANOTINITIALISED =>
+ when WSANOTINITIALISED =>
Errm := Error_Messages (N_WSANOTINITIALISED);
- when WSAEDISCON =>
- Errm := Error_Messages (N_WSAEDISCON);
+ when WSAEDISCON => Errm := Error_Messages (N_WSAEDISCON);
-- h_errno values
- when HOST_NOT_FOUND => Errm := Error_Messages (N_HOST_NOT_FOUND);
- when TRY_AGAIN => Errm := Error_Messages (N_TRY_AGAIN);
- when NO_RECOVERY => Errm := Error_Messages (N_NO_RECOVERY);
- when NO_DATA => Errm := Error_Messages (N_NO_DATA);
-
- when others => Errm := Error_Messages (N_OTHERS);
+ when HOST_NOT_FOUND => Errm := Error_Messages (N_HOST_NOT_FOUND);
+ when TRY_AGAIN => Errm := Error_Messages (N_TRY_AGAIN);
+ when NO_RECOVERY => Errm := Error_Messages (N_NO_RECOVERY);
+ when NO_DATA => Errm := Error_Messages (N_NO_DATA);
+ when others => Errm := Error_Messages (N_OTHERS);
end case;
return Value (Errm);
diff --git a/gcc/ada/g-sothco.ads b/gcc/ada/g-sothco.ads
index 0d77dd75ef..c25f4edc70 100644
--- a/gcc/ada/g-sothco.ads
+++ b/gcc/ada/g-sothco.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2008-2014, AdaCore --
+-- Copyright (C) 2008-2016, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -41,9 +41,6 @@ package GNAT.Sockets.Thin_Common is
package C renames Interfaces.C;
- use type C.int;
- -- This is so we can declare the Failure constant below
-
Success : constant C.int := 0;
Failure : constant C.int := -1;
diff --git a/gcc/ada/g-souinf.ads b/gcc/ada/g-souinf.ads
index 610db23371..83d23d4f67 100644
--- a/gcc/ada/g-souinf.ads
+++ b/gcc/ada/g-souinf.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -79,6 +79,10 @@ package GNAT.Source_Info is
-- package itself. This is useful in identifying and logging information
-- from within generic templates.
+ function Compilation_ISO_Date return String with
+ Import, Convention => Intrinsic;
+ -- Returns date of compilation as a static string "yyyy-mm-dd".
+
function Compilation_Date return String with
Import, Convention => Intrinsic;
-- Returns date of compilation as a static string "mmm dd yyyy". This is
diff --git a/gcc/ada/g-spipat.adb b/gcc/ada/g-spipat.adb
index f11bcfc997..348c8e4e00 100644
--- a/gcc/ada/g-spipat.adb
+++ b/gcc/ada/g-spipat.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2013, AdaCore --
+-- Copyright (C) 1998-2016, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -220,103 +220,130 @@ package body GNAT.Spitbol.Patterns is
-- Successor element, to be matched after this one
case Pcode is
+ when PC_Arb_Y
+ | PC_Assign
+ | PC_Bal
+ | PC_BreakX_X
+ | PC_Cancel
+ | PC_EOP
+ | PC_Fail
+ | PC_Fence
+ | PC_Fence_X
+ | PC_Fence_Y
+ | PC_Null
+ | PC_R_Enter
+ | PC_R_Remove
+ | PC_R_Restore
+ | PC_Rest
+ | PC_Succeed
+ | PC_Unanchored
+ =>
+ null;
+
+ when PC_Alt
+ | PC_Arb_X
+ | PC_Arbno_S
+ | PC_Arbno_X
+ =>
+ Alt : PE_Ptr;
- when PC_Arb_Y |
- PC_Assign |
- PC_Bal |
- PC_BreakX_X |
- PC_Cancel |
- PC_EOP |
- PC_Fail |
- PC_Fence |
- PC_Fence_X |
- PC_Fence_Y |
- PC_Null |
- PC_R_Enter |
- PC_R_Remove |
- PC_R_Restore |
- PC_Rest |
- PC_Succeed |
- PC_Unanchored => null;
-
- when PC_Alt |
- PC_Arb_X |
- PC_Arbno_S |
- PC_Arbno_X => Alt : PE_Ptr;
-
- when PC_Rpat => PP : Pattern_Ptr;
-
- when PC_Pred_Func => BF : Boolean_Func;
-
- when PC_Assign_Imm |
- PC_Assign_OnM |
- PC_Any_VP |
- PC_Break_VP |
- PC_BreakX_VP |
- PC_NotAny_VP |
- PC_NSpan_VP |
- PC_Span_VP |
- PC_String_VP => VP : VString_Ptr;
-
- when PC_Write_Imm |
- PC_Write_OnM => FP : File_Ptr;
-
- when PC_String => Str : String_Ptr;
-
- when PC_String_2 => Str2 : String (1 .. 2);
-
- when PC_String_3 => Str3 : String (1 .. 3);
-
- when PC_String_4 => Str4 : String (1 .. 4);
-
- when PC_String_5 => Str5 : String (1 .. 5);
-
- when PC_String_6 => Str6 : String (1 .. 6);
-
- when PC_Setcur => Var : Natural_Ptr;
-
- when PC_Any_CH |
- PC_Break_CH |
- PC_BreakX_CH |
- PC_Char |
- PC_NotAny_CH |
- PC_NSpan_CH |
- PC_Span_CH => Char : Character;
-
- when PC_Any_CS |
- PC_Break_CS |
- PC_BreakX_CS |
- PC_NotAny_CS |
- PC_NSpan_CS |
- PC_Span_CS => CS : Character_Set;
-
- when PC_Arbno_Y |
- PC_Len_Nat |
- PC_Pos_Nat |
- PC_RPos_Nat |
- PC_RTab_Nat |
- PC_Tab_Nat => Nat : Natural;
-
- when PC_Pos_NF |
- PC_Len_NF |
- PC_RPos_NF |
- PC_RTab_NF |
- PC_Tab_NF => NF : Natural_Func;
-
- when PC_Pos_NP |
- PC_Len_NP |
- PC_RPos_NP |
- PC_RTab_NP |
- PC_Tab_NP => NP : Natural_Ptr;
-
- when PC_Any_VF |
- PC_Break_VF |
- PC_BreakX_VF |
- PC_NotAny_VF |
- PC_NSpan_VF |
- PC_Span_VF |
- PC_String_VF => VF : VString_Func;
+ when PC_Rpat =>
+ PP : Pattern_Ptr;
+
+ when PC_Pred_Func =>
+ BF : Boolean_Func;
+
+ when PC_Assign_Imm
+ | PC_Assign_OnM
+ | PC_Any_VP
+ | PC_Break_VP
+ | PC_BreakX_VP
+ | PC_NotAny_VP
+ | PC_NSpan_VP
+ | PC_Span_VP
+ | PC_String_VP
+ =>
+ VP : VString_Ptr;
+
+ when PC_Write_Imm
+ | PC_Write_OnM
+ =>
+ FP : File_Ptr;
+
+ when PC_String =>
+ Str : String_Ptr;
+
+ when PC_String_2 =>
+ Str2 : String (1 .. 2);
+
+ when PC_String_3 =>
+ Str3 : String (1 .. 3);
+
+ when PC_String_4 =>
+ Str4 : String (1 .. 4);
+ when PC_String_5 =>
+ Str5 : String (1 .. 5);
+
+ when PC_String_6 =>
+ Str6 : String (1 .. 6);
+
+ when PC_Setcur =>
+ Var : Natural_Ptr;
+
+ when PC_Any_CH
+ | PC_Break_CH
+ | PC_BreakX_CH
+ | PC_Char
+ | PC_NotAny_CH
+ | PC_NSpan_CH
+ | PC_Span_CH
+ =>
+ Char : Character;
+
+ when PC_Any_CS
+ | PC_Break_CS
+ | PC_BreakX_CS
+ | PC_NotAny_CS
+ | PC_NSpan_CS
+ | PC_Span_CS
+ =>
+ CS : Character_Set;
+
+ when PC_Arbno_Y
+ | PC_Len_Nat
+ | PC_Pos_Nat
+ | PC_RPos_Nat
+ | PC_RTab_Nat
+ | PC_Tab_Nat
+ =>
+ Nat : Natural;
+
+ when PC_Pos_NF
+ | PC_Len_NF
+ | PC_RPos_NF
+ | PC_RTab_NF
+ | PC_Tab_NF
+ =>
+ NF : Natural_Func;
+
+ when PC_Pos_NP
+ | PC_Len_NP
+ | PC_RPos_NP
+ | PC_RTab_NP
+ | PC_Tab_NP
+ =>
+ NP : Natural_Ptr;
+
+ when PC_Any_VF
+ | PC_Break_VF
+ | PC_BreakX_VF
+ | PC_NotAny_VF
+ | PC_NSpan_VF
+ | PC_Span_VF
+ | PC_String_VF
+ =>
+ VF : VString_Func;
end case;
end record;
@@ -1241,13 +1268,13 @@ package body GNAT.Spitbol.Patterns is
-- Called to raise Program_Error with an appropriate message if an
-- internal logic error is detected.
- function Str_BF (A : Boolean_Func) return String;
- function Str_FP (A : File_Ptr) return String;
- function Str_NF (A : Natural_Func) return String;
- function Str_NP (A : Natural_Ptr) return String;
- function Str_PP (A : Pattern_Ptr) return String;
- function Str_VF (A : VString_Func) return String;
- function Str_VP (A : VString_Ptr) return String;
+ function Str_BF (A : Boolean_Func) return String;
+ function Str_FP (A : File_Ptr) return String;
+ function Str_NF (A : Natural_Func) return String;
+ function Str_NP (A : Natural_Ptr) return String;
+ function Str_PP (A : Pattern_Ptr) return String;
+ function Str_VF (A : VString_Func) return String;
+ function Str_VP (A : VString_Ptr) return String;
-- These are debugging routines, which return a representation of the
-- given access value (they are called only by Image and Dump)
@@ -2163,11 +2190,11 @@ package body GNAT.Spitbol.Patterns is
Set_Col (24 + 2 * Count (Cols) + Address_Image_Length);
case E.Pcode is
-
- when PC_Alt |
- PC_Arb_X |
- PC_Arbno_S |
- PC_Arbno_X =>
+ when PC_Alt
+ | PC_Arb_X
+ | PC_Arbno_S
+ | PC_Arbno_X
+ =>
Write_Node_Id (E.Alt);
when PC_Rpat =>
@@ -2176,19 +2203,21 @@ package body GNAT.Spitbol.Patterns is
when PC_Pred_Func =>
Put (Str_BF (E.BF));
- when PC_Assign_Imm |
- PC_Assign_OnM |
- PC_Any_VP |
- PC_Break_VP |
- PC_BreakX_VP |
- PC_NotAny_VP |
- PC_NSpan_VP |
- PC_Span_VP |
- PC_String_VP =>
+ when PC_Assign_Imm
+ | PC_Assign_OnM
+ | PC_Any_VP
+ | PC_Break_VP
+ | PC_BreakX_VP
+ | PC_NotAny_VP
+ | PC_NSpan_VP
+ | PC_Span_VP
+ | PC_String_VP
+ =>
Put (Str_VP (E.VP));
- when PC_Write_Imm |
- PC_Write_OnM =>
+ when PC_Write_Imm
+ | PC_Write_OnM
+ =>
Put (Str_FP (E.FP));
when PC_String =>
@@ -2212,56 +2241,62 @@ package body GNAT.Spitbol.Patterns is
when PC_Setcur =>
Put (Str_NP (E.Var));
- when PC_Any_CH |
- PC_Break_CH |
- PC_BreakX_CH |
- PC_Char |
- PC_NotAny_CH |
- PC_NSpan_CH |
- PC_Span_CH =>
+ when PC_Any_CH
+ | PC_Break_CH
+ | PC_BreakX_CH
+ | PC_Char
+ | PC_NotAny_CH
+ | PC_NSpan_CH
+ | PC_Span_CH
+ =>
Put (''' & E.Char & ''');
- when PC_Any_CS |
- PC_Break_CS |
- PC_BreakX_CS |
- PC_NotAny_CS |
- PC_NSpan_CS |
- PC_Span_CS =>
+ when PC_Any_CS
+ | PC_Break_CS
+ | PC_BreakX_CS
+ | PC_NotAny_CS
+ | PC_NSpan_CS
+ | PC_Span_CS
+ =>
Put ('"' & To_Sequence (E.CS) & '"');
- when PC_Arbno_Y |
- PC_Len_Nat |
- PC_Pos_Nat |
- PC_RPos_Nat |
- PC_RTab_Nat |
- PC_Tab_Nat =>
+ when PC_Arbno_Y
+ | PC_Len_Nat
+ | PC_Pos_Nat
+ | PC_RPos_Nat
+ | PC_RTab_Nat
+ | PC_Tab_Nat
+ =>
Put (S (E.Nat));
- when PC_Pos_NF |
- PC_Len_NF |
- PC_RPos_NF |
- PC_RTab_NF |
- PC_Tab_NF =>
+ when PC_Pos_NF
+ | PC_Len_NF
+ | PC_RPos_NF
+ | PC_RTab_NF
+ | PC_Tab_NF
+ =>
Put (Str_NF (E.NF));
- when PC_Pos_NP |
- PC_Len_NP |
- PC_RPos_NP |
- PC_RTab_NP |
- PC_Tab_NP =>
+ when PC_Pos_NP
+ | PC_Len_NP
+ | PC_RPos_NP
+ | PC_RTab_NP
+ | PC_Tab_NP
+ =>
Put (Str_NP (E.NP));
- when PC_Any_VF |
- PC_Break_VF |
- PC_BreakX_VF |
- PC_NotAny_VF |
- PC_NSpan_VF |
- PC_Span_VF |
- PC_String_VF =>
+ when PC_Any_VF
+ | PC_Break_VF
+ | PC_BreakX_VF
+ | PC_NotAny_VF
+ | PC_NSpan_VF
+ | PC_Span_VF
+ | PC_String_VF
+ =>
Put (Str_VF (E.VF));
- when others => null;
-
+ when others =>
+ null;
end case;
New_Line;
@@ -2409,7 +2444,6 @@ package body GNAT.Spitbol.Patterns is
begin
case E.Pcode is
-
when PC_Cancel =>
Append (Result, "Cancel");
@@ -2668,17 +2702,17 @@ package body GNAT.Spitbol.Patterns is
-- Other pattern codes should not appear as leading elements
- when PC_Arb_Y |
- PC_Arbno_Y |
- PC_Assign |
- PC_BreakX_X |
- PC_EOP |
- PC_Fence_Y |
- PC_R_Remove |
- PC_R_Restore |
- PC_Unanchored =>
+ when PC_Arb_Y
+ | PC_Arbno_Y
+ | PC_Assign
+ | PC_BreakX_X
+ | PC_EOP
+ | PC_Fence_Y
+ | PC_R_Remove
+ | PC_R_Restore
+ | PC_Unanchored
+ =>
Append (Result, "???");
-
end case;
E := ER;
@@ -3450,7 +3484,6 @@ package body GNAT.Spitbol.Patterns is
when others =>
return new PE'(PC_String, 1, EOP, new String'(Str));
-
end case;
end S_To_PE;
@@ -3998,7 +4031,7 @@ package body GNAT.Spitbol.Patterns is
-- Arb (extension)
- when PC_Arb_Y =>
+ when PC_Arb_Y =>
if Cursor < Length then
Cursor := Cursor + 1;
Push (Node);
@@ -4916,7 +4949,6 @@ package body GNAT.Spitbol.Patterns is
Pop_Region;
Assign_OnM := True;
goto Succeed;
-
end case;
-- We are NOT allowed to fall though this case statement, since every
@@ -5315,8 +5347,7 @@ package body GNAT.Spitbol.Patterns is
-- Alternation
when PC_Alt =>
- Dout
- (Img (Node) & "setting up alternative " & Img (Node.Alt));
+ Dout (Img (Node) & "setting up alternative " & Img (Node.Alt));
Push (Node.Alt);
Node := Node.Pthen;
goto Match;
@@ -6437,7 +6468,6 @@ package body GNAT.Spitbol.Patterns is
Pop_Region;
Assign_OnM := True;
goto Succeed;
-
end case;
-- We are NOT allowed to fall though this case statement, since every
diff --git a/gcc/ada/g-spitbo.adb b/gcc/ada/g-spitbo.adb
index 22677149ee..26753bd0b1 100644
--- a/gcc/ada/g-spitbo.adb
+++ b/gcc/ada/g-spitbo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2012, AdaCore --
+-- Copyright (C) 1998-2016, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -333,7 +333,7 @@ package body GNAT.Spitbol is
-- Adjust --
------------
- procedure Adjust (Object : in out Table) is
+ overriding procedure Adjust (Object : in out Table) is
Ptr1 : Hash_Element_Ptr;
Ptr2 : Hash_Element_Ptr;
@@ -555,7 +555,7 @@ package body GNAT.Spitbol is
-- Finalize --
--------------
- procedure Finalize (Object : in out Table) is
+ overriding procedure Finalize (Object : in out Table) is
Ptr1 : Hash_Element_Ptr;
Ptr2 : Hash_Element_Ptr;
diff --git a/gcc/ada/g-spitbo.ads b/gcc/ada/g-spitbo.ads
index e97bb62d03..b07a21451f 100644
--- a/gcc/ada/g-spitbo.ads
+++ b/gcc/ada/g-spitbo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1997-2012, AdaCore --
+-- Copyright (C) 1997-2016, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -379,12 +379,12 @@ package GNAT.Spitbol is
pragma Finalize_Storage_Only (Table);
- procedure Adjust (Object : in out Table);
+ overriding procedure Adjust (Object : in out Table);
-- The Adjust procedure does a deep copy of the table structure
-- so that the effect of assignment is, like other assignments
-- in Ada, value-oriented.
- procedure Finalize (Object : in out Table);
+ overriding procedure Finalize (Object : in out Table);
-- This is the finalization routine that ensures that all storage
-- associated with a table is properly released when a table object
-- is abandoned and finalized.
diff --git a/gcc/ada/g-traceb.ads b/gcc/ada/g-traceb.ads
index 98d11a8ef9..e71a0552cf 100644
--- a/gcc/ada/g-traceb.ads
+++ b/gcc/ada/g-traceb.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2014, AdaCore --
+-- Copyright (C) 1999-2016, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -58,14 +58,18 @@
-- This capability is currently supported on the following targets:
-- AiX PowerPC
--- HP-UX
-- GNU/Linux x86
+-- GNU/Linux PowerPC
-- LynxOS x86
+-- LynxOS 178 xcoff PowerPC
+-- LynxOS 178 elf PowerPC
-- Solaris x86
-- Solaris sparc
+-- VxWorks ARM
+-- VxWorks7 ARM
-- VxWorks PowerPC
-- VxWorks x86
--- Windows NT/XP
+-- Windows XP
-- Note: see also GNAT.Traceback.Symbolic, a child unit in file g-trasym.ads
-- providing symbolic trace back capability for a subset of the above targets.
diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in
index a8ce672249..eb0489b4a5 100644
--- a/gcc/ada/gcc-interface/Make-lang.in
+++ b/gcc/ada/gcc-interface/Make-lang.in
@@ -175,10 +175,10 @@ else
# or a cross-native compiler. We provide defaults for tools targeting the
# host platform, but they can be overriden by just setting <tool>_FOR_HOST
# variables.
- GNATMAKE_FOR_HOST=$(host)-gnatmake
- GNATBIND_FOR_HOST=$(host)-gnatbind
- GNATLINK_FOR_HOST=$(host)-gnatlink
- GNATLS_FOR_HOST=$(host)-gnatls
+ GNATMAKE_FOR_HOST=$(host_noncanonical)-gnatmake
+ GNATBIND_FOR_HOST=$(host_noncanonical)-gnatbind
+ GNATLINK_FOR_HOST=$(host_noncanonical)-gnatlink
+ GNATLS_FOR_HOST=$(host_noncanonical)-gnatls
ifeq ($(host), $(target))
# This is a cross native. All the sources are taken from the currently
@@ -863,11 +863,15 @@ ada.stagefeedback: stagefeedback-start
-$(MV) ada/stamp-* stagefeedback/ada
lang_checks += check-gnat
+lang_checks_parallelized += check-gnat
+# For description see the check_$lang_parallelize comment in gcc/Makefile.in.
+check_gnat_parallelize = 1000
check-ada: check-acats check-gnat
check-ada-subtargets: check-acats-subtargets check-gnat-subtargets
ACATSDIR = $(TESTSUITEDIR)/ada/acats
+ACATSCMD = run_acats.sh
check_acats_numbers0:=1 2 3 4 5 6 7 8 9
check_acats_numbers1:=0 $(check_acats_numbers0)
@@ -886,13 +890,13 @@ check-acats:
@test -d $(ACATSDIR) || mkdir -p $(ACATSDIR); \
rootme=`${PWD_COMMAND}`; export rootme; \
EXPECT=$(EXPECT); export EXPECT; \
- if [ -z "$(CHAPTERS)" ] && [ "$(filter -j, $(MFLAGS))" = "-j" ]; \
+ if [ -z "$(CHAPTERS)" ] && [ -n "$(filter -j%, $(MFLAGS))" ]; \
then \
rm -rf $(ACATSDIR)-parallel; \
mkdir $(ACATSDIR)-parallel; \
( testdir=`cd ${srcdir}/${ACATSDIR} && ${PWD_COMMAND}`; \
export testdir; \
- cd $(ACATSDIR) && $(SHELL) $${testdir}/run_acats NONE ) \
+ cd $(ACATSDIR) && $(SHELL) $${testdir}/$(ACATSCMD) NONE ) \
|| exit 1; \
GCC_RUNTEST_PARALLELIZE_DIR=$$rootme/$(ACATSDIR)-parallel; \
export GCC_RUNTEST_PARALLELIZE_DIR; \
@@ -913,7 +917,7 @@ check-acats:
exit 0; \
fi; \
testdir=`cd ${srcdir}/${ACATSDIR} && ${PWD_COMMAND}`; \
- export testdir; cd $(ACATSDIR) && $(SHELL) $${testdir}/run_acats $(CHAPTERS)
+ export testdir; cd $(ACATSDIR) && $(SHELL) $${testdir}/$(ACATSCMD) $(CHAPTERS)
check-acats-subtargets:
@echo check-acats
@@ -925,7 +929,7 @@ $(check_acats_targets): check-acats%:
fi; \
test -d $(ACATSDIR)$* || mkdir -p $(ACATSDIR)$*; \
testdir=`cd ${srcdir}/${ACATSDIR} && ${PWD_COMMAND}`; \
- export testdir; cd $(ACATSDIR)$* && $(SHELL) $${testdir}/run_acats
+ export testdir; cd $(ACATSDIR)$* && $(SHELL) $${testdir}/$(ACATSCMD)
touch $$GCC_RUNTEST_PARALLELIZE_DIR/finished
.PHONY: check-acats $(check_acats_targets)
diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in
index 8996dd1bef..5f570cf34c 100644
--- a/gcc/ada/gcc-interface/Makefile.in
+++ b/gcc/ada/gcc-interface/Makefile.in
@@ -107,6 +107,7 @@ ADA_CFLAGS =
ADAFLAGS = -W -Wall -gnatpg -gnata
FORCE_DEBUG_ADAFLAGS = -g
NO_INLINE_ADAFLAGS = -fno-inline
+NO_OMIT_ADAFLAGS = -fno-omit-frame-pointer
NO_SIBLING_ADAFLAGS = -fno-optimize-sibling-calls
NO_REORDER_ADAFLAGS = -fno-toplevel-reorder
GNATLIBFLAGS = -W -Wall -gnatpg -nostdinc
@@ -434,6 +435,7 @@ X86_64_TARGET_PAIRS = \
a-numaux.adb<a-numaux-x86.adb \
s-atocou.adb<s-atocou-builtin.adb
+# Shared library version
LIB_VERSION = $(strip $(shell grep ' Library_Version :' $(fsrcpfx)ada/gnatvsn.ads | sed -e 's/.*"\(.*\)".*/\1/'))
# Additionnal object files from C source to be added to libgnat.
@@ -444,14 +446,23 @@ EXTRA_LIBGNAT_OBJS=
# specific header files required to rebuild the runtime library from sources.
EXTRA_LIBGNAT_SRCS=
+# Additionnal object files from Ada sources to be added in libgnat
+EXTRA_GNATRTL_NONTASKING_OBJS=
+
+# Additionnal object files from Ada sources to be added in libgnarl
+EXTRA_GNATRTL_TASKING_OBJS=
+
+# Subsets of extra libgnat sources that always go together
+VX_SIGTRAMP_EXTRA_SRCS=sigtramp.h sigtramp-vxworks-target.inc
+
+# Additional object files that should go in the same directory as libgnat,
+# aside the library itself. Typically useful for crtbegin/crtend kind of files.
+EXTRA_ADALIB_OBJS=
+
+VX_CRTBE_EXTRA_ADALIB_OBJS=vx_crtbegin.o vx_crtbegin_auto.o vx_crtend.o
+
# GCC spec files to be installed in $(libsubdir), so --specs=<spec-filename>
-# finds them at runtime. Sequences of alphanum characters prefixed with '_' in
-# the filename are stripped off at installation time. This is used to strip
-# the architecture indications in vxsim spec filenames, installing e.g.
-# vxsim_ppc.spec as vxsim.spec. This allows setting up pretty general self
-# specs to perform -vxsim -> --specs=<...> translations without causing
-# conflicts since the specs are installed in a target specific subdirectory.
-#
+# finds them at runtime.
GCC_SPEC_FILES=
# $(filter-out PATTERN...,TEXT) removes all PATTERN words from TEXT.
@@ -464,7 +475,7 @@ ifeq ($(strip $(filter-out m68k% wrs vx%,$(target_cpu) $(target_vendor) $(target
a-intnam.ads<a-intnam-vxworks.ads \
a-numaux.ads<a-numaux-vxworks.ads \
s-inmaop.adb<s-inmaop-vxworks.adb \
- s-interr.adb<s-interr-hwint.adb \
+ s-interr.adb<s-interr-vxworks.adb \
s-intman.ads<s-intman-vxworks.ads \
s-intman.adb<s-intman-vxworks.adb \
s-osinte.adb<s-osinte-vxworks.adb \
@@ -486,8 +497,8 @@ ifeq ($(strip $(filter-out m68k% wrs vx%,$(target_cpu) $(target_vendor) $(target
TOOLS_TARGET_PAIRS=mlib-tgt-specific.adb<mlib-tgt-specific-vxworks.adb
- EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o
- EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o s-vxwext.o
+ EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o s-stchop.o
+ EXTRA_GNATRTL_TASKING_OBJS=i-vxinco.o s-vxwork.o s-vxwext.o
EXTRA_LIBGNAT_OBJS+=vx_stack_info.o
@@ -502,7 +513,7 @@ ifeq ($(strip $(filter-out m68k% wrs vx%,$(target_cpu) $(target_vendor) $(target
endif
# PowerPC and e500v2 VxWorks
-ifeq ($(strip $(filter-out powerpc% wrs vxworks vxworks7,$(target_cpu) $(target_vendor) $(target_os))),)
+ifeq ($(strip $(filter-out powerpc% wrs vxworks vxworksspe vxworks7 vxworks7spe,$(target_cpu) $(target_vendor) $(target_os))),)
ifeq ($(strip $(filter-out e500%, $(target_alias))),)
ARCH_STR=e500
@@ -548,6 +559,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks vxworks7,$(target_cpu) $(target_
LIBGNAT_TARGET_PAIRS += \
s-stchop.ads<s-stchop-limit.ads \
s-stchop.adb<s-stchop-vxworks.adb
+ EXTRA_GNATRTL_NONTASKING_OBJS+=s-stchop.o
endif
TOOLS_TARGET_PAIRS=\
@@ -571,7 +583,6 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks vxworks7,$(target_cpu) $(target_
system.ads<system-vxworks-$(ARCH_STR)-rtp.ads
EH_MECHANISM=-gcc
- EXTRA_LIBGNAT_OBJS+=sigtramp-vxworks.o
else
ifeq ($(strip $(filter-out rtp-smp,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS += \
@@ -582,12 +593,11 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks vxworks7,$(target_cpu) $(target_
system.ads<$(SVX)-$(ARCH_STR)-rtp-smp.ads
EH_MECHANISM=-gcc
- EXTRA_LIBGNAT_OBJS+=affinity.o sigtramp-vxworks.o
- EXTRA_LIBGNAT_SRCS+=sigtramp.h
+ EXTRA_LIBGNAT_OBJS+=affinity.o
else
ifeq ($(strip $(filter-out kernel-smp,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS += \
- s-interr.adb<s-interr-hwint.adb \
+ s-interr.adb<s-interr-vxworks.adb \
s-mudido.adb<s-mudido-affinity.adb \
s-tpopsp.adb<s-tpopsp-vxworks-tls.adb \
s-vxwext.ads<s-vxwext-kernel.ads \
@@ -598,7 +608,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks vxworks7,$(target_cpu) $(target_
EXTRA_LIBGNAT_OBJS+=affinity.o
else
LIBGNAT_TARGET_PAIRS += \
- s-interr.adb<s-interr-hwint.adb \
+ s-interr.adb<s-interr-vxworks.adb \
s-tpopsp.adb<s-tpopsp-vxworks.adb
ifeq ($(strip $(filter-out kernel,$(THREAD_KIND))),)
@@ -612,9 +622,8 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks vxworks7,$(target_cpu) $(target_
system.ads<system-vxworks-ppc.ads
endif
endif
- EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o
- EXTRA_LIBGNAT_OBJS+=sigtramp-vxworks.o
- EXTRA_LIBGNAT_SRCS+=sigtramp.h
+ EXTRA_GNATRTL_NONTASKING_OBJS=i-vxinco.o i-vxwork.o i-vxwoio.o
+ EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o s-vxwext.o
endif
endif
@@ -622,8 +631,17 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks vxworks7,$(target_cpu) $(target_
EXTRA_LIBGNAT_OBJS+=vx_stack_info.o
- GCC_SPEC_FILES+=vxworks-$(ARCH_STR)-link.spec
- GCC_SPEC_FILES+=vxworks-crtbe-link.spec
+ EXTRA_ADALIB_OBJS+=$(VX_CRTBE_EXTRA_ADALIB_OBJS)
+ EXTRA_LIBGNAT_SRCS+=vx_crtbegin.inc
+ GCC_SPEC_FILES+=vxworks-gnat-crtbe-link.spec
+
+ ifeq ($(strip $(filter-out vxworks7%, $(target_os))),)
+ GCC_SPEC_FILES+=vxworks7-rtp-base-link.spec
+ else
+ GCC_SPEC_FILES+=vxworks-$(ARCH_STR)-link.spec
+ GCC_SPEC_FILES+=vxworks-cert-$(ARCH_STR)-link.spec
+ GCC_SPEC_FILES+=vxworks-smp-$(ARCH_STR)-link.spec
+ endif
endif
# PowerPC and e500v2 VxWorks 653
@@ -642,7 +660,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworksae,$(target_cpu) $(target_vendor)
a-numaux.ads<a-numaux-vxworks.ads \
g-io.adb<g-io-vxworks-ppc-cert.adb \
s-inmaop.adb<s-inmaop-vxworks.adb \
- s-interr.adb<s-interr-hwint.adb \
+ s-interr.adb<s-interr-vxworks.adb \
s-intman.ads<s-intman-vxworks.ads \
s-intman.adb<s-intman-vxworks.adb \
s-osinte.adb<s-osinte-vxworks.adb \
@@ -661,15 +679,17 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworksae,$(target_cpu) $(target_vendor)
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS)
+ EH_MECHANISM=-gcc
+
TOOLS_TARGET_PAIRS=\
mlib-tgt-specific.adb<mlib-tgt-specific-vxworks.adb \
indepsw.adb<indepsw-gnu.adb
EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o
- EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o s-vxwext.o
+ EXTRA_GNATRTL_TASKING_OBJS=i-vxinco.o s-vxwork.o s-vxwext.o
EXTRA_LIBGNAT_OBJS+=sigtramp-vxworks.o
- EXTRA_LIBGNAT_SRCS+=sigtramp.h
+ EXTRA_LIBGNAT_SRCS+=$(VX_SIGTRAMP_EXTRA_SRCS)
# Extra pairs for the vthreads runtime
ifeq ($(strip $(filter-out vthreads,$(THREAD_KIND))),)
@@ -706,12 +726,13 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworksmils,$(target_cpu) $(target_vendo
a-numaux.ads<a-numaux-vxworks.ads \
g-io.adb<g-io-vxworks-ppc-cert.adb \
s-inmaop.adb<s-inmaop-vxworks.adb \
- s-interr.adb<s-interr-hwint.adb \
+ s-interr.adb<s-interr-vxworks.adb \
s-intman.ads<s-intman-vxworks.ads \
s-intman.adb<s-intman-vxworks.adb \
s-osinte.adb<s-osinte-vxworks.adb \
s-osinte.ads<s-osinte-vxworks.ads \
s-osprim.adb<s-osprim-vxworks.adb \
+ s-osvers.ads<s-osvers-vxworks-mils.ads \
s-parame.ads<s-parame-ae653.ads \
s-parame.adb<s-parame-vxworks.adb \
s-stchop.adb<s-stchop-vxworks.adb \
@@ -720,7 +741,6 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworksmils,$(target_cpu) $(target_vendo
s-tasinf.ads<s-tasinf-vxworks.ads \
s-taspri.ads<s-taspri-vxworks.ads \
s-thread.adb<s-thread-ae653.adb \
- s-osvers.ads<s-osvers-vxworks-mils.ads \
s-tpopsp.adb<s-tpopsp-vxworks.adb \
s-vxwork.ads<s-vxwork-ppc.ads \
system.ads<system-vxworks-ppc-mils.ads \
@@ -732,11 +752,15 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworksmils,$(target_cpu) $(target_vendo
mlib-tgt-specific.adb<mlib-tgt-specific-vxworks.adb \
indepsw.adb<indepsw-gnu.adb
- EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o s-thread.o s-osvers.o
- EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o s-vxwext.o
+ EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o \
+ s-thread.o s-osvers.o s-stchop.o
+ EXTRA_GNATRTL_TASKING_OBJS=i-vxinco.o s-vxwork.o s-vxwext.o
+
+ EXTRA_LIBGNAT_OBJS+=vx_stack_info.o
+
+ EXTRA_LIBGNAT_OBJS+=sigtramp-vxworks.o
+ EXTRA_LIBGNAT_SRCS+=$(VX_SIGTRAMP_EXTRA_SRCS)
- EXTRA_LIBGNAT_OBJS+=vx_stack_info.o sigtramp-vxworks.o
- EXTRA_LIBGNAT_SRCS+=sigtramp.h
GNATRTL_SOCKETS_OBJS =
ifeq ($(strip $(filter-out yes,$(TRACE))),)
@@ -758,7 +782,7 @@ ifeq ($(strip $(filter-out %86 wrs vxworksae,$(target_cpu) $(target_vendor) $(ta
a-numaux.ads<a-numaux-vxworks.ads \
g-io.adb<g-io-vxworks-ppc-cert.adb \
s-inmaop.adb<s-inmaop-vxworks.adb \
- s-interr.adb<s-interr-hwint.adb \
+ s-interr.adb<s-interr-vxworks.adb \
s-intman.ads<s-intman-vxworks.ads \
s-intman.adb<s-intman-vxworks.adb \
s-osinte.adb<s-osinte-vxworks.adb \
@@ -777,12 +801,14 @@ ifeq ($(strip $(filter-out %86 wrs vxworksae,$(target_cpu) $(target_vendor) $(ta
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS)
+ EH_MECHANISM=-gcc
+
TOOLS_TARGET_PAIRS=\
mlib-tgt-specific.adb<mlib-tgt-specific-vxworks.adb \
indepsw.adb<indepsw-gnu.adb
EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o s-thread.o
- EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o s-vxwext.o
+ EXTRA_GNATRTL_TASKING_OBJS=i-vxinco.o s-vxwork.o s-vxwext.o
EXTRA_LIBGNAT_OBJS+=vx_stack_info.o
GNATRTL_SOCKETS_OBJS =
@@ -819,7 +845,7 @@ ifeq ($(strip $(filter-out sparc% wrs vx%,$(target_cpu) $(target_vendor) $(targe
a-intnam.ads<a-intnam-vxworks.ads \
a-numaux.ads<a-numaux-vxworks.ads \
s-inmaop.adb<s-inmaop-vxworks.adb \
- s-interr.adb<s-interr-hwint.adb \
+ s-interr.adb<s-interr-vxworks.adb \
s-intman.ads<s-intman-vxworks.ads \
s-intman.adb<s-intman-vxworks.adb \
s-osinte.adb<s-osinte-vxworks.adb \
@@ -859,27 +885,32 @@ ifeq ($(strip $(filter-out sparc% wrs vx%,$(target_cpu) $(target_vendor) $(targe
s-vxwext.adb<s-vxwext-kernel.adb
endif
- EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o
- EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o s-vxwext.o
+ EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o s-stchop.o
+ EXTRA_GNATRTL_TASKING_OBJS=i-vxinco.o s-vxwork.o s-vxwext.o
EXTRA_LIBGNAT_OBJS+=vx_stack_info.o
endif
-# x86 VxWorks
-ifeq ($(strip $(filter-out %86 wrs vxworks vxworks7,$(target_cpu) $(target_vendor) $(target_os))),)
+# x86/x86_64 VxWorks
+ifeq ($(strip $(filter-out %86 x86_64 wrs vxworks vxworks7,$(target_cpu) $(target_vendor) $(target_os))),)
+
+ EH_MECHANISM=-gcc
ifeq ($(strip $(filter-out vxworks7%, $(target_os))),)
SVX=system-vxworks7
else
SVX=system-vxworks
- EH_MECHANISM=-gcc
endif
- EXTRA_LIBGNAT_OBJS+=sigtramp-vxworks.o sigtramp-vxworks-vxsim.o
- EXTRA_LIBGNAT_OBJS+=init-vxsim.o
- EXTRA_LIBGNAT_SRCS+=sigtramp.h sigtramp-vxworks-target.inc
+ ifeq ($(strip $(filter-out x86_64, $(target_cpu))),)
+ X86CPU=x86_64
+ LIBGNAT_TARGET_PAIRS=s-atocou.adb<s-atocou-builtin.adb
+ else
+ X86CPU=x86
+ LIBGNAT_TARGET_PAIRS=s-atocou.adb<s-atocou-x86.adb
+ endif
- LIBGNAT_TARGET_PAIRS = \
+ LIBGNAT_TARGET_PAIRS+= \
a-intnam.ads<a-intnam-vxworks.ads \
i-vxwork.ads<i-vxwork-x86.ads \
s-osinte.adb<s-osinte-vxworks.adb \
@@ -900,7 +931,9 @@ ifeq ($(strip $(filter-out %86 wrs vxworks vxworks7,$(target_cpu) $(target_vendo
g-socthi.adb<g-socthi-vxworks.adb \
g-stsifd.adb<g-stsifd-sockets.adb \
$(ATOMICS_TARGET_PAIRS) \
- $(X86_TARGET_PAIRS)
+ $(CERTMATH_TARGET_PAIRS) \
+ $(CERTMATH_TARGET_PAIRS_SQRT_FPU) \
+ $(CERTMATH_TARGET_PAIRS_X86TRA)
TOOLS_TARGET_PAIRS=\
mlib-tgt-specific.adb<mlib-tgt-specific-vxworks.adb \
@@ -933,23 +966,23 @@ ifeq ($(strip $(filter-out %86 wrs vxworks vxworks7,$(target_cpu) $(target_vendo
# runtime to be called if a program is running on VxSim vs real hardware
# (due to differences in signal context for unwinding).
- VXSIM_CPU =
-
- ifeq ($(strip $(filter-out vxworks rtp rtp-smp,$(target_os) $(THREAD_KIND))),)
+ ifneq ($(strip $(filter-out vxworks7, $(target_os))),)
+ ifeq ($(strip $(filter-out vxworks rtp rtp-smp,$(target_os) $(THREAD_KIND))),)
VXSIM_CPU = SIMPENTIUM
- else
- ifeq ($(strip $(filter-out kernel kernel-smp rtp rtp-smp,$(THREAD_KIND))),)
- ifeq ($(strip $(filter-out linux%,$(host_os))),)
- # Linux
- VXSIM_CPU = SIMLINUX
- else
- # Windows
- VXSIM_CPU = SIMNT
+ else
+ ifeq ($(strip $(filter-out kernel kernel-smp rtp rtp-smp,$(THREAD_KIND))),)
+ ifeq ($(strip $(filter-out linux%,$(host_os))),)
+ # Linux
+ VXSIM_CPU = SIMLINUX
+ else
+ # Windows
+ VXSIM_CPU = SIMNT
+ endif
endif
endif
- endif
- GNATLIBCFLAGS_FOR_C := $(GNATLIBCFLAGS_FOR_C) -D__VXSIM_CPU__=$(VXSIM_CPU)
+ GNATLIBCFLAGS_FOR_C := $(GNATLIBCFLAGS_FOR_C) -D__VXSIM_CPU__=$(VXSIM_CPU)
+ endif
ifeq ($(strip $(filter-out rtp,$(THREAD_KIND))),)
# Runtime N/A for VxWorks7 (non-existent system file)
@@ -957,7 +990,7 @@ ifeq ($(strip $(filter-out %86 wrs vxworks vxworks7,$(target_cpu) $(target_vendo
s-vxwext.ads<s-vxwext-rtp.ads \
s-vxwext.adb<s-vxwext-rtp.adb \
s-tpopsp.adb<s-tpopsp-vxworks-rtp.adb \
- system.ads<$(SVX)-x86-rtp.ads
+ system.ads<system-vxworks-x86-rtp.ads
else
ifeq ($(strip $(filter-out rtp-smp, $(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS += \
@@ -965,23 +998,23 @@ ifeq ($(strip $(filter-out %86 wrs vxworks vxworks7,$(target_cpu) $(target_vendo
s-vxwext.ads<s-vxwext-rtp.ads \
s-vxwext.adb<s-vxwext-rtp-smp.adb \
s-tpopsp.adb<s-tpopsp-vxworks-tls.adb \
- system.ads<$(SVX)-x86-rtp-smp.ads
+ system.ads<$(SVX)-$(X86CPU)-rtp-smp.ads
EXTRA_LIBGNAT_OBJS+=affinity.o
else
ifeq ($(strip $(filter-out kernel-smp, $(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS += \
- s-interr.adb<s-interr-hwint.adb \
+ s-interr.adb<s-interr-vxworks.adb \
s-mudido.adb<s-mudido-affinity.adb \
s-tpopsp.adb<s-tpopsp-vxworks-tls.adb \
s-vxwext.ads<s-vxwext-kernel.ads \
s-vxwext.adb<s-vxwext-kernel-smp.adb \
- system.ads<$(SVX)-x86-kernel.ads
+ system.ads<$(SVX)-$(X86CPU)-kernel.ads
EXTRA_LIBGNAT_OBJS+=affinity.o
else
LIBGNAT_TARGET_PAIRS += \
- s-interr.adb<s-interr-hwint.adb \
+ s-interr.adb<s-interr-vxworks.adb \
s-tpopsp.adb<s-tpopsp-vxworks.adb
ifeq ($(strip $(filter-out kernel,$(THREAD_KIND))),)
@@ -999,12 +1032,23 @@ ifeq ($(strip $(filter-out %86 wrs vxworks vxworks7,$(target_cpu) $(target_vendo
EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o
endif
endif
- EXTRA_GNATRTL_TASKING_OBJS += s-vxwork.o s-vxwext.o
+
+ EXTRA_GNATRTL_NONTASKING_OBJS += s-stchop.o \
+ $(CERTMATH_GNATRTL_OBJS) $(CERTMATH_GNATRTL_X86TRA_OBJS)
+ EXTRA_GNATRTL_TASKING_OBJS += i-vxinco.o s-vxwork.o s-vxwext.o
EXTRA_LIBGNAT_OBJS+=vx_stack_info.o
- ifneq ($(strip $(filter-out vxworks7%, $(target_os))),)
- GCC_SPEC_FILES+=vxworks-crtbe-link.spec
+ EXTRA_LIBGNAT_OBJS+=sigtramp-vxworks.o
+ EXTRA_LIBGNAT_SRCS+=$(VX_SIGTRAMP_EXTRA_SRCS)
+
+ EXTRA_ADALIB_OBJS+=$(VX_CRTBE_EXTRA_ADALIB_OBJS)
+ EXTRA_LIBGNAT_SRCS+=vx_crtbegin.inc
+ GCC_SPEC_FILES+=vxworks-gnat-crtbe-link.spec
+
+ ifeq ($(strip $(filter-out vxworks7%, $(target_os))),)
+ GCC_SPEC_FILES+=vxworks7-$(X86CPU)-rtp-base-link.spec
+ else
GCC_SPEC_FILES+=vxworks-x86-link.spec
GCC_SPEC_FILES+=vxworks-cert-x86-link.spec
GCC_SPEC_FILES+=vxworks-smp-x86-link.spec
@@ -1016,15 +1060,19 @@ ifeq ($(strip $(filter-out arm% coff wrs vx%,$(target_cpu) $(target_vendor) $(ta
ifeq ($(strip $(filter-out vxworks7%, $(target_os))),)
SVX=system-vxworks7
+ EH_MECHANISM=-arm
+ SIGTRAMP_OBJ=sigtramp-armvxworks.o
else
SVX=system-vxworks
+ EH_MECHANISM=-gcc
+ SIGTRAMP_OBJ=sigtramp-vxworks.o
endif
LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<a-intnam-vxworks.ads \
a-numaux.ads<a-numaux-vxworks.ads \
s-inmaop.adb<s-inmaop-vxworks.adb \
- s-interr.adb<s-interr-hwint.adb \
+ s-interr.adb<s-interr-vxworks.adb \
s-intman.ads<s-intman-vxworks.ads \
s-intman.adb<s-intman-vxworks.adb \
s-osinte.adb<s-osinte-vxworks.adb \
@@ -1047,8 +1095,6 @@ ifeq ($(strip $(filter-out arm% coff wrs vx%,$(target_cpu) $(target_vendor) $(ta
indepsw.adb<indepsw-gnu.adb
ifeq ($(strip $(filter-out rtp-smp,$(THREAD_KIND))),)
- EH_MECHANISM=-gcc
-
LIBGNAT_TARGET_PAIRS += \
s-mudido.adb<s-mudido-affinity.adb \
s-vxwext.ads<s-vxwext-rtp.ads \
@@ -1056,47 +1102,55 @@ ifeq ($(strip $(filter-out arm% coff wrs vx%,$(target_cpu) $(target_vendor) $(ta
s-tpopsp.adb<s-tpopsp-vxworks-tls.adb \
system.ads<$(SVX)-arm-rtp-smp.ads
- EXTRA_LIBGNAT_OBJS+=affinity.o sigtramp-vxworks.o
- EXTRA_LIBGNAT_SRCS+=sigtramp.h
+ EXTRA_LIBGNAT_OBJS+=affinity.o
+
+ EXTRA_LIBGNAT_OBJS+=$(SIGTRAMP_OBJ)
+ EXTRA_LIBGNAT_SRCS+=$(VX_SIGTRAMP_EXTRA_SRCS)
else
ifeq ($(strip $(filter-out kernel-smp,$(THREAD_KIND))),)
- EH_MECHANISM=-gcc
-
LIBGNAT_TARGET_PAIRS += \
s-mudido.adb<s-mudido-affinity.adb \
s-tpopsp.adb<s-tpopsp-vxworks-tls.adb \
s-vxwext.ads<s-vxwext-kernel.ads \
s-vxwext.adb<s-vxwext-kernel-smp.adb \
- system.ads<system-vxworks-arm.ads
+ system.ads<$(SVX)-arm.ads
- EXTRA_LIBGNAT_OBJS+=affinity.o sigtramp-vxworks.o
- EXTRA_LIBGNAT_SRCS+=sigtramp.h
+ EXTRA_LIBGNAT_OBJS+=affinity.o
+
+ EXTRA_LIBGNAT_OBJS+=$(SIGTRAMP_OBJ)
+ EXTRA_LIBGNAT_SRCS+=$(VX_SIGTRAMP_EXTRA_SRCS)
else
LIBGNAT_TARGET_PAIRS += \
s-tpopsp.adb<s-tpopsp-vxworks.adb \
- system.ads<system-vxworks-arm.ads
+ system.ads<$(SVX)-arm.ads
ifeq ($(strip $(filter-out kernel,$(THREAD_KIND))),)
- EH_MECHANISM=-gcc
-
LIBGNAT_TARGET_PAIRS += \
s-vxwext.ads<s-vxwext-kernel.ads \
s-vxwext.adb<s-vxwext-kernel.adb
- EXTRA_LIBGNAT_OBJS+=sigtramp-vxworks.o
- EXTRA_LIBGNAT_SRCS+=sigtramp.h
+ EXTRA_LIBGNAT_OBJS+=$(SIGTRAMP_OBJ)
+ EXTRA_LIBGNAT_SRCS+=$(VX_SIGTRAMP_EXTRA_SRCS)
endif
endif
endif
- EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o
- EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o s-vxwext.o
+ EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o $(CERTMATH_GNATRTL_OBJS) \
+ s-stchop.o
+ EXTRA_GNATRTL_TASKING_OBJS=i-vxinco.o s-vxwork.o s-vxwext.o
EXTRA_LIBGNAT_OBJS+=vx_stack_info.o
- GCC_SPEC_FILES+=vxworks-crtbe-link.spec
- GCC_SPEC_FILES+=vxworks-arm-link.spec
- GCC_SPEC_FILES+=vxworks-smp-arm-link.spec
+ ifeq ($(strip $(filter-out vxworks7%, $(target_os))),)
+ GCC_SPEC_FILES+=vxworks7-rtp-base-link.spec
+ else
+ EXTRA_ADALIB_OBJS+=$(VX_CRTBE_EXTRA_ADALIB_OBJS)
+ EXTRA_LIBGNAT_SRCS+=vx_crtbegin.inc
+ GCC_SPEC_FILES+=vxworks-gnat-crtbe-link.spec
+
+ GCC_SPEC_FILES+=vxworks-arm-link.spec
+ GCC_SPEC_FILES+=vxworks-smp-arm-link.spec
+ endif
endif
# MIPS VxWorks
@@ -1105,7 +1159,7 @@ ifeq ($(strip $(filter-out mips% wrs vx%,$(target_cpu) $(target_vendor) $(target
a-intnam.ads<a-intnam-vxworks.ads \
a-numaux.ads<a-numaux-vxworks.ads \
s-inmaop.adb<s-inmaop-vxworks.adb \
- s-interr.adb<s-interr-hwint.adb \
+ s-interr.adb<s-interr-vxworks.adb \
s-intman.ads<s-intman-vxworks.ads \
s-intman.adb<s-intman-vxworks.adb \
s-osinte.adb<s-osinte-vxworks.adb \
@@ -1138,7 +1192,10 @@ ifeq ($(strip $(filter-out mips% wrs vx%,$(target_cpu) $(target_vendor) $(target
s-vxwext.adb<s-vxwext-rtp-smp.adb \
s-tpopsp.adb<s-tpopsp-vxworks-tls.adb
- EXTRA_LIBGNAT_OBJS+=affinity.o sigtramp-vxworks.o
+ EXTRA_LIBGNAT_OBJS+=affinity.o
+
+ EXTRA_LIBGNAT_OBJS+=sigtramp-vxworks.o
+ EXTRA_LIBGNAT_SRCS+=$(VX_SIGTRAMP_EXTRA_SRCS)
else
ifeq ($(strip $(filter-out kernel-smp,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS += \
@@ -1160,8 +1217,8 @@ ifeq ($(strip $(filter-out mips% wrs vx%,$(target_cpu) $(target_vendor) $(target
endif
endif
- EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o
- EXTRA_GNATRTL_TASKING_OBJS=s-vxwork.o s-vxwext.o
+ EXTRA_GNATRTL_NONTASKING_OBJS=i-vxwork.o i-vxwoio.o s-stchop.o
+ EXTRA_GNATRTL_TASKING_OBJS=i-vxinco.o s-vxwork.o s-vxwext.o
EXTRA_LIBGNAT_OBJS+=vx_stack_info.o
endif
@@ -1179,17 +1236,17 @@ ifeq ($(strip $(filter-out arm% linux-androideabi,$(target_cpu) $(target_os))),)
s-taprop.adb<s-taprop-posix.adb \
s-taspri.ads<s-taspri-posix.ads \
s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
- system.ads<system-linux-armel.ads \
- a-exexpr.adb<a-exexpr-gcc.adb \
- s-excmac.ads<s-excmac-arm.ads
+ $(ATOMICS_TARGET_PAIRS) \
+ $(ATOMICS_BUILTINS_TARGET_PAIRS) \
+ system.ads<system-linux-arm.ads
TOOLS_TARGET_PAIRS = \
mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb \
indepsw.adb<indepsw-gnu.adb
EXTRA_GNATRTL_TASKING_OBJS=s-linux.o
- EXTRA_LIBGNAT_OBJS+=raise-gcc.o sigtramp-armdroid.o
- EXTRA_GNATRTL_NONTASKING_OBJS+=g-cppexc.o s-excmac.o
+ EXTRA_LIBGNAT_OBJS+=sigtramp-armdroid.o
+ EXTRA_LIBGNAT_SRCS+=sigtramp.h
EH_MECHANISM=-arm
THREADSLIB =
GNATLIB_SHARED = gnatlib-shared-dual
@@ -1198,7 +1255,7 @@ endif
# Sparc Solaris
ifeq ($(strip $(filter-out sparc% sun solaris%,$(target_cpu) $(target_vendor) $(target_os))),)
- LIBGNAT_TARGET_PAIRS_COMMON = \
+ LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<a-intnam-solaris.ads \
s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<s-intman-solaris.adb \
@@ -1213,32 +1270,9 @@ ifeq ($(strip $(filter-out sparc% sun solaris%,$(target_cpu) $(target_vendor) $(
s-tpopsp.adb<s-tpopsp-solaris.adb \
g-soliop.ads<g-soliop-solaris.ads \
$(ATOMICS_TARGET_PAIRS) \
- $(ATOMICS_BUILTINS_TARGET_PAIRS)
-
- LIBGNAT_TARGET_PAIRS_32 = \
+ $(ATOMICS_BUILTINS_TARGET_PAIRS) \
system.ads<system-solaris-sparc.ads
- LIBGNAT_TARGET_PAIRS_64 = \
- system.ads<system-solaris-sparcv9.ads
-
- ifeq ($(strip $(filter-out sparc sun solaris%,$(target_cpu) $(target_vendor) $(target_os))),)
- ifeq ($(strip $(MULTISUBDIR)),/sparcv9)
- LIBGNAT_TARGET_PAIRS = \
- $(LIBGNAT_TARGET_PAIRS_COMMON) $(LIBGNAT_TARGET_PAIRS_64)
- else
- LIBGNAT_TARGET_PAIRS = \
- $(LIBGNAT_TARGET_PAIRS_COMMON) $(LIBGNAT_TARGET_PAIRS_32)
- endif
- else
- ifeq ($(strip $(MULTISUBDIR)),/sparcv8plus)
- LIBGNAT_TARGET_PAIRS = \
- $(LIBGNAT_TARGET_PAIRS_COMMON) $(LIBGNAT_TARGET_PAIRS_32)
- else
- LIBGNAT_TARGET_PAIRS = \
- $(LIBGNAT_TARGET_PAIRS_COMMON) $(LIBGNAT_TARGET_PAIRS_64)
- endif
- endif
-
TOOLS_TARGET_PAIRS=mlib-tgt-specific.adb<mlib-tgt-specific-solaris.adb
EH_MECHANISM=-gcc
@@ -1287,37 +1321,30 @@ ifeq ($(strip $(filter-out %86 %x86_64 solaris2%,$(target_cpu) $(target_os))),)
s-taspri.ads<s-taspri-solaris.ads \
s-tpopsp.adb<s-tpopsp-solaris.adb \
g-soliop.ads<g-soliop-solaris.ads \
- $(ATOMICS_TARGET_PAIRS)
-
- LIBGNAT_TARGET_PAIRS_32 = \
- $(X86_TARGET_PAIRS) \
+ $(ATOMICS_TARGET_PAIRS) \
system.ads<system-solaris-x86.ads
- LIBGNAT_TARGET_PAIRS_64 = \
- $(X86_64_TARGET_PAIRS) \
- system.ads<system-solaris-x86_64.ads
-
ifeq ($(strip $(filter-out %86 solaris2%,$(target_cpu) $(target_os))),)
ifeq ($(strip $(MULTISUBDIR)),/amd64)
LIBGNAT_TARGET_PAIRS = \
- $(LIBGNAT_TARGET_PAIRS_COMMON) $(LIBGNAT_TARGET_PAIRS_64)
+ $(LIBGNAT_TARGET_PAIRS_COMMON) $(X86_64_TARGET_PAIRS)
else
LIBGNAT_TARGET_PAIRS = \
- $(LIBGNAT_TARGET_PAIRS_COMMON) $(LIBGNAT_TARGET_PAIRS_32)
+ $(LIBGNAT_TARGET_PAIRS_COMMON) $(X86_TARGET_PAIRS)
endif
else
ifeq ($(strip $(MULTISUBDIR)),/32)
LIBGNAT_TARGET_PAIRS = \
- $(LIBGNAT_TARGET_PAIRS_COMMON) $(LIBGNAT_TARGET_PAIRS_32)
+ $(LIBGNAT_TARGET_PAIRS_COMMON) $(X86_TARGET_PAIRS)
else
LIBGNAT_TARGET_PAIRS = \
- $(LIBGNAT_TARGET_PAIRS_COMMON) $(LIBGNAT_TARGET_PAIRS_64)
+ $(LIBGNAT_TARGET_PAIRS_COMMON) $(X86_64_TARGET_PAIRS)
endif
endif
TOOLS_TARGET_PAIRS=mlib-tgt-specific.adb<mlib-tgt-specific-solaris.adb
- EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o
+ EXTRA_GNATRTL_NONTASKING_OBJS += g-sse.o g-ssvety.o
EH_MECHANISM=-gcc
THREADSLIB = -lposix4 -lthread
@@ -1342,20 +1369,13 @@ ifeq ($(strip $(filter-out %86 linux%,$(target_cpu) $(target_os))),)
a-exetim.ads<a-exetim-default.ads \
s-linux.ads<s-linux.ads \
s-osinte.adb<s-osinte-posix.adb \
- $(ATOMICS_TARGET_PAIRS)
-
- LIBGNAT_TARGET_PAIRS_32 = \
- $(X86_TARGET_PAIRS) \
+ $(ATOMICS_TARGET_PAIRS) \
system.ads<system-linux-x86.ads
- LIBGNAT_TARGET_PAIRS_64 = \
- $(X86_64_TARGET_PAIRS) \
- system.ads<system-linux-x86_64.ads
-
ifeq ($(strip $(MULTISUBDIR)),/64)
- LIBGNAT_TARGET_PAIRS += $(LIBGNAT_TARGET_PAIRS_64)
+ LIBGNAT_TARGET_PAIRS += $(X86_64_TARGET_PAIRS)
else
- LIBGNAT_TARGET_PAIRS += $(LIBGNAT_TARGET_PAIRS_32)
+ LIBGNAT_TARGET_PAIRS += $(X86_TARGET_PAIRS)
endif
ifeq ($(strip $(filter-out xenomai,$(THREAD_KIND))),)
@@ -1377,7 +1397,7 @@ ifeq ($(strip $(filter-out %86 linux%,$(target_cpu) $(target_os))),)
EH_MECHANISM=-gcc
THREADSLIB = -lpthread -lrt
- EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o
+ EXTRA_GNATRTL_NONTASKING_OBJS += g-sse.o g-ssvety.o
EXTRA_GNATRTL_TASKING_OBJS=s-linux.o a-exetim.o
TOOLS_TARGET_PAIRS = \
@@ -1410,7 +1430,7 @@ ifeq ($(strip $(filter-out %86 kfreebsd%,$(target_cpu) $(target_os))),)
mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb \
indepsw.adb<indepsw-gnu.adb
- EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o
+ EXTRA_GNATRTL_NONTASKING_OBJS += g-sse.o g-ssvety.o
EH_MECHANISM=-gcc
THREADSLIB = -lpthread
@@ -1462,7 +1482,7 @@ ifeq ($(strip $(filter-out x86_64 kfreebsd%,$(target_cpu) $(target_os))),)
s-taprop.adb<s-taprop-posix.adb \
s-taspri.ads<s-taspri-posix.ads \
s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
- system.ads<system-freebsd-x86_64.ads
+ system.ads<system-freebsd-x86.ads
TOOLS_TARGET_PAIRS = \
mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb \
@@ -1475,6 +1495,34 @@ ifeq ($(strip $(filter-out x86_64 kfreebsd%,$(target_cpu) $(target_os))),)
LIBRARY_VERSION := $(LIB_VERSION)
endif
+# aarch64 FreeBSD
+ifeq ($(strip $(filter-out %aarch64 freebsd%,$(target_cpu) $(target_os))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-intnam.ads<a-intnam-freebsd.ads \
+ s-inmaop.adb<s-inmaop-posix.adb \
+ s-intman.adb<s-intman-posix.adb \
+ s-mudido.adb<s-mudido-affinity.adb \
+ s-osinte.adb<s-osinte-freebsd.adb \
+ s-osinte.ads<s-osinte-freebsd.ads \
+ s-osprim.adb<s-osprim-posix.adb \
+ s-taprop.adb<s-taprop-posix.adb \
+ s-taspri.ads<s-taspri-posix.ads \
+ s-tpopsp.adb<s-tpopsp-posix.adb \
+ $(ATOMICS_TARGET_PAIRS) \
+ $(ATOMICS_BUILTINS_TARGET_PAIRS) \
+ system.ads<system-freebsd.ads
+
+ TOOLS_TARGET_PAIRS = \
+ mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb
+ GNATLIB_SHARED = gnatlib-shared-dual
+
+ EH_MECHANISM=-gcc
+ THREADSLIB= -lpthread
+ GMEM_LIB = gmemlib
+ LIBRARY_VERSION := $(LIB_VERSION)
+ MISCLIB = -lutil
+endif
+
# x86 FreeBSD
ifeq ($(strip $(filter-out %86 freebsd%,$(target_cpu) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
@@ -1490,13 +1538,13 @@ ifeq ($(strip $(filter-out %86 freebsd%,$(target_cpu) $(target_os))),)
s-tpopsp.adb<s-tpopsp-posix.adb \
$(ATOMICS_TARGET_PAIRS) \
$(X86_TARGET_PAIRS) \
- system.ads<system-freebsd-x86.ads
+ system.ads<system-freebsd.ads
TOOLS_TARGET_PAIRS = \
mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb
GNATLIB_SHARED = gnatlib-shared-dual
- EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o
+ EXTRA_GNATRTL_NONTASKING_OBJS += g-sse.o g-ssvety.o
EH_MECHANISM=-gcc
THREADSLIB= -lpthread
@@ -1520,13 +1568,13 @@ ifeq ($(strip $(filter-out %86_64 freebsd%,$(target_cpu) $(target_os))),)
s-tpopsp.adb<s-tpopsp-posix.adb \
$(ATOMICS_TARGET_PAIRS) \
$(X86_64_TARGET_PAIRS) \
- system.ads<system-freebsd-x86_64.ads
+ system.ads<system-freebsd.ads
TOOLS_TARGET_PAIRS = \
mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb
GNATLIB_SHARED = gnatlib-shared-dual
- EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o
+ EXTRA_GNATRTL_NONTASKING_OBJS += g-sse.o g-ssvety.o
EH_MECHANISM=-gcc
THREADSLIB= -lpthread
@@ -1567,7 +1615,7 @@ endif
# S390 Linux
ifeq ($(strip $(filter-out s390% linux%,$(target_cpu) $(target_os))),)
- LIBGNAT_TARGET_PAIRS_COMMON = \
+ LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<a-intnam-linux.ads \
s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<s-intman-posix.adb \
@@ -1579,27 +1627,9 @@ ifeq ($(strip $(filter-out s390% linux%,$(target_cpu) $(target_os))),)
s-tasinf.ads<s-tasinf-linux.ads \
s-tasinf.adb<s-tasinf-linux.adb \
s-taspri.ads<s-taspri-posix-noaltstack.ads \
- s-tpopsp.adb<s-tpopsp-posix-foreign.adb
-
- LIBGNAT_TARGET_PAIRS_32 = \
+ s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
system.ads<system-linux-s390.ads
- LIBGNAT_TARGET_PAIRS_64 = \
- system.ads<system-linux-s390x.ads
-
- ifeq ($(strip $(filter-out s390x,$(target_cpu))),)
- ifeq ($(strip $(MULTISUBDIR)),/32)
- LIBGNAT_TARGET_PAIRS = \
- $(LIBGNAT_TARGET_PAIRS_COMMON) $(LIBGNAT_TARGET_PAIRS_32)
- else
- LIBGNAT_TARGET_PAIRS = \
- $(LIBGNAT_TARGET_PAIRS_COMMON) $(LIBGNAT_TARGET_PAIRS_64)
- endif
- else
- LIBGNAT_TARGET_PAIRS = \
- $(LIBGNAT_TARGET_PAIRS_COMMON) $(LIBGNAT_TARGET_PAIRS_32)
- endif
-
TOOLS_TARGET_PAIRS = \
mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb \
indepsw.adb<indepsw-gnu.adb
@@ -1660,7 +1690,7 @@ endif
# IBM AIX
ifeq ($(strip $(filter-out ibm aix%,$(target_vendor) $(target_os))),)
- LIBGNAT_TARGET_PAIRS_COMMON = \
+ LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<a-intnam-aix.ads \
s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<s-intman-posix.adb \
@@ -1671,27 +1701,16 @@ ifeq ($(strip $(filter-out ibm aix%,$(target_vendor) $(target_os))),)
s-taspri.ads<s-taspri-posix.ads \
s-tpopsp.adb<s-tpopsp-posix.adb \
$(ATOMICS_TARGET_PAIRS) \
- $(ATOMICS_BUILTINS_TARGET_PAIRS)
-
- LIBGNAT_TARGET_PAIRS_32 = \
+ $(ATOMICS_BUILTINS_TARGET_PAIRS) \
system.ads<system-aix.ads
- LIBGNAT_TARGET_PAIRS_64 = \
- system.ads<system-aix64.ads
-
ifeq ($(findstring ppc64, \
$(shell $(GCC_FOR_TARGET) $(GNATLIBCFLAGS) \
-print-multi-os-directory)), \
ppc64)
- LIBGNAT_TARGET_PAIRS = \
- $(LIBGNAT_TARGET_PAIRS_COMMON) $(LIBGNAT_TARGET_PAIRS_64)
- TOOLS_TARGET_PAIRS = \
- indepsw.adb<indepsw-aix.adb
+ TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-aix.adb
else
- LIBGNAT_TARGET_PAIRS = \
- $(LIBGNAT_TARGET_PAIRS_COMMON) $(LIBGNAT_TARGET_PAIRS_32)
- TOOLS_TARGET_PAIRS = \
- indepsw.adb<indepsw-gnu.adb
+ TOOLS_TARGET_PAIRS = indepsw.adb<indepsw-gnu.adb
endif
THREADSLIB = -lpthreads
@@ -1717,7 +1736,7 @@ ifeq ($(strip $(filter-out rtems%,$(target_os))),)
s-taspri.ads<s-taspri-posix.ads \
s-tpopsp.adb<s-tpopsp-rtems.adb \
s-stchop.adb<s-stchop-rtems.adb \
- s-interr.adb<s-interr-hwint.adb
+ s-interr.adb<s-interr-vxworks.adb
endif
# PikeOS
@@ -1734,6 +1753,23 @@ ifeq ($(strip $(filter-out elf eabi eabispe,$(target_os))),)
indepsw.adb<indepsw-gnu.adb
endif
+ifeq ($(strip $(filter-out %djgpp,$(target_os))),)
+ GNATRTL_SOCKETS_OBJS =
+
+ LIBGNAT_TARGET_PAIRS = \
+ a-intnam.ads<a-intnam-dummy.ads \
+ s-inmaop.adb<s-inmaop-dummy.adb \
+ s-intman.adb<s-intman-dummy.adb \
+ s-osinte.ads<s-osinte-dummy.ads \
+ s-osprim.adb<s-osprim-unix.adb \
+ s-taprop.adb<s-taprop-dummy.adb \
+ s-taspri.ads<s-taspri-dummy.ads \
+ system.ads<system-djgpp.ads \
+ $(DUMMY_SOCKETS_TARGET_PAIRS)
+
+ EH_MECHANISM=-gcc
+endif
+
# Cygwin/Mingw32
ifeq ($(strip $(filter-out cygwin% mingw32% pe,$(target_os))),)
# Cygwin provides a full Posix environment, and so we use the default
@@ -1763,7 +1799,8 @@ ifeq ($(strip $(filter-out cygwin% mingw32% pe,$(target_os))),)
s-tasinf.ads<s-tasinf-mingw.ads \
g-stsifd.adb<g-stsifd-sockets.adb \
g-soliop.ads<g-soliop-mingw.ads \
- $(ATOMICS_TARGET_PAIRS)
+ $(ATOMICS_TARGET_PAIRS) \
+ system.ads<system-mingw.ads
LIBGNAT_TARGET_PAIRS += \
a-exetim.adb<a-exetim-mingw.adb \
@@ -1779,31 +1816,23 @@ ifeq ($(strip $(filter-out cygwin% mingw32% pe,$(target_os))),)
ifeq ($(strip $(filter-out x86_64%,$(target_cpu))),)
ifeq ($(strip $(MULTISUBDIR)),/32)
- LIBGNAT_TARGET_PAIRS += \
- $(X86_TARGET_PAIRS) \
- system.ads<system-mingw.ads
+ LIBGNAT_TARGET_PAIRS += $(X86_TARGET_PAIRS)
SO_OPTS= -m32 -Wl,-soname,
else
- LIBGNAT_TARGET_PAIRS += \
- $(X86_64_TARGET_PAIRS) \
- system.ads<system-mingw-x86_64.ads
+ LIBGNAT_TARGET_PAIRS += $(X86_64_TARGET_PAIRS)
SO_OPTS = -m64 -Wl,-soname,
endif
else
ifeq ($(strip $(MULTISUBDIR)),/64)
- LIBGNAT_TARGET_PAIRS += \
- $(X86_64_TARGET_PAIRS) \
- system.ads<system-mingw-x86_64.ads
+ LIBGNAT_TARGET_PAIRS += $(X86_64_TARGET_PAIRS)
SO_OPTS = -m64 -Wl,-soname,
else
- LIBGNAT_TARGET_PAIRS += \
- $(X86_TARGET_PAIRS) \
- system.ads<system-mingw.ads
+ LIBGNAT_TARGET_PAIRS += $(X86_TARGET_PAIRS)
SO_OPTS = -m32 -Wl,-soname,
endif
endif
- EXTRA_GNATRTL_NONTASKING_OBJS = \
+ EXTRA_GNATRTL_NONTASKING_OBJS += \
s-win32.o s-winext.o g-regist.o g-sse.o g-ssvety.o
EXTRA_GNATRTL_TASKING_OBJS = a-exetim.o
EXTRA_LIBGNAT_SRCS+=mingw32.h
@@ -1827,36 +1856,12 @@ ifeq ($(strip $(filter-out cygwin% mingw32% pe,$(target_os))),)
endif
# Mips Linux
-ifeq ($(strip $(filter-out mips linux%,$(target_cpu) $(target_os))),)
+ifeq ($(strip $(filter-out mips% linux%,$(target_cpu) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<a-intnam-linux.ads \
s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<s-intman-posix.adb \
- s-linux.ads<s-linux.ads \
- s-osinte.adb<s-osinte-posix.adb \
- s-osinte.ads<s-osinte-linux.ads \
- s-osprim.adb<s-osprim-posix.adb \
- s-taprop.adb<s-taprop-linux.adb \
- s-tasinf.ads<s-tasinf-linux.ads \
- s-tasinf.adb<s-tasinf-linux.adb \
- s-taspri.ads<s-taspri-posix.ads \
- s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
- system.ads<system-linux-mips.ads
-
- EH_MECHANISM=-gcc
- THREADSLIB = -lpthread
- GNATLIB_SHARED = gnatlib-shared-dual
- GMEM_LIB = gmemlib
- LIBRARY_VERSION := $(LIB_VERSION)
-endif
-
-# Mips/el and Mips64/el Linux
-ifeq ($(strip $(filter-out mipsel mips64el linux%,$(target_cpu) $(target_os))),)
- LIBGNAT_TARGET_PAIRS_COMMON = \
- a-intnam.ads<a-intnam-linux.ads \
- s-inmaop.adb<s-inmaop-posix.adb \
- s-intman.adb<s-intman-posix.adb \
- s-linux.ads<s-linux-mipsel.ads \
+ s-linux.ads<s-linux-mips.ads \
s-osinte.adb<s-osinte-posix.adb \
s-osinte.ads<s-osinte-linux.ads \
s-osprim.adb<s-osprim-posix.adb \
@@ -1865,21 +1870,8 @@ ifeq ($(strip $(filter-out mipsel mips64el linux%,$(target_cpu) $(target_os))),)
s-tasinf.adb<s-tasinf-linux.adb \
s-taspri.ads<s-taspri-posix-noaltstack.ads \
s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
- g-sercom.adb<g-sercom-linux.adb
-
- LIBGNAT_TARGET_PAIRS_32 = \
- system.ads<system-linux-mipsel.ads
-
- LIBGNAT_TARGET_PAIRS_64 = \
- system.ads<system-linux-mips64el.ads
-
- ifneq (,$(or $(filter mips64el%, $(shell $(GCC_FOR_TARGET) $(GNATLIBCFLAGS) -print-multiarch)), $(filter ../lib64, $(shell $(GCC_FOR_TARGET) $(GNATLIBCFLAGS) -print-multi-os-directory))))
- LIBGNAT_TARGET_PAIRS = \
- $(LIBGNAT_TARGET_PAIRS_COMMON) $(LIBGNAT_TARGET_PAIRS_64)
- else
- LIBGNAT_TARGET_PAIRS = \
- $(LIBGNAT_TARGET_PAIRS_COMMON) $(LIBGNAT_TARGET_PAIRS_32)
- endif
+ g-sercom.adb<g-sercom-linux.adb \
+ system.ads<system-linux-mips.ads
TOOLS_TARGET_PAIRS = \
mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb \
@@ -1908,41 +1900,26 @@ ifeq ($(strip $(filter-out powerpc% linux%,$(target_cpu) $(target_os))),)
s-tpopsp.adb<s-tpopsp-tls.adb \
g-sercom.adb<g-sercom-linux.adb \
$(ATOMICS_TARGET_PAIRS) \
- $(ATOMICS_BUILTINS_TARGET_PAIRS)
+ $(ATOMICS_BUILTINS_TARGET_PAIRS) \
+ system.ads<system-linux-ppc.ads
ifeq ($(strip $(filter-out xenomai,$(THREAD_KIND))),)
LIBGNAT_TARGET_PAIRS = \
- $(LIBGNAT_TARGET_PAIRS_COMMON)
-
- LIBGNAT_TARGET_PAIRS += \
- s-osinte.ads<s-osinte-linux-xenomai.ads \
- s-osprim.adb<s-osprim-linux-xenomai.adb \
- s-taprop.adb<s-taprop-linux-xenomai.adb \
- s-taspri.ads<s-taspri-linux-xenomai.ads \
- system.ads<system-linux-ppc.ads
+ $(LIBGNAT_TARGET_PAIRS_COMMON) \
+ s-osinte.ads<s-osinte-linux-xenomai.ads \
+ s-osprim.adb<s-osprim-linux-xenomai.adb \
+ s-taprop.adb<s-taprop-linux-xenomai.adb \
+ s-taspri.ads<s-taspri-linux-xenomai.ads
else
- LIBGNAT_TARGET_PAIRS_32 = \
- system.ads<system-linux-ppc.ads
-
- LIBGNAT_TARGET_PAIRS_64 = \
- system.ads<system-linux-ppc64.ads
-
- ifneq (,$(or $(filter powerpc64%, $(shell $(GCC_FOR_TARGET) $(GNATLIBCFLAGS) -print-multiarch)), $(filter ../lib64, $(shell $(GCC_FOR_TARGET) $(GNATLIBCFLAGS) -print-multi-os-directory))))
- LIBGNAT_TARGET_PAIRS = \
- $(LIBGNAT_TARGET_PAIRS_COMMON) $(LIBGNAT_TARGET_PAIRS_64)
- else
- LIBGNAT_TARGET_PAIRS = \
- $(LIBGNAT_TARGET_PAIRS_COMMON) $(LIBGNAT_TARGET_PAIRS_32)
- endif
-
- LIBGNAT_TARGET_PAIRS += \
- s-mudido.adb<s-mudido-affinity.adb \
- s-osinte.ads<s-osinte-linux.ads \
- s-osprim.adb<s-osprim-posix.adb \
- s-taprop.adb<s-taprop-linux.adb \
- s-tasinf.ads<s-tasinf-linux.ads \
- s-tasinf.adb<s-tasinf-linux.adb \
- s-taspri.ads<s-taspri-posix-noaltstack.ads
+ LIBGNAT_TARGET_PAIRS = \
+ $(LIBGNAT_TARGET_PAIRS_COMMON) \
+ s-mudido.adb<s-mudido-affinity.adb \
+ s-osinte.ads<s-osinte-linux.ads \
+ s-osprim.adb<s-osprim-posix.adb \
+ s-taprop.adb<s-taprop-linux.adb \
+ s-tasinf.ads<s-tasinf-linux.ads \
+ s-tasinf.adb<s-tasinf-linux.adb \
+ s-taspri.ads<s-taspri-posix-noaltstack.ads
endif
TOOLS_TARGET_PAIRS = \
@@ -1950,6 +1927,7 @@ ifeq ($(strip $(filter-out powerpc% linux%,$(target_cpu) $(target_os))),)
indepsw.adb<indepsw-gnu.adb
EXTRA_GNATRTL_TASKING_OBJS=s-linux.o a-exetim.o
+
EH_MECHANISM=-gcc
THREADSLIB = -lpthread -lrt
GNATLIB_SHARED = gnatlib-shared-dual
@@ -1971,18 +1949,15 @@ ifeq ($(strip $(filter-out arm% linux-gnueabi%,$(target_cpu) $(target_os))),)
s-tasinf.ads<s-tasinf-linux.ads \
s-tasinf.adb<s-tasinf-linux.adb \
s-taspri.ads<s-taspri-posix-noaltstack.ads \
- s-tpopsp.adb<s-tpopsp-posix-foreign.adb
+ s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
+ $(ATOMICS_TARGET_PAIRS) \
+ $(ATOMICS_BUILTINS_TARGET_PAIRS) \
+ system.ads<system-linux-arm.ads
ifeq ($(strip $(filter-out arm%b,$(target_cpu))),)
EH_MECHANISM=
- LIBGNAT_TARGET_PAIRS += \
- system.ads<system-linux-armeb.ads
else
EH_MECHANISM=-arm
- LIBGNAT_TARGET_PAIRS += \
- system.ads<system-linux-armel.ads \
- a-exexpr.adb<a-exexpr-gcc.adb \
- s-excmac.ads<s-excmac-arm.ads
endif
TOOLS_TARGET_PAIRS = \
@@ -1990,8 +1965,6 @@ ifeq ($(strip $(filter-out arm% linux-gnueabi%,$(target_cpu) $(target_os))),)
indepsw.adb<indepsw-gnu.adb
EXTRA_GNATRTL_TASKING_OBJS=s-linux.o
- EXTRA_LIBGNAT_OBJS+=raise-gcc.o
- EXTRA_GNATRTL_NONTASKING_OBJS+=g-cppexc.o s-excmac.o
THREADSLIB = -lpthread
GNATLIB_SHARED = gnatlib-shared-dual
GMEM_LIB = gmemlib
@@ -2000,7 +1973,7 @@ endif
# AArch64 Linux
ifeq ($(strip $(filter-out aarch64% linux%,$(target_cpu) $(target_os))),)
- LIBGNAT_TARGET_PAIRS = \
+ LIBGNAT_TARGET_PAIRS_COMMON = \
a-exetim.adb<a-exetim-posix.adb \
a-exetim.ads<a-exetim-default.ads \
a-intnam.ads<a-intnam-linux.ads \
@@ -2020,9 +1993,21 @@ ifeq ($(strip $(filter-out aarch64% linux%,$(target_cpu) $(target_os))),)
s-taspri.ads<s-taspri-posix.ads \
g-sercom.adb<g-sercom-linux.adb \
$(ATOMICS_TARGET_PAIRS) \
- $(ATOMICS_BUILTINS_TARGET_PAIRS) \
- system.ads<system-linux-x86_64.ads
- ## ^^ Note the above is a pretty-close placeholder.
+ $(ATOMICS_BUILTINS_TARGET_PAIRS)
+
+ LIBGNAT_TARGET_PAIRS_32 = \
+ system.ads<system-linux-aarch64-ilp32.ads
+
+ LIBGNAT_TARGET_PAIRS_64 = \
+ system.ads<system-linux-arm.ads
+
+ ifneq (,$(or $(filter aarch64-linux-gnu, $(shell $(GCC_FOR_TARGET) $(GNATLIBCFLAGS) -print-multiarch)), $(filter ../lib64, $(shell $(GCC_FOR_TARGET) $(GNATLIBCFLAGS) -print-multi-os-directory))))
+ LIBGNAT_TARGET_PAIRS = \
+ $(LIBGNAT_TARGET_PAIRS_COMMON) $(LIBGNAT_TARGET_PAIRS_64)
+ else
+ LIBGNAT_TARGET_PAIRS = \
+ $(LIBGNAT_TARGET_PAIRS_COMMON) $(LIBGNAT_TARGET_PAIRS_32)
+ endif
TOOLS_TARGET_PAIRS = \
mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb \
@@ -2038,7 +2023,7 @@ endif
# Sparc Linux
ifeq ($(strip $(filter-out sparc% linux%,$(target_cpu) $(target_os))),)
- LIBGNAT_TARGET_PAIRS_COMMON = \
+ LIBGNAT_TARGET_PAIRS = \
a-intnam.ads<a-intnam-linux.ads \
s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<s-intman-posix.adb \
@@ -2050,22 +2035,9 @@ ifeq ($(strip $(filter-out sparc% linux%,$(target_cpu) $(target_os))),)
s-tasinf.ads<s-tasinf-linux.ads \
s-tasinf.adb<s-tasinf-linux.adb \
s-taspri.ads<s-taspri-posix-noaltstack.ads \
- s-tpopsp.adb<s-tpopsp-tls.adb
-
- LIBGNAT_TARGET_PAIRS_32 = \
+ s-tpopsp.adb<s-tpopsp-tls.adb \
system.ads<system-linux-sparc.ads
- LIBGNAT_TARGET_PAIRS_64 = \
- system.ads<system-linux-sparcv9.ads
-
- ifneq (,$(or $(filter sparc64-linux-gnu, $(shell $(GCC_FOR_TARGET) $(GNATLIBCFLAGS) -print-multiarch)), $(filter ../lib64, $(shell $(GCC_FOR_TARGET) $(GNATLIBCFLAGS) -print-multi-os-directory))))
- LIBGNAT_TARGET_PAIRS = \
- $(LIBGNAT_TARGET_PAIRS_COMMON) $(LIBGNAT_TARGET_PAIRS_64)
- else
- LIBGNAT_TARGET_PAIRS = \
- $(LIBGNAT_TARGET_PAIRS_COMMON) $(LIBGNAT_TARGET_PAIRS_32)
- endif
-
TOOLS_TARGET_PAIRS = \
mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb \
indepsw.adb<indepsw-gnu.adb
@@ -2107,6 +2079,35 @@ ifeq ($(strip $(filter-out hppa% linux%,$(target_cpu) $(target_os))),)
LIBRARY_VERSION := $(LIB_VERSION)
endif
+# M68K Linux
+ifeq ($(strip $(filter-out m68k% linux%,$(target_cpu) $(target_os))),)
+ LIBGNAT_TARGET_PAIRS = \
+ a-intnam.ads<a-intnam-linux.ads \
+ s-inmaop.adb<s-inmaop-posix.adb \
+ s-intman.adb<s-intman-posix.adb \
+ s-linux.ads<s-linux.ads \
+ s-osinte.adb<s-osinte-posix.adb \
+ s-osinte.ads<s-osinte-linux.ads \
+ s-osprim.adb<s-osprim-posix.adb \
+ s-taprop.adb<s-taprop-linux.adb \
+ s-tasinf.ads<s-tasinf-linux.ads \
+ s-tasinf.adb<s-tasinf-linux.adb \
+ s-taspri.ads<s-taspri-posix.ads \
+ s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
+ system.ads<system-linux-m68k.ads
+
+ TOOLS_TARGET_PAIRS = \
+ mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb \
+ indepsw.adb<indepsw-gnu.adb
+
+ EXTRA_GNATRTL_TASKING_OBJS=s-linux.o
+ EH_MECHANISM=-gcc
+ THREADSLIB = -lpthread
+ GNATLIB_SHARED = gnatlib-shared-dual
+ GMEM_LIB = gmemlib
+ LIBRARY_VERSION := $(LIB_VERSION)
+endif
+
# SH4 Linux
ifeq ($(strip $(filter-out sh4% linux%,$(target_cpu) $(target_os))),)
LIBGNAT_TARGET_PAIRS = \
@@ -2159,9 +2160,9 @@ ifeq ($(strip $(filter-out %ia64 linux%,$(target_cpu) $(target_os))),)
s-tpopsp.adb<s-tpopsp-tls.adb \
s-taspri.ads<s-taspri-posix-noaltstack.ads \
g-sercom.adb<g-sercom-linux.adb \
- system.ads<system-linux-ia64.ads \
$(ATOMICS_TARGET_PAIRS) \
- $(ATOMICS_BUILTINS_TARGET_PAIRS)
+ $(ATOMICS_BUILTINS_TARGET_PAIRS) \
+ system.ads<system-linux-ia64.ads
TOOLS_TARGET_PAIRS = \
mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb \
@@ -2188,9 +2189,9 @@ ifeq ($(strip $(filter-out ia64% hp hpux%,$(target_cpu) $(target_vendor) $(targe
s-taprop.adb<s-taprop-posix.adb \
s-taspri.ads<s-taspri-posix.ads \
s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
- system.ads<system-hpux-ia64.ads \
$(ATOMICS_TARGET_PAIRS) \
- $(ATOMICS_BUILTINS_TARGET_PAIRS)
+ $(ATOMICS_BUILTINS_TARGET_PAIRS) \
+ system.ads<system-hpux-ia64.ads
TOOLS_TARGET_PAIRS = \
mlib-tgt-specific.adb<mlib-tgt-specific-ia64-hpux.adb
@@ -2220,9 +2221,9 @@ ifeq ($(strip $(filter-out alpha% linux%,$(target_cpu) $(target_os))),)
s-tasinf.adb<s-tasinf-linux.adb \
s-tpopsp.adb<s-tpopsp-posix-foreign.adb \
s-taspri.ads<s-taspri-posix-noaltstack.ads \
- system.ads<system-linux-alpha.ads \
$(ATOMICS_TARGET_PAIRS) \
- $(ATOMICS_BUILTINS_TARGET_PAIRS)
+ $(ATOMICS_BUILTINS_TARGET_PAIRS) \
+ system.ads<system-linux-alpha.ads
TOOLS_TARGET_PAIRS = \
mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb \
@@ -2259,14 +2260,15 @@ ifeq ($(strip $(filter-out %x86_64 linux%,$(target_cpu) $(target_os))),)
g-sercom.adb<g-sercom-linux.adb \
$(ATOMICS_TARGET_PAIRS) \
$(X86_64_TARGET_PAIRS) \
- system.ads<system-linux-x86_64.ads
+ system.ads<system-linux-x86.ads
TOOLS_TARGET_PAIRS = \
mlib-tgt-specific.adb<mlib-tgt-specific-linux.adb \
indepsw.adb<indepsw-gnu.adb
- EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o
+ EXTRA_GNATRTL_NONTASKING_OBJS += g-sse.o g-ssvety.o
EXTRA_GNATRTL_TASKING_OBJS=s-linux.o a-exetim.o
+
EH_MECHANISM=-gcc
THREADSLIB=-lpthread -lrt
MISCLIB = -ldl
@@ -2328,17 +2330,14 @@ ifeq ($(strip $(filter-out darwin%,$(target_os))),)
LIBGNAT_TARGET_PAIRS += \
s-intman.adb<s-intman-susv3.adb \
s-osprim.adb<s-osprim-darwin.adb \
- $(ATOMICS_TARGET_PAIRS)
+ $(ATOMICS_TARGET_PAIRS) \
+ system.ads<system-darwin-x86.ads
ifeq ($(strip $(MULTISUBDIR)),/x86_64)
- LIBGNAT_TARGET_PAIRS += \
- $(X86_64_TARGET_PAIRS) \
- system.ads<system-darwin-x86_64.ads
SO_OPTS += -m64
+ LIBGNAT_TARGET_PAIRS += $(X86_64_TARGET_PAIRS)
else
- LIBGNAT_TARGET_PAIRS += \
- $(X86_TARGET_PAIRS) \
- system.ads<system-darwin-x86.ads
+ LIBGNAT_TARGET_PAIRS += $(X86_TARGET_PAIRS)
endif
EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o
@@ -2348,20 +2347,20 @@ ifeq ($(strip $(filter-out darwin%,$(target_os))),)
LIBGNAT_TARGET_PAIRS += \
s-intman.adb<s-intman-susv3.adb \
s-osprim.adb<s-osprim-darwin.adb \
- $(ATOMICS_TARGET_PAIRS)
+ a-exetim.ads<a-exetim-default.ads \
+ a-exetim.adb<a-exetim-darwin.adb \
+ $(ATOMICS_TARGET_PAIRS) \
+ system.ads<system-darwin-x86.ads
ifeq ($(strip $(MULTISUBDIR)),/i386)
- LIBGNAT_TARGET_PAIRS += \
- $(X86_TARGET_PAIRS) \
- system.ads<system-darwin-x86.ads
SO_OPTS += -m32
+ LIBGNAT_TARGET_PAIRS += $(X86_TARGET_PAIRS)
else
- LIBGNAT_TARGET_PAIRS += \
- $(X86_64_TARGET_PAIRS) \
- system.ads<system-darwin-x86_64.ads
+ LIBGNAT_TARGET_PAIRS += $(X86_64_TARGET_PAIRS)
endif
EXTRA_GNATRTL_NONTASKING_OBJS=g-sse.o g-ssvety.o
+ EXTRA_GNATRTL_TASKING_OBJS=a-exetim.o
endif
ifeq ($(strip $(filter-out powerpc%,$(target_cpu))),)
@@ -2371,15 +2370,11 @@ ifeq ($(strip $(filter-out darwin%,$(target_os))),)
a-numaux.ads<a-numaux-darwin.ads \
a-numaux.adb<a-numaux-darwin.adb \
$(ATOMICS_TARGET_PAIRS) \
- $(ATOMICS_BUILTINS_TARGET_PAIRS)
+ $(ATOMICS_BUILTINS_TARGET_PAIRS) \
+ system.ads<system-darwin-ppc.ads
ifeq ($(strip $(MULTISUBDIR)),/ppc64)
- LIBGNAT_TARGET_PAIRS += \
- system.ads<system-darwin-ppc64.ads
SO_OPTS += -m64
- else
- LIBGNAT_TARGET_PAIRS += \
- system.ads<system-darwin-ppc.ads
endif
endif
@@ -2401,8 +2396,10 @@ ifeq ($(strip $(filter-out darwin%,$(target_os))),)
$(ATOMICS_TARGET_PAIRS) \
$(ATOMICS_BUILTINS_TARGET_PAIRS)
+ EXTRA_LIBGNAT_OBJS+=sigtramp-ios.o
+ EXTRA_LIBGNAT_SRCS+=sigtramp.h
LIBGNAT_TARGET_PAIRS += \
- system.ads<system-darwin-arm64.ads
+ system.ads<system-darwin-arm.ads
endif
TOOLS_TARGET_PAIRS = \
@@ -2425,6 +2422,14 @@ ifeq ($(EH_MECHANISM),-gcc)
EXTRA_GNATRTL_NONTASKING_OBJS+=g-cppexc.o s-excmac.o
endif
+ifeq ($(EH_MECHANISM),-arm)
+ LIBGNAT_TARGET_PAIRS += \
+ a-exexpr.adb<a-exexpr-gcc.adb \
+ s-excmac.ads<s-excmac-arm.ads
+ EXTRA_LIBGNAT_OBJS+=raise-gcc.o
+ EXTRA_GNATRTL_NONTASKING_OBJS+=g-cppexc.o s-excmac.o
+endif
+
# Use the Ada 2005 version of Ada.Exceptions by default, unless specified
# explicitly already. The base files (a-except.ad?) are used only for building
# the compiler and other basic tools.
@@ -2488,7 +2493,8 @@ ADA_EXCLUDE_SRCS =\
g-allein.ads g-alleve.adb g-alleve.ads g-altcon.adb g-altcon.ads \
g-altive.ads g-alveop.adb g-alveop.ads g-alvety.ads g-alvevi.ads \
g-intpri.ads g-regist.adb g-regist.ads g-sse.ads g-ssvety.ads \
- i-vxwoio.adb i-vxwoio.ads i-vxwork.ads \
+ i-vxinco.adb i-vxinco.ads i-vxwoio.adb i-vxwoio.ads i-vxwork.ads \
+ i-bit_types.ads \
s-bb.ads s-bbbosu.ads s-bbcaco.ads s-bbcppr.ads s-bbexti.adb \
s-bbexti.ads s-bbinte.adb s-bbinte.ads s-bbprot.adb s-bbprot.ads \
s-bbsle3.ads s-bbsuer.ads s-bbsule.ads s-bbthqu.adb s-bbthqu.ads \
@@ -2499,8 +2505,9 @@ ADA_EXCLUDE_SRCS =\
s-init.ads s-init.adb s-linux.ads s-macres.ads \
s-memcom.adb s-memcom.ads s-memmov.adb s-memmov.ads s-memset.adb \
s-memset.ads s-mufalo.adb s-mufalo.ads s-musplo.adb s-musplo.ads \
- s-sopco3.adb s-sopco3.ads s-sopco4.adb s-sopco4.ads \
- s-sopco5.adb s-sopco5.ads s-stache.adb s-stache.ads \
+ s-sam4.ads s-sopco3.adb s-sopco3.ads s-sopco4.adb s-sopco4.ads \
+ s-sopco5.adb s-sopco5.ads s-stchop.ads s-stchop.adb \
+ s-stm32.ads \
s-strcom.adb s-strcom.ads s-thread.ads \
s-vxwexc.adb s-vxwexc.ads s-vxwext.adb s-vxwext.ads \
s-win32.ads s-winext.ads
@@ -2670,9 +2677,9 @@ gnatlink-re: ../stamp-tools gnatmake-re
install-gcc-specs:
# Install all the requested GCC spec files.
- $(foreach f,$(GCC_SPEC_FILES), \
- $(INSTALL_DATA_DATE) $(srcdir)/ada/$(f) \
- $(DESTDIR)$(libsubdir)/$$(echo $(f)|sed -e 's#_[a-zA-Z0-9]*##g');)
+ for f in $(GCC_SPEC_FILES); do \
+ $(INSTALL_DATA_DATE) $(srcdir)/ada/$$f $(libsubdir)/; \
+ done
install-gnatlib: ../stamp-gnatlib-$(RTSDIR) install-gcc-specs
$(RMDIR) $(DESTDIR)$(ADA_RTL_OBJ_DIR)
@@ -2686,7 +2693,7 @@ install-gnatlib: ../stamp-gnatlib-$(RTSDIR) install-gcc-specs
$(INSTALL_DATA) $$file $(DESTDIR)$(ADA_RTL_OBJ_DIR); \
$(RANLIB_FOR_TARGET) $(DESTDIR)$(ADA_RTL_OBJ_DIR)/$$file; \
done
- -$(foreach file, $(EXTRA_ADALIB_FILES), \
+ -$(foreach file, $(EXTRA_ADALIB_OBJS), \
$(INSTALL_DATA_DATE) $(RTSDIR)/$(file) $(DESTDIR)$(ADA_RTL_OBJ_DIR) && \
) true
# Install the shared libraries, if any, using $(INSTALL) instead
@@ -2803,7 +2810,7 @@ gnatlib: ../stamp-gnatlib1-$(RTSDIR) ../stamp-gnatlib2-$(RTSDIR) $(RTSDIR)/s-osc
CFLAGS="$(GNATLIBCFLAGS_FOR_C)" \
FORCE_DEBUG_ADAFLAGS="$(FORCE_DEBUG_ADAFLAGS)" \
srcdir=$(fsrcdir) \
- -f ../Makefile $(LIBGNAT_OBJS)
+ -f ../Makefile $(LIBGNAT_OBJS) $(EXTRA_ADALIB_OBJS)
# Ada files
$(MAKE) -C $(RTSDIR) \
CC="`echo \"$(GCC_FOR_TARGET)\" \
@@ -2858,6 +2865,16 @@ gnatlib-shared-default:
cd $(RTSDIR); $(LN_S) libgnarl$(hyphen)$(LIBRARY_VERSION)$(soext) \
libgnarl$(soext)
+ # Create static libgnat and libgnarl compiled with -fPIC
+ $(RM) $(RTSDIR)/libgnat_pic$(arext) $(RTSDIR)/libgnarl_pic$(arext)
+ $(AR_FOR_TARGET) $(AR_FLAGS) $(RTSDIR)/libgnat_pic$(arext) \
+ $(addprefix $(RTSDIR)/,$(GNATRTL_NONTASKING_OBJS) $(LIBGNAT_OBJS))
+ $(RANLIB_FOR_TARGET) $(RTSDIR)/libgnat_pic$(arext)
+ $(AR_FOR_TARGET) $(AR_FLAGS) $(RTSDIR)/libgnarl_pic$(arext) \
+ $(addprefix $(RTSDIR)/,$(GNATRTL_TASKING_OBJS))
+ $(RANLIB_FOR_TARGET) $(RTSDIR)/libgnarl_pic$(arext)
+
+
gnatlib-shared-dual:
$(MAKE) $(FLAGS_TO_PASS) \
GNATLIBFLAGS="$(GNATLIBFLAGS)" \
@@ -2867,6 +2884,8 @@ gnatlib-shared-dual:
THREAD_KIND="$(THREAD_KIND)" \
gnatlib-shared-default
$(MV) $(RTSDIR)/libgna*$(soext) .
+ $(MV) $(RTSDIR)/libgnat_pic$(arext) .
+ $(MV) $(RTSDIR)/libgnarl_pic$(arext) .
$(RM) ../stamp-gnatlib2-$(RTSDIR)
$(MAKE) $(FLAGS_TO_PASS) \
GNATLIBFLAGS="$(GNATLIBFLAGS)" \
@@ -2876,6 +2895,8 @@ gnatlib-shared-dual:
THREAD_KIND="$(THREAD_KIND)" \
gnatlib
$(MV) libgna*$(soext) $(RTSDIR)
+ $(MV) libgnat_pic$(arext) $(RTSDIR)
+ $(MV) libgnarl_pic$(arext) $(RTSDIR)
gnatlib-shared-dual-win32:
$(MAKE) $(FLAGS_TO_PASS) \
@@ -2910,6 +2931,8 @@ gnatlib-shared-win32:
THREAD_KIND="$(THREAD_KIND)" \
gnatlib
$(RM) $(RTSDIR)/libgna*$(soext)
+ $(CP) $(RTSDIR)/libgnat$(arext) $(RTSDIR)/libgnat_pic$(arext)
+ $(CP) $(RTSDIR)/libgnarl$(arext) $(RTSDIR)/libgnarl_pic$(arext)
cd $(RTSDIR); `echo "$(GCC_FOR_TARGET)" \
| sed -e 's,\./xgcc,../../xgcc,' -e 's,-B\./,-B../../,'` -shared -shared-libgcc \
$(PICFLAG_FOR_TARGET) \
@@ -2933,6 +2956,8 @@ gnatlib-shared-darwin:
THREAD_KIND="$(THREAD_KIND)" \
gnatlib
$(RM) $(RTSDIR)/libgnat$(soext) $(RTSDIR)/libgnarl$(soext)
+ $(CP) $(RTSDIR)/libgnat$(arext) $(RTSDIR)/libgnat_pic$(arext)
+ $(CP) $(RTSDIR)/libgnarl$(arext) $(RTSDIR)/libgnarl_pic$(arext)
cd $(RTSDIR); `echo "$(GCC_FOR_TARGET)" \
| sed -e 's,\./xgcc,../../xgcc,' -e 's,-B\./,-B../../,'` -dynamiclib $(PICFLAG_FOR_TARGET) \
-o libgnat$(hyphen)$(LIBRARY_VERSION)$(soext) \
@@ -2964,14 +2989,12 @@ gnatlib-shared:
PICFLAG_FOR_TARGET="$(PICFLAG_FOR_TARGET)" \
$(GNATLIB_SHARED)
-# When building a SJLJ runtime for VxWorks, in addition to forcing
-# ZCX_By_default to False, we need to ensure that extra linker options
-# are not passed to prevent the inclusion of useless objects and
-# potential troubles from the presence of extra symbols and references
-# in some configurations. The inhibition is performed by commenting
-# the pragma instead of deleting the line, as the latter might result
-# in getting multiple blank lines, hence a style check error, as a
-# result.
+# When building a SJLJ runtime for VxWorks, we need to ensure that the extra
+# linker options needed for ZCX are not passed to prevent the inclusion of
+# useless objects and potential troubles from the presence of extra symbols
+# and references in some configurations. The inhibition is performed by
+# commenting the pragma instead of deleting the line, as the latter might
+# result in getting multiple blank lines, hence possible style check errors.
gnatlib-sjlj:
$(MAKE) $(FLAGS_TO_PASS) EH_MECHANISM="" \
THREAD_KIND="$(THREAD_KIND)" ../stamp-gnatlib1-$(RTSDIR)
@@ -3058,8 +3081,8 @@ s-tasdeb.o : s-tasdeb.adb s-tasdeb.ads
# use -O1 otherwise gdb isn't able to get a full backtrace on mips targets.
a-except.o : a-except.adb a-except.ads
- $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O1 -fno-inline \
- $(NO_REORDER_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION)
+ $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) $(NO_INLINE_ADAFLAGS) \
+ $(NO_REORDER_ADAFLAGS) -O1 $(ADA_INCLUDES) $< $(OUTPUT_OPTION)
# compile s-excdeb.o without optimization and with debug info to let the
# debugger set breakpoints and inspect subprogram parameters on exception
@@ -3083,11 +3106,19 @@ a-tags.o : a-tags.adb a-tags.ads
$(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) $(ADA_INCLUDES) \
$< $(OUTPUT_OPTION)
-# need to keep the frame pointer in this file to pop the stack properly on
+# force no sibling call optimization on s-memory.o to avoid turning the
+# tail recursion in Alloc into a loop that confuses branch prediction.
+
+s-memory.o : s-memory.adb s-memory.ads
+ $(CC) -c $(ALL_ADAFLAGS) $(NO_SIBLING_ADAFLAGS) $(ADA_INCLUDES) \
+ $< $(OUTPUT_OPTION)
+
+# need to keep the frame pointer in tracebak.o to pop the stack properly on
# some targets.
+
tracebak.o : tracebak.c tb-gcc.c
$(COMPILER) -c $(ALL_COMPILERFLAGS) $(ADA_CFLAGS) $(ALL_CPPFLAGS) \
- $(INCLUDES) -fno-omit-frame-pointer $< $(OUTPUT_OPTION)
+ $(INCLUDES) $(NO_OMIT_ADAFLAGS) $< $(OUTPUT_OPTION)
adadecode.o : adadecode.c adadecode.h
aux-io.o : aux-io.c
@@ -3106,8 +3137,10 @@ socket.o : socket.c gsocket.h
sysdep.o : sysdep.c
raise.o : raise.c raise.h
sigtramp-armdroid.o : sigtramp-armdroid.c sigtramp.h
-sigtramp-vxworks.o : sigtramp-vxworks.c sigtramp.h sigtramp-vxworks-target.inc
-sigtramp-vxworks-vxsim.o : sigtramp-vxworks-vxsim.c sigtramp.h sigtramp-vxworks-target.inc
+sigtramp-armvxworks.o : sigtramp-armvxworks.c sigtramp.h
+sigtramp-ios.o : sigtramp-ios.c sigtramp.h
+sigtramp-vxworks.o : sigtramp-vxworks.c $(VX_SIGTRAMP_EXTRA_SRCS)
+sigtramp-vxworks-vxsim.o : sigtramp-vxworks-vxsim.c $(VX_SIGTRAMP_EXTRA_SRCS)
terminals.o : terminals.c
vx_stack_info.o : vx_stack_info.c
@@ -3124,6 +3157,21 @@ init.o : init.c adaint.h raise.h
$(COMPILER) -c $(ALL_COMPILERFLAGS) $(ADA_CFLAGS) \
$(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION)
+vx_crtbegin.o : vx_crtbegin.c vx_crtbegin.inc
+ $(COMPILER) -c $(ALL_COMPILERFLAGS) $(ADA_CFLAGS) \
+ -iquote $(srcdir) -iquote $(ftop_srcdir)/libgcc \
+ $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION)
+
+vx_crtbegin_auto.o : vx_crtbegin_auto.c vx_crtbegin.inc
+ $(COMPILER) -c $(ALL_COMPILERFLAGS) $(ADA_CFLAGS) \
+ -iquote $(srcdir) -iquote $(ftop_srcdir)/libgcc \
+ $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION)
+
+vx_crtend.o : vx_crtend.c
+ $(COMPILER) -c $(ALL_COMPILERFLAGS) $(ADA_CFLAGS) \
+ -iquote $(srcdir) -iquote $(ftop_srcdir)/libgcc \
+ $(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION)
+
init-vxsim.o : init-vxsim.c
$(COMPILER) -c $(ALL_COMPILERFLAGS) $(ADA_CFLAGS) \
$(ALL_CPPFLAGS) $(INCLUDES) $< $(OUTPUT_OPTION)
diff --git a/gcc/ada/gcc-interface/ada-tree.h b/gcc/ada/gcc-interface/ada-tree.h
index ac4ec2f81c..a3d38b1b22 100644
--- a/gcc/ada/gcc-interface/ada-tree.h
+++ b/gcc/ada/gcc-interface/ada-tree.h
@@ -180,12 +180,11 @@ do { \
#define TYPE_IS_PADDING_P(NODE) \
(TREE_CODE (NODE) == RECORD_TYPE && TYPE_PADDING_P (NODE))
-/* True if TYPE can alias any other types. */
+/* True for a non-dummy type if TYPE can alias any other types. */
#define TYPE_UNIVERSAL_ALIASING_P(NODE) TYPE_LANG_FLAG_6 (NODE)
-/* For RECORD_TYPE, UNION_TYPE, and QUAL_UNION_TYPE, this holds the maximum
- alignment value the type ought to have. */
-#define TYPE_MAX_ALIGN(NODE) (TYPE_PRECISION (RECORD_OR_UNION_CHECK (NODE)))
+/* True for a dummy type if TYPE appears in a profile. */
+#define TYPE_DUMMY_IN_PROFILE_P(NODE) TYPE_LANG_FLAG_6 (NODE)
/* True for types that implement a packed array and for original packed array
types. */
@@ -196,6 +195,13 @@ do { \
/* True for types that can hold a debug type. */
#define TYPE_CAN_HAVE_DEBUG_TYPE_P(NODE) (!TYPE_IMPL_PACKED_ARRAY_P (NODE))
+/* For RECORD_TYPE, UNION_TYPE, and QUAL_UNION_TYPE, this holds the maximum
+ alignment value the type ought to have. */
+#define TYPE_MAX_ALIGN(NODE) (TYPE_PRECISION (RECORD_OR_UNION_CHECK (NODE)))
+
+/* True if objects of tagged types are guaranteed to be properly aligned. */
+#define TYPE_ALIGN_OK(NODE) TYPE_LANG_FLAG_7 (NODE)
+
/* For an UNCONSTRAINED_ARRAY_TYPE, this is the record containing both the
template and the object.
diff --git a/gcc/ada/gcc-interface/decl.c b/gcc/ada/gcc-interface/decl.c
index 6f2b0bbfd2..35fd92f33d 100644
--- a/gcc/ada/gcc-interface/decl.c
+++ b/gcc/ada/gcc-interface/decl.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2016, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2017, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -34,6 +34,7 @@
#include "fold-const.h"
#include "stor-layout.h"
#include "tree-inline.h"
+#include "demangle.h"
#include "ada.h"
#include "types.h"
@@ -96,13 +97,13 @@ struct incomplete
};
/* These variables are used to defer recursively expanding incomplete types
- while we are processing an array, a record or a subprogram type. */
+ while we are processing a record, an array or a subprogram type. */
static int defer_incomplete_level = 0;
static struct incomplete *defer_incomplete_list;
/* This variable is used to delay expanding From_Limited_With types until the
end of the spec. */
-static struct incomplete *defer_limited_with;
+static struct incomplete *defer_limited_with_list;
typedef struct subst_pair_d {
tree discriminant;
@@ -125,8 +126,7 @@ typedef struct variant_desc_d {
} variant_desc;
-/* A hash table used to cache the result of annotate_value. */
-
+/* A map used to cache the result of annotate_value. */
struct value_annotation_hasher : ggc_cache_ptr_hash<tree_int_map>
{
static inline hashval_t
@@ -150,6 +150,47 @@ struct value_annotation_hasher : ggc_cache_ptr_hash<tree_int_map>
static GTY ((cache)) hash_table<value_annotation_hasher> *annotate_value_cache;
+/* A map used to associate a dummy type with a list of subprogram entities. */
+struct GTY((for_user)) tree_entity_vec_map
+{
+ struct tree_map_base base;
+ vec<Entity_Id, va_gc_atomic> *to;
+};
+
+void
+gt_pch_nx (Entity_Id &)
+{
+}
+
+void
+gt_pch_nx (Entity_Id *x, gt_pointer_operator op, void *cookie)
+{
+ op (x, cookie);
+}
+
+struct dummy_type_hasher : ggc_cache_ptr_hash<tree_entity_vec_map>
+{
+ static inline hashval_t
+ hash (tree_entity_vec_map *m)
+ {
+ return htab_hash_pointer (m->base.from);
+ }
+
+ static inline bool
+ equal (tree_entity_vec_map *a, tree_entity_vec_map *b)
+ {
+ return a->base.from == b->base.from;
+ }
+
+ static int
+ keep_cache_entry (tree_entity_vec_map *&m)
+ {
+ return ggc_marked_p (m->base.from);
+ }
+};
+
+static GTY ((cache)) hash_table<dummy_type_hasher> *dummy_to_subprog_map;
+
static void prepend_one_attribute (struct attrib **,
enum attrib_type, tree, tree, Node_Id);
static void prepend_one_attribute_pragma (struct attrib **, Node_Id);
@@ -162,11 +203,12 @@ static tree elaborate_expression_2 (tree, Entity_Id, const char *, bool, bool,
unsigned int);
static tree elaborate_reference (tree, Entity_Id, bool, tree *);
static tree gnat_to_gnu_component_type (Entity_Id, bool, bool);
-static tree gnat_to_gnu_param (Entity_Id, Mechanism_Type, Entity_Id, bool,
- bool *);
+static tree gnat_to_gnu_subprog_type (Entity_Id, bool, bool, tree *);
static tree gnat_to_gnu_field (Entity_Id, tree, int, bool, bool);
-static bool is_from_limited_with_of_main (Entity_Id);
+static tree gnu_ext_name_for_subprog (Entity_Id, tree);
static tree change_qualified_type (tree, int);
+static void set_nonaliased_component_on_array_type (tree);
+static void set_reverse_storage_order_on_array_type (tree);
static bool same_discriminant_p (Entity_Id, Entity_Id);
static bool array_type_has_nonaliased_component (tree, Entity_Id);
static bool compile_time_known_address_p (Node_Id);
@@ -217,15 +259,13 @@ static bool intrin_profiles_compatible_p (intrin_binding_t *);
initial value (in GCC tree form). This is optional for a variable. For
a renamed entity, GNU_EXPR gives the object being renamed.
- DEFINITION is nonzero if this call is intended for a definition. This is
- used for separate compilation where it is necessary to know whether an
- external declaration or a definition must be created if the GCC equivalent
- was not created previously. The value of 1 is normally used for a nonzero
- DEFINITION, but a value of 2 is used in special circumstances, defined in
- the code. */
+ DEFINITION is true if this call is intended for a definition. This is used
+ for separate compilation where it is necessary to know whether an external
+ declaration or a definition must be created if the GCC equivalent was not
+ created previously. */
tree
-gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
+gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, bool definition)
{
/* Contains the kind of the input GNAT node. */
const Entity_Kind kind = Ekind (gnat_entity);
@@ -306,7 +346,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
|| (IN (Ekind (gnat_temp), Subprogram_Kind)
&& present_gnu_tree (gnat_temp)
&& (current_function_decl
- == gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0))))
+ == gnat_to_gnu_entity (gnat_temp, NULL_TREE, false))))
{
process_type (gnat_entity);
return get_gnu_tree (gnat_entity);
@@ -337,7 +377,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
|| No (Freeze_Node (Full_View (gnat_entity)))))
{
gnu_decl
- = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, 0);
+ = gnat_to_gnu_entity (Full_View (gnat_entity), NULL_TREE, false);
save_gnu_tree (gnat_entity, NULL_TREE, false);
save_gnu_tree (gnat_entity, gnu_decl, false);
}
@@ -349,7 +389,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
must be specified unless it was specified by the programmer. Exceptions
are for access-to-protected-subprogram types and all access subtypes, as
another GNAT type is used to lay out the GCC type for them. */
- gcc_assert (!Unknown_Esize (gnat_entity)
+ gcc_assert (!is_type
+ || Known_Esize (gnat_entity)
|| Has_Size_Clause (gnat_entity)
|| (!IN (kind, Numeric_Kind)
&& !IN (kind, Enumeration_Kind)
@@ -459,8 +500,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
be a FIELD_DECL. Likewise for discriminants. If the entity is a
non-girder discriminant (in the case of derived untagged record
types), return the stored discriminant it renames. */
- else if (Present (Original_Record_Component (gnat_entity))
- && Original_Record_Component (gnat_entity) != gnat_entity)
+ if (Present (Original_Record_Component (gnat_entity))
+ && Original_Record_Component (gnat_entity) != gnat_entity)
{
gnu_decl
= gnat_to_gnu_entity (Original_Record_Component (gnat_entity),
@@ -472,7 +513,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
/* Otherwise, if we are not defining this and we have no GCC type
for the containing record, make one for it. Then we should
have made our own equivalent. */
- else if (!definition && !present_gnu_tree (gnat_record))
+ if (!definition && !present_gnu_tree (gnat_record))
{
/* ??? If this is in a record whose scope is a protected
type and we have an Original_Record_Component, use it.
@@ -485,22 +526,22 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
gnu_decl
= gnat_to_gnu_entity (Original_Record_Component
(gnat_entity),
- gnu_expr, 0);
- saved = true;
- break;
+ gnu_expr, false);
+ }
+ else
+ {
+ gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, false);
+ gnu_decl = get_gnu_tree (gnat_entity);
}
- gnat_to_gnu_entity (Scope (gnat_entity), NULL_TREE, 0);
- gnu_decl = get_gnu_tree (gnat_entity);
saved = true;
break;
}
- else
- /* Here we have no GCC type and this is a reference rather than a
- definition. This should never happen. Most likely the cause is
- reference before declaration in the GNAT tree for gnat_entity. */
- gcc_unreachable ();
+ /* Here we have no GCC type and this is a reference rather than a
+ definition. This should never happen. Most likely the cause is
+ reference before declaration in the GNAT tree for gnat_entity. */
+ gcc_unreachable ();
}
case E_Constant:
@@ -537,7 +578,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
&& Present (Full_View (gnat_entity)))
{
gnu_decl
- = gnat_to_gnu_entity (Full_View (gnat_entity), gnu_expr, 0);
+ = gnat_to_gnu_entity (Full_View (gnat_entity), gnu_expr, false);
saved = true;
break;
}
@@ -564,6 +605,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
case E_Out_Parameter:
case E_Variable:
{
+ const Entity_Id gnat_type = Etype (gnat_entity);
/* Always create a variable for volatile objects and variables seen
constant but with a Linker_Section pragma. */
bool const_flag
@@ -598,20 +640,26 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
{
if (kind == E_Exception)
gnu_expr = gnat_to_gnu_entity (Renamed_Entity (gnat_entity),
- NULL_TREE, 0);
+ NULL_TREE, false);
else
gnu_expr = gnat_to_gnu_external (Renamed_Object (gnat_entity));
}
/* Get the type after elaborating the renamed object. */
- gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
-
- /* If this is a standard exception definition, then use the standard
- exception type. This is necessary to make sure that imported and
- exported views of exceptions are properly merged in LTO mode. */
- if (TREE_CODE (TYPE_NAME (gnu_type)) == TYPE_DECL
- && DECL_NAME (TYPE_NAME (gnu_type)) == exception_data_name_id)
- gnu_type = except_type_node;
+ if (Has_Foreign_Convention (gnat_entity)
+ && Is_Descendant_Of_Address (gnat_type))
+ gnu_type = ptr_type_node;
+ else
+ {
+ gnu_type = gnat_to_gnu_type (gnat_type);
+
+ /* If this is a standard exception definition, use the standard
+ exception type. This is necessary to make sure that imported
+ and exported views of exceptions are merged in LTO mode. */
+ if (TREE_CODE (TYPE_NAME (gnu_type)) == TYPE_DECL
+ && DECL_NAME (TYPE_NAME (gnu_type)) == exception_data_name_id)
+ gnu_type = except_type_node;
+ }
/* For a debug renaming declaration, build a debug-only entity. */
if (Present (Debug_Renaming_Link (gnat_entity)))
@@ -625,6 +673,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
VAR_DECL, gnu_entity_name, gnu_type);
SET_DECL_VALUE_EXPR (gnu_decl, value);
DECL_HAS_VALUE_EXPR_P (gnu_decl) = 1;
+ TREE_STATIC (gnu_decl) = global_bindings_p ();
gnat_pushdecl (gnu_decl, gnat_entity);
break;
}
@@ -752,10 +801,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
mutable_p = true;
}
- /* If we are at global level and the size isn't constant, call
+ /* If the size isn't constant and we are at global level, call
elaborate_expression_1 to make a variable for it rather than
calculating it each time. */
- if (global_bindings_p () && !TREE_CONSTANT (gnu_size))
+ if (!TREE_CONSTANT (gnu_size) && global_bindings_p ())
gnu_size = elaborate_expression_1 (gnu_size, gnat_entity,
"SIZE", definition, false);
}
@@ -773,7 +822,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
|| (TYPE_SIZE (gnu_type)
&& integer_zerop (TYPE_SIZE (gnu_type))
&& !TREE_OVERFLOW (TYPE_SIZE (gnu_type))))
- && !Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
+ && !Is_Constr_Subt_For_UN_Aliased (gnat_type)
&& No (Renamed_Object (gnat_entity))
&& No (Address_Clause (gnat_entity)))
gnu_size = bitsize_unit_node;
@@ -789,8 +838,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
|| (!Optimize_Alignment_Space (gnat_entity)
&& kind != E_Exception
&& kind != E_Out_Parameter
- && Is_Composite_Type (Etype (gnat_entity))
- && !Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
+ && Is_Composite_Type (gnat_type)
+ && !Is_Constr_Subt_For_UN_Aliased (gnat_type)
&& !Is_Exported (gnat_entity)
&& !imported_p
&& No (Renamed_Object (gnat_entity))
@@ -856,12 +905,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
/* If this is an aliased object with an unconstrained array nominal
subtype, make a type that includes the template. We will either
allocate or create a variable of that type, see below. */
- if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
- && Is_Array_Type (Underlying_Type (Etype (gnat_entity)))
+ if (Is_Constr_Subt_For_UN_Aliased (gnat_type)
+ && Is_Array_Type (Underlying_Type (gnat_type))
&& !type_annotate_only)
{
- tree gnu_array
- = gnat_to_gnu_type (Base_Type (Etype (gnat_entity)));
+ tree gnu_array = gnat_to_gnu_type (Base_Type (gnat_type));
gnu_type
= build_unc_object_type_from_ptr (TREE_TYPE (gnu_array),
gnu_type,
@@ -875,7 +923,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
without pessimizing the allocation. This is a kludge necessary
because we don't support dynamic alignment. */
if (align == 0
- && Ekind (Etype (gnat_entity)) == E_Class_Wide_Subtype
+ && Ekind (gnat_type) == E_Class_Wide_Subtype
&& No (Renamed_Object (gnat_entity))
&& No (Address_Clause (gnat_entity)))
align = get_target_system_allocator_alignment () * BITS_PER_UNIT;
@@ -1028,6 +1076,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
gcc_assert (ralign >= align);
}
+ /* The expression might not be a DECL so save it manually. */
save_gnu_tree (gnat_entity, gnu_decl, true);
saved = true;
annotate_object (gnat_entity, gnu_type, NULL_TREE, false);
@@ -1130,10 +1179,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
if (definition && Present (Address_Clause (gnat_entity)))
{
const Node_Id gnat_clause = Address_Clause (gnat_entity);
- Node_Id gnat_expr = Expression (gnat_clause);
+ Node_Id gnat_address = Expression (gnat_clause);
tree gnu_address
= present_gnu_tree (gnat_entity)
- ? get_gnu_tree (gnat_entity) : gnat_to_gnu (gnat_expr);
+ ? get_gnu_tree (gnat_entity) : gnat_to_gnu (gnat_address);
save_gnu_tree (gnat_entity, NULL_TREE, false);
@@ -1147,15 +1196,15 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
used_by_ref = true;
const_flag
= (!Is_Public (gnat_entity)
- || compile_time_known_address_p (gnat_expr));
+ || compile_time_known_address_p (gnat_address));
volatile_flag = false;
gnu_size = NULL_TREE;
/* If this is an aliased object with an unconstrained array nominal
subtype, then it can overlay only another aliased object with an
unconstrained array nominal subtype and compatible template. */
- if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
- && Is_Array_Type (Underlying_Type (Etype (gnat_entity)))
+ if (Is_Constr_Subt_For_UN_Aliased (gnat_type)
+ && Is_Array_Type (Underlying_Type (gnat_type))
&& !type_annotate_only)
{
tree rec_type = TREE_TYPE (gnu_type);
@@ -1293,7 +1342,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
= TREE_TYPE (DECL_CHAIN (TYPE_FIELDS (gnu_alloc_type)));
if (TREE_CODE (gnu_expr) == CONSTRUCTOR
- && vec_safe_length (CONSTRUCTOR_ELTS (gnu_expr)) == 1)
+ && CONSTRUCTOR_NELTS (gnu_expr) == 1)
gnu_expr = NULL_TREE;
else
gnu_expr
@@ -1320,10 +1369,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
than the largest stack alignment the back-end can honor, resort to
a variable of "aligning type". */
if (definition
- && !global_bindings_p ()
- && !static_flag
+ && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT
&& !imported_p
- && TYPE_ALIGN (gnu_type) > BIGGEST_ALIGNMENT)
+ && !static_flag
+ && !global_bindings_p ())
{
/* Create the new variable. No need for extra room before the
aligned field as this is in automatic storage. */
@@ -1368,8 +1417,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
This is aimed to make it easier for the debugger to decode the
object. Note that we have to do it this late because of the
couple of allocation adjustments that might be made above. */
- if (Is_Constr_Subt_For_UN_Aliased (Etype (gnat_entity))
- && Is_Array_Type (Underlying_Type (Etype (gnat_entity)))
+ if (Is_Constr_Subt_For_UN_Aliased (gnat_type)
+ && Is_Array_Type (Underlying_Type (gnat_type))
&& !type_annotate_only)
{
/* In case the object with the template has already been allocated
@@ -1396,15 +1445,11 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
gnu_size = NULL_TREE;
}
- tree gnu_array
- = gnat_to_gnu_type (Base_Type (Etype (gnat_entity)));
+ tree gnu_array = gnat_to_gnu_type (Base_Type (gnat_type));
gnu_type
= build_reference_type (TYPE_OBJECT_RECORD_TYPE (gnu_array));
}
- if (const_flag)
- gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_CONST);
-
/* Convert the expression to the type of the object if need be. */
if (gnu_expr && initial_value_needs_conversion (gnu_type, gnu_expr))
gnu_expr = convert (gnu_type, gnu_expr);
@@ -1456,7 +1501,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
&& !optimize
&& !flag_generate_lto)
{
- tree param = create_param_decl (gnu_entity_name, gnu_type, false);
+ tree param = create_param_decl (gnu_entity_name, gnu_type);
gnat_pushdecl (param, gnat_entity);
SET_DECL_VALUE_EXPR (param, gnu_decl);
DECL_HAS_VALUE_EXPR_P (param) = 1;
@@ -1486,7 +1531,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
&& No (Address_Clause (gnat_entity)))
|| Address_Taken (gnat_entity)
|| Is_Aliased (gnat_entity)
- || Is_Aliased (Etype (gnat_entity))))
+ || Is_Aliased (gnat_type)))
{
tree gnu_corr_var
= create_var_decl (gnu_entity_name, gnu_ext_name, gnu_type,
@@ -1772,7 +1817,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
&& !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
&& (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
|| !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
- gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), gnu_expr, 0);
+ gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), gnu_expr, false);
/* Set the precision to the Esize except for bit-packed arrays. */
if (Is_Packed_Array_Impl_Type (gnat_entity)
@@ -1782,15 +1827,21 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
/* First subtypes of Character are treated as Character; otherwise
this should be an unsigned type if the base type is unsigned or
if the lower bound is constant and non-negative or if the type
- is biased. */
+ is biased. However, even if the lower bound is constant and
+ non-negative, we use a signed type for a subtype with the same
+ size as its signed base type, because this eliminates useless
+ conversions to it and gives more leeway to the optimizer; but
+ this means that we will need to explicitly test for this case
+ when we change the representation based on the RM size. */
if (kind == E_Enumeration_Subtype
&& No (First_Literal (Etype (gnat_entity)))
&& Esize (gnat_entity) == RM_Size (gnat_entity)
&& esize == CHAR_TYPE_SIZE
&& flag_signed_char)
gnu_type = make_signed_type (CHAR_TYPE_SIZE);
- else if (Is_Unsigned_Type (Etype (gnat_entity))
- || Is_Unsigned_Type (gnat_entity)
+ else if (Is_Unsigned_Type (Underlying_Type (Etype (gnat_entity)))
+ || (Esize (Etype (gnat_entity)) != Esize (gnat_entity)
+ && Is_Unsigned_Type (gnat_entity))
|| Has_Biased_Representation (gnat_entity))
gnu_type = make_unsigned_type (esize);
else
@@ -1810,8 +1861,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
TYPE_BIASED_REPRESENTATION_P (gnu_type)
= Has_Biased_Representation (gnat_entity);
- /* Set TYPE_STRING_FLAG for Character and Wide_Character subtypes. */
- TYPE_STRING_FLAG (gnu_type) = TYPE_STRING_FLAG (TREE_TYPE (gnu_type));
+ /* Do the same processing for Character subtypes as for types. */
+ if (TYPE_STRING_FLAG (TREE_TYPE (gnu_type)))
+ {
+ TYPE_NAME (gnu_type) = gnu_entity_name;
+ TYPE_STRING_FLAG (gnu_type) = 1;
+ TYPE_ARTIFICIAL (gnu_type) = artificial_p;
+ finish_character_type (gnu_type);
+ }
/* Inherit our alias set from what we're a subtype of. Subtypes
are not different types and a pointer can designate any instance
@@ -1889,8 +1946,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
This means that bit-packed arrays are given "ceil" alignment for
their size by default, which may seem counter-intuitive but makes
it possible to overlay them on modular types easily. */
- TYPE_ALIGN (gnu_type)
- = align > 0 ? align : TYPE_ALIGN (gnu_field_type);
+ SET_TYPE_ALIGN (gnu_type,
+ align > 0 ? align : TYPE_ALIGN (gnu_field_type));
/* Propagate the reverse storage order flag to the record type so
that the required byte swapping is performed when retrieving the
@@ -1907,7 +1964,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
= create_field_decl (get_identifier ("OBJECT"), gnu_field_type,
gnu_type, NULL_TREE, bitsize_zero_node, 1, 0);
- /* Do not emit debug info until after the parallel type is added. */
+ /* We will output additional debug info manually below. */
finish_record_type (gnu_type, gnu_field, 2, false);
compute_record_mode (gnu_type);
TYPE_JUSTIFIED_MODULAR_P (gnu_type) = 1;
@@ -1921,53 +1978,25 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
implementation type, the padded type is its debug type. */
if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
SET_TYPE_DEBUG_TYPE (gnu_type, gnu_field_type);
-
- rest_of_record_type_compilation (gnu_type);
}
}
/* If the type we are dealing with has got a smaller alignment than the
natural one, we need to wrap it up in a record type and misalign the
- latter; we reuse the padding machinery for this purpose. Note that,
- even if the record type is marked as packed because of misalignment,
- we don't pack the field so as to give it the size of the type. */
+ latter; we reuse the padding machinery for this purpose. */
else if (align > 0)
{
- tree gnu_field_type, gnu_field;
-
- /* Set the RM size before wrapping up the type. */
- SET_TYPE_RM_SIZE (gnu_type,
- UI_To_gnu (RM_Size (gnat_entity), bitsizetype));
+ tree gnu_size = UI_To_gnu (RM_Size (gnat_entity), bitsizetype);
- /* Create a stripped-down declaration, mainly for debugging. */
- create_type_decl (gnu_entity_name, gnu_type, true, debug_info_p,
- gnat_entity);
+ /* Set the RM size before wrapping the type. */
+ SET_TYPE_RM_SIZE (gnu_type, gnu_size);
- /* Now save it and build the enclosing record type. */
- gnu_field_type = gnu_type;
+ gnu_type
+ = maybe_pad_type (gnu_type, TYPE_SIZE (gnu_type), align,
+ gnat_entity, false, true, definition, false);
- gnu_type = make_node (RECORD_TYPE);
- TYPE_NAME (gnu_type) = create_concat_name (gnat_entity, "PAD");
- if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
- SET_TYPE_DEBUG_TYPE (gnu_type, gnu_field_type);
TYPE_PACKED (gnu_type) = 1;
- TYPE_SIZE (gnu_type) = TYPE_SIZE (gnu_field_type);
- TYPE_SIZE_UNIT (gnu_type) = TYPE_SIZE_UNIT (gnu_field_type);
- SET_TYPE_ADA_SIZE (gnu_type, TYPE_RM_SIZE (gnu_field_type));
- TYPE_ALIGN (gnu_type) = align;
- relate_alias_sets (gnu_type, gnu_field_type, ALIAS_SET_COPY);
-
- /* Don't declare the field as addressable since we won't be taking
- its address and this would prevent create_field_decl from making
- a bitfield. */
- gnu_field
- = create_field_decl (get_identifier ("F"), gnu_field_type,
- gnu_type, TYPE_SIZE (gnu_field_type),
- bitsize_zero_node, 0, 0);
-
- finish_record_type (gnu_type, gnu_field, 2, debug_info_p);
- compute_record_mode (gnu_type);
- TYPE_PADDING_P (gnu_type) = 1;
+ SET_TYPE_ADA_SIZE (gnu_type, gnu_size);
}
break;
@@ -1987,7 +2016,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
&& !In_Extended_Main_Code_Unit (Ancestor_Subtype (gnat_entity))
&& (!Compile_Time_Known_Value (Type_Low_Bound (gnat_entity))
|| !Compile_Time_Known_Value (Type_High_Bound (gnat_entity))))
- gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), gnu_expr, 0);
+ gnat_to_gnu_entity (Ancestor_Subtype (gnat_entity), gnu_expr, false);
gnu_type = make_node (REAL_TYPE);
TREE_TYPE (gnu_type) = get_unpadded_type (Etype (gnat_entity));
@@ -2252,12 +2281,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
for (index = ndim - 1; index >= 0; index--)
{
tem = build_nonshared_array_type (tem, gnu_index_types[index]);
- if (index == ndim - 1)
- TYPE_REVERSE_STORAGE_ORDER (tem)
- = Reverse_Storage_Order (gnat_entity);
TYPE_MULTI_ARRAY_P (tem) = (index > 0);
+ TYPE_CONVENTION_FORTRAN_P (tem) = convention_fortran_p;
+ if (index == ndim - 1 && Reverse_Storage_Order (gnat_entity))
+ set_reverse_storage_order_on_array_type (tem);
if (array_type_has_nonaliased_component (tem, gnat_entity))
- TYPE_NONALIASED_COMPONENT (tem) = 1;
+ set_nonaliased_component_on_array_type (tem);
}
/* If an alignment is specified, use it if valid. But ignore it
@@ -2266,15 +2295,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
if (No (Packed_Array_Impl_Type (gnat_entity))
&& Known_Alignment (gnat_entity))
{
- TYPE_ALIGN (tem)
- = validate_alignment (Alignment (gnat_entity), gnat_entity,
- TYPE_ALIGN (tem));
+ SET_TYPE_ALIGN (tem,
+ validate_alignment (Alignment (gnat_entity),
+ gnat_entity,
+ TYPE_ALIGN (tem)));
if (Present (Alignment_Clause (gnat_entity)))
TYPE_USER_ALIGN (tem) = 1;
}
- TYPE_CONVENTION_FORTRAN_P (tem) = convention_fortran_p;
-
/* Tag top-level ARRAY_TYPE nodes for packed arrays and their
implementation types as such so that the debug information back-end
can output the appropriate description for them. */
@@ -2297,7 +2325,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
TYPE_POINTER_TO (gnu_type) = gnu_fat_type;
TYPE_REFERENCE_TO (gnu_type) = gnu_fat_type;
SET_TYPE_MODE (gnu_type, BLKmode);
- TYPE_ALIGN (gnu_type) = TYPE_ALIGN (tem);
+ SET_TYPE_ALIGN (gnu_type, TYPE_ALIGN (tem));
/* If the maximum size doesn't overflow, use it. */
if (gnu_max_size
@@ -2637,12 +2665,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
{
gnu_type = build_nonshared_array_type (gnu_type,
gnu_index_types[index]);
- if (index == ndim - 1)
- TYPE_REVERSE_STORAGE_ORDER (gnu_type)
- = Reverse_Storage_Order (gnat_entity);
TYPE_MULTI_ARRAY_P (gnu_type) = (index > 0);
+ TYPE_CONVENTION_FORTRAN_P (gnu_type) = convention_fortran_p;
+ if (index == ndim - 1 && Reverse_Storage_Order (gnat_entity))
+ set_reverse_storage_order_on_array_type (gnu_type);
if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
- TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
+ set_nonaliased_component_on_array_type (gnu_type);
}
/* Strip the ___XP suffix for standard DWARF. */
@@ -2660,10 +2688,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
TYPE_STUB_DECL (gnu_type)
= create_type_stub_decl (gnu_entity_name, gnu_type);
- /* If we are at file level and this is a multi-dimensional array,
+ /* If this is a multi-dimensional array and we are at global level,
we need to make a variable corresponding to the stride of the
inner dimensions. */
- if (global_bindings_p () && ndim > 1)
+ if (ndim > 1 && global_bindings_p ())
{
tree gnu_arr_type;
@@ -2741,7 +2769,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
else
{
tree gnu_base_decl
- = gnat_to_gnu_entity (Etype (gnat_entity), NULL_TREE, 0);
+ = gnat_to_gnu_entity (Etype (gnat_entity), NULL_TREE,
+ false);
if (!DECL_ARTIFICIAL (gnu_base_decl)
&& gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
add_parallel_type (gnu_type,
@@ -2749,7 +2778,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
}
}
- TYPE_CONVENTION_FORTRAN_P (gnu_type) = convention_fortran_p;
TYPE_PACKED_ARRAY_TYPE_P (gnu_type)
= (Is_Packed_Array_Impl_Type (gnat_entity)
&& Is_Bit_Packed_Array (Original_Array_Type (gnat_entity)));
@@ -2814,11 +2842,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
gnu_decl
= gnat_to_gnu_entity (Packed_Array_Impl_Type (gnat_entity),
- NULL_TREE, 0);
+ NULL_TREE, false);
this_made_decl = true;
gnu_type = TREE_TYPE (gnu_decl);
-
save_gnu_tree (gnat_entity, NULL_TREE, false);
+ save_gnu_tree (gnat_entity, gnu_decl, false);
+ saved = true;
gnu_inner = gnu_type;
while (TREE_CODE (gnu_inner) == RECORD_TYPE
@@ -2875,10 +2904,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
TREE_TYPE (TYPE_FIELDS (gnu_type)) = gnu_inner;
}
}
-
- else
- /* Abort if packed array with no Packed_Array_Impl_Type. */
- gcc_assert (!Is_Packed (gnat_entity));
}
break;
@@ -2920,7 +2945,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
(Component_Type (gnat_entity)),
gnu_index_type);
if (array_type_has_nonaliased_component (gnu_type, gnat_entity))
- TYPE_NONALIASED_COMPONENT (gnu_type) = 1;
+ set_nonaliased_component_on_array_type (gnu_type);
relate_alias_sets (gnu_type, gnu_string_type, ALIAS_SET_COPY);
}
break;
@@ -3038,11 +3063,12 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
/* Always set the alignment on the record type here so that it can
get the proper layout. */
if (has_align)
- TYPE_ALIGN (gnu_type)
- = validate_alignment (Alignment (gnat_entity), gnat_entity, 0);
+ SET_TYPE_ALIGN (gnu_type,
+ validate_alignment (Alignment (gnat_entity),
+ gnat_entity, 0));
else
{
- TYPE_ALIGN (gnu_type) = 0;
+ SET_TYPE_ALIGN (gnu_type, 0);
/* If a type needs strict alignment, the minimum size will be the
type size instead of the RM size (see validate_size). Cap the
@@ -3115,7 +3141,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
if (definition)
gcc_assert (present_gnu_tree (gnat_uview));
else
- gnat_to_gnu_entity (gnat_uview, NULL_TREE, 0);
+ gnat_to_gnu_entity (gnat_uview, NULL_TREE, false);
gnu_parent = gnat_to_gnu_type (Parent_Subtype (gnat_uview));
@@ -3141,7 +3167,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
be created with a component clause below, then we need
to apply the same adjustment as in gnat_to_gnu_field. */
if (has_rep && TYPE_ALIGN (gnu_type) < TYPE_ALIGN (gnu_parent))
- TYPE_ALIGN (gnu_type) = TYPE_ALIGN (gnu_parent);
+ SET_TYPE_ALIGN (gnu_type, TYPE_ALIGN (gnu_parent));
/* Finally we fix up both kinds of twisted COMPONENT_REF we have
initially built. The discriminants must reference the fields
@@ -3278,7 +3304,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
gnu_discr_type = gnat_to_gnu_type (Etype (gnat_discr));
gnu_ref
= gnat_to_gnu_entity (Original_Record_Component (gnat_discr),
- NULL_TREE, 0);
+ NULL_TREE, false);
/* GNU_REF must be an expression using a PLACEHOLDER_EXPR built
just above for one of the stored discriminants. */
@@ -3322,7 +3348,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
|| Ekind (gnat_temp) == E_Discriminant)
&& Is_Itype (Etype (gnat_temp))
&& !present_gnu_tree (gnat_temp))
- gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
+ gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, false);
/* If this is a record type associated with an exception definition,
equate its fields to those of the standard exception type. This
@@ -3347,7 +3373,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
since it may have constraints. */
if (gnat_equiv_type != gnat_entity)
{
- gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
+ gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, false);
maybe_present = true;
break;
}
@@ -3362,7 +3388,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
if (Present (Cloned_Subtype (gnat_entity)))
{
gnu_decl = gnat_to_gnu_entity (Cloned_Subtype (gnat_entity),
- NULL_TREE, 0);
+ NULL_TREE, false);
maybe_present = true;
break;
}
@@ -3701,10 +3727,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
if ((Ekind (gnat_field) == E_Discriminant
|| Ekind (gnat_field) == E_Component)
&& !present_gnu_tree (Etype (gnat_field)))
- gnat_to_gnu_entity (Etype (gnat_field), NULL_TREE, 0);
+ gnat_to_gnu_entity (Etype (gnat_field), NULL_TREE, false);
- /* Do not emit debug info for the type yet since we're going to
- modify it below. */
+ /* We will output additional debug info manually below. */
finish_record_type (gnu_type, nreverse (gnu_field_list), 2,
false);
compute_record_mode (gnu_type);
@@ -3750,9 +3775,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
gnu_variant_list.release ();
gnu_subst_list.release ();
-
- /* Now we can finalize it. */
- rest_of_record_type_compilation (gnu_type);
}
/* Otherwise, go down all the components in the new type and make
@@ -3776,6 +3798,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
break;
case E_Access_Subprogram_Type:
+ case E_Anonymous_Access_Subprogram_Type:
/* Use the special descriptor type for dispatch tables if needed,
that is to say for the Prim_Ptr of a-tags.ads and its clones.
Note that we are only required to do so for static tables in
@@ -3792,34 +3815,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
/* ... fall through ... */
- case E_Anonymous_Access_Subprogram_Type:
- /* If we are not defining this entity, and we have incomplete
- entities being processed above us, make a dummy type and
- fill it in later. */
- if (!definition && defer_incomplete_level != 0)
- {
- struct incomplete *p = XNEW (struct incomplete);
-
- gnu_type
- = build_pointer_type
- (make_dummy_type (Directly_Designated_Type (gnat_entity)));
- gnu_decl = create_type_decl (gnu_entity_name, gnu_type,
- artificial_p, debug_info_p,
- gnat_entity);
- this_made_decl = true;
- gnu_type = TREE_TYPE (gnu_decl);
- save_gnu_tree (gnat_entity, gnu_decl, false);
- saved = true;
-
- p->old_type = TREE_TYPE (gnu_type);
- p->full_type = Directly_Designated_Type (gnat_entity);
- p->next = defer_incomplete_list;
- defer_incomplete_list = p;
- break;
- }
-
- /* ... fall through ... */
-
case E_Allocator_Type:
case E_Access_Type:
case E_Access_Attribute_Type:
@@ -3830,7 +3825,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
Entity_Id gnat_desig_type = Directly_Designated_Type (gnat_entity);
Entity_Id gnat_desig_equiv = Gigi_Equivalent_Type (gnat_desig_type);
/* Whether it comes from a limited with. */
- bool is_from_limited_with
+ const bool is_from_limited_with
= (IN (Ekind (gnat_desig_equiv), Incomplete_Kind)
&& From_Limited_With (gnat_desig_equiv));
/* The "full view" of the designated type. If this is an incomplete
@@ -3858,7 +3853,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
Entity_Id gnat_desig_rep;
/* We want to know if we'll be seeing the freeze node for any
incomplete type we may be pointing to. */
- bool in_main_unit
+ const bool in_main_unit
= (Present (gnat_desig_full)
? In_Extended_Main_Code_Unit (gnat_desig_full)
: In_Extended_Main_Code_Unit (gnat_desig_type));
@@ -3906,14 +3901,16 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
&& Present (gnat_desig_full)
&& (Is_Record_Type (gnat_desig_full)
|| Is_Array_Type (gnat_desig_full)))
- /* Likewise if we are pointing to a record or array and we are
- to defer elaborating incomplete types. We do this as this
- access type may be the full view of a private type. */
+ /* Likewise if this is a reference to a record, an array or a
+ subprogram type and we are to defer elaborating incomplete
+ types. We do this because this access type may be the full
+ view of a private type. */
|| ((!in_main_unit || imported_p)
&& defer_incomplete_level != 0
&& !present_gnu_tree (gnat_desig_equiv)
&& (Is_Record_Type (gnat_desig_rep)
- || Is_Array_Type (gnat_desig_rep)))
+ || Is_Array_Type (gnat_desig_rep)
+ || Ekind (gnat_desig_rep) == E_Subprogram_Type))
/* If this is a reference from a limited_with type back to our
main unit and there's a freeze node for it, either we have
already processed the declaration and made the dummy type,
@@ -3940,10 +3937,19 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
}
/* If expansion is disabled, the equivalent type of a concurrent type
- is absent, so build a dummy pointer type. */
+ is absent, so we use the void pointer type. */
else if (type_annotate_only && No (gnat_desig_equiv))
gnu_type = ptr_type_node;
+ /* If the ultimately designated type is an incomplete type with no full
+ view, we use the void pointer type in LTO mode to avoid emitting a
+ dummy type in the GIMPLE IR. We cannot do that in regular mode as
+ the name of the dummy type in used by GDB for a global lookup. */
+ else if (Ekind (gnat_desig_rep) == E_Incomplete_Type
+ && No (Full_View (gnat_desig_rep))
+ && flag_generate_lto)
+ gnu_type = ptr_type_node;
+
/* Finally, handle the default case where we can just elaborate our
designated type. */
else
@@ -3957,7 +3963,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
break;
}
- /* For an unconstrained array, make dummy fat & thin pointer types. */
+ /* Access-to-unconstrained-array types need a special treatment. */
if (Is_Array_Type (gnat_desig_rep) && !Is_Constrained (gnat_desig_rep))
{
/* If the processing above got something that has a pointer, then
@@ -3965,6 +3971,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
was elaborated or because somebody else executed the code. */
if (!TYPE_POINTER_TO (gnu_desig_type))
build_dummy_unc_pointer_types (gnat_desig_equiv, gnu_desig_type);
+
gnu_type = TYPE_POINTER_TO (gnu_desig_type);
}
@@ -3972,62 +3979,28 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
else if (!gnu_type)
{
/* Modify the designated type if we are pointing only to constant
- objects, but don't do it for unconstrained arrays. */
+ objects, but don't do it for a dummy type. */
if (Is_Access_Constant (gnat_entity)
- && TREE_CODE (gnu_desig_type) != UNCONSTRAINED_ARRAY_TYPE)
- {
- gnu_desig_type
- = change_qualified_type (gnu_desig_type, TYPE_QUAL_CONST);
-
- /* Some extra processing is required if we are building a
- pointer to an incomplete type (in the GCC sense). We might
- have such a type if we just made a dummy, or directly out
- of the call to gnat_to_gnu_type above if we are processing
- an access type for a record component designating the
- record type itself. */
- if (TYPE_MODE (gnu_desig_type) == VOIDmode)
- {
- /* We must ensure that the pointer to variant we make will
- be processed by update_pointer_to when the initial type
- is completed. Pretend we made a dummy and let further
- processing act as usual. */
- made_dummy = true;
-
- /* We must ensure that update_pointer_to will not retrieve
- the dummy variant when building a properly qualified
- version of the complete type. We take advantage of the
- fact that get_qualified_type is requiring TYPE_NAMEs to
- match to influence build_qualified_type and then also
- update_pointer_to here. */
- TYPE_NAME (gnu_desig_type)
- = create_concat_name (gnat_desig_type, "INCOMPLETE_CST");
- }
- }
+ && !TYPE_IS_DUMMY_P (gnu_desig_type))
+ gnu_desig_type
+ = change_qualified_type (gnu_desig_type, TYPE_QUAL_CONST);
gnu_type
= build_pointer_type_for_mode (gnu_desig_type, p_mode,
No_Strict_Aliasing (gnat_entity));
}
- /* If we are not defining this object and we have made a dummy pointer,
- save our current definition, evaluate the actual type, and replace
- the tentative type we made with the actual one. If we are to defer
- actually looking up the actual type, make an entry in the deferred
- list. If this is from a limited with, we may have to defer to the
- end of the current unit. */
- if ((!in_main_unit || is_from_limited_with) && made_dummy)
+ /* If the designated type is not declared in the main unit and we made
+ a dummy node for it, save our definition, elaborate the actual type
+ and replace the dummy type we made with the actual one. But if we
+ are to defer actually looking up the actual type, make an entry in
+ the deferred list instead. If this is from a limited with, we may
+ have to defer until the end of the current unit. */
+ if (!in_main_unit && made_dummy)
{
- tree gnu_old_desig_type;
-
- if (TYPE_IS_FAT_POINTER_P (gnu_type))
- {
- gnu_old_desig_type = TYPE_UNCONSTRAINED_ARRAY (gnu_type);
- if (esize == POINTER_SIZE)
- gnu_type = build_pointer_type
- (TYPE_OBJECT_RECORD_TYPE (gnu_old_desig_type));
- }
- else
- gnu_old_desig_type = TREE_TYPE (gnu_type);
+ if (TYPE_IS_FAT_POINTER_P (gnu_type) && esize == POINTER_SIZE)
+ gnu_type
+ = build_pointer_type (TYPE_OBJECT_RECORD_TYPE (gnu_desig_type));
process_attributes (&gnu_type, &attr_list, false, gnat_entity);
gnu_decl = create_type_decl (gnu_entity_name, gnu_type,
@@ -4038,20 +4011,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
save_gnu_tree (gnat_entity, gnu_decl, false);
saved = true;
- /* Note that the call to gnat_to_gnu_type on gnat_desig_equiv might
- update gnu_old_desig_type directly, in which case it will not be
- a dummy type any more when we get into update_pointer_to.
-
- This can happen e.g. when the designated type is a record type,
- because their elaboration starts with an initial node from
- make_dummy_type, which may be the same node as the one we got.
-
- Besides, variants of this non-dummy type might have been created
- along the way. update_pointer_to is expected to properly take
- care of those situations. */
if (defer_incomplete_level == 0 && !is_from_limited_with)
{
- update_pointer_to (TYPE_MAIN_VARIANT (gnu_old_desig_type),
+ update_pointer_to (TYPE_MAIN_VARIANT (gnu_desig_type),
gnat_to_gnu_type (gnat_desig_equiv));
}
else
@@ -4059,8 +4021,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
struct incomplete *p = XNEW (struct incomplete);
struct incomplete **head
= (is_from_limited_with
- ? &defer_limited_with : &defer_incomplete_list);
- p->old_type = gnu_old_desig_type;
+ ? &defer_limited_with_list : &defer_incomplete_list);
+
+ p->old_type = gnu_desig_type;
p->full_type = gnat_desig_equiv;
p->next = *head;
*head = p;
@@ -4071,48 +4034,49 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
case E_Access_Protected_Subprogram_Type:
case E_Anonymous_Access_Protected_Subprogram_Type:
- if (type_annotate_only && No (gnat_equiv_type))
+ /* If we are just annotating types and have no equivalent record type,
+ just use the void pointer type. */
+ if (type_annotate_only && gnat_equiv_type == gnat_entity)
gnu_type = ptr_type_node;
+
+ /* The run-time representation is the equivalent type. */
else
{
- /* The run-time representation is the equivalent type. */
gnu_type = gnat_to_gnu_type (gnat_equiv_type);
maybe_present = true;
}
+ /* The designated subtype must be elaborated as well, if it does
+ not have its own freeze node. */
if (Is_Itype (Directly_Designated_Type (gnat_entity))
&& !present_gnu_tree (Directly_Designated_Type (gnat_entity))
&& No (Freeze_Node (Directly_Designated_Type (gnat_entity)))
&& !Is_Record_Type (Scope (Directly_Designated_Type (gnat_entity))))
gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
- NULL_TREE, 0);
+ NULL_TREE, false);
break;
case E_Access_Subtype:
-
/* We treat this as identical to its base type; any constraint is
- meaningful only to the front-end.
+ meaningful only to the front-end. */
+ gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
- The designated type must be elaborated as well, if it does
- not have its own freeze node. Designated (sub)types created
+ /* The designated subtype must be elaborated as well, if it does
+ not have its own freeze node. But designated subtypes created
for constrained components of records with discriminants are
- not frozen by the front-end and thus not elaborated by gigi,
- because their use may appear before the base type is frozen,
- and because it is not clear that they are needed anywhere in
- gigi. With the current model, there is no correct place where
- they could be elaborated. */
-
- gnu_type = gnat_to_gnu_type (Etype (gnat_entity));
+ not frozen by the front-end and not elaborated here, because
+ their use may appear before the base type is frozen and it is
+ not clear that they are needed in gigi. With the current model,
+ there is no correct place where they could be elaborated. */
if (Is_Itype (Directly_Designated_Type (gnat_entity))
&& !present_gnu_tree (Directly_Designated_Type (gnat_entity))
&& Is_Frozen (Directly_Designated_Type (gnat_entity))
&& No (Freeze_Node (Directly_Designated_Type (gnat_entity))))
{
- /* If we are not defining this entity, and we have incomplete
- entities being processed above us, make a dummy type and
- elaborate it later. */
- if (!definition && defer_incomplete_level != 0)
+ /* If we are to defer elaborating incomplete types, make a dummy
+ type node and elaborate it later. */
+ if (defer_incomplete_level != 0)
{
struct incomplete *p = XNEW (struct incomplete);
@@ -4126,7 +4090,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
(Directly_Designated_Type (gnat_entity))),
Incomplete_Or_Private_Kind))
gnat_to_gnu_entity (Directly_Designated_Type (gnat_entity),
- NULL_TREE, 0);
+ NULL_TREE, false);
}
maybe_present = true;
@@ -4176,31 +4140,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
case E_Function:
case E_Procedure:
{
- /* The type returned by a function or else Standard_Void_Type for a
- procedure. */
- Entity_Id gnat_return_type = Etype (gnat_entity);
- tree gnu_return_type;
- /* The first GCC parameter declaration (a PARM_DECL node). The
- PARM_DECL nodes are chained through the DECL_CHAIN field, so this
- actually is the head of this parameter list. */
- tree gnu_param_list = NULL_TREE;
- /* Non-null for subprograms containing parameters passed by copy-in
- copy-out (Ada In Out or Out parameters not passed by reference),
- in which case it is the list of nodes used to specify the values
- of the In Out/Out parameters that are returned as a record upon
- procedure return. The TREE_PURPOSE of an element of this list is
- a field of the record and the TREE_VALUE is the PARM_DECL
- corresponding to that field. This list will be saved in the
- TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
- tree gnu_cico_list = NULL_TREE;
- /* List of fields in return type of procedure with copy-in copy-out
- parameters. */
- tree gnu_field_list = NULL_TREE;
- /* If an import pragma asks to map this subprogram to a GCC builtin,
- this is the builtin DECL node. */
- tree gnu_builtin_decl = NULL_TREE;
- tree gnu_ext_name = create_concat_name (gnat_entity, NULL);
- Entity_Id gnat_param;
+ tree gnu_ext_name
+ = gnu_ext_name_for_subprog (gnat_entity, gnu_entity_name);
enum inline_status_t inline_status
= Has_Pragma_No_Inline (gnat_entity)
? is_suppressed
@@ -4215,20 +4156,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
|| imported_p
|| (Convention (gnat_entity) == Convention_Intrinsic
&& Has_Pragma_Inline_Always (gnat_entity)));
- /* The semantics of "pure" in Ada essentially matches that of "const"
- in the back-end. In particular, both properties are orthogonal to
- the "nothrow" property if the EH circuitry is explicit in the
- internal representation of the back-end. If we are to completely
- hide the EH circuitry from it, we need to declare that calls to pure
- Ada subprograms that can throw have side effects since they can
- trigger an "abnormal" transfer of control flow; thus they can be
- neither "const" nor "pure" in the back-end sense. */
- bool const_flag = (Back_End_Exceptions () && Is_Pure (gnat_entity));
- bool volatile_flag = No_Return (gnat_entity);
- bool return_by_direct_ref_p = false;
- bool return_by_invisi_ref_p = false;
- bool return_unconstrained_p = false;
- int parmnum;
+ tree gnu_param_list;
/* A parameter may refer to this type, so defer completion of any
incomplete types. */
@@ -4247,16 +4175,18 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
const Entity_Id gnat_renamed = Renamed_Object (gnat_entity);
if (Ekind (Alias (gnat_entity)) == E_Enumeration_Literal)
- gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE, 0);
+ gnat_to_gnu_entity (Etype (Alias (gnat_entity)), NULL_TREE,
+ false);
- gnu_decl = gnat_to_gnu_entity (Alias (gnat_entity), gnu_expr, 0);
+ gnu_decl
+ = gnat_to_gnu_entity (Alias (gnat_entity), gnu_expr, false);
/* Elaborate any Itypes in the parameters of this entity. */
for (gnat_temp = First_Formal_With_Extras (gnat_entity);
Present (gnat_temp);
gnat_temp = Next_Formal_With_Extras (gnat_temp))
if (Is_Itype (Etype (gnat_temp)))
- gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
+ gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, false);
/* Materialize renamed subprograms in the debugging information
when the renamed object is compile time known. We can consider
@@ -4288,346 +4218,16 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
break;
}
- /* If this subprogram is expectedly bound to a GCC builtin, fetch the
- corresponding DECL node. Proper generation of calls later on need
- proper parameter associations so we don't "break;" here. */
- if (Convention (gnat_entity) == Convention_Intrinsic
- && Present (Interface_Name (gnat_entity)))
- {
- gnu_builtin_decl = builtin_decl_for (gnu_ext_name);
-
- /* Inability to find the builtin decl most often indicates a
- genuine mistake, but imports of unregistered intrinsics are
- sometimes issued on purpose to allow hooking in alternate
- bodies. We post a warning conditioned on Wshadow in this case,
- to let developers be notified on demand without risking false
- positives with common default sets of options. */
-
- if (!gnu_builtin_decl && warn_shadow)
- post_error ("?gcc intrinsic not found for&!", gnat_entity);
- }
-
- /* ??? What if we don't find the builtin node above ? warn ? err ?
- In the current state we neither warn nor err, and calls will just
- be handled as for regular subprograms. */
-
- /* Look into the return type and get its associated GCC tree. If it
- is not void, compute various flags for the subprogram type. */
- if (Ekind (gnat_return_type) == E_Void)
- gnu_return_type = void_type_node;
- else
- {
- /* Ada 2012 (AI05-0151): Incomplete types coming from a limited
- context may now appear in parameter and result profiles. If
- we are only annotating types, break circularities here. */
- if (type_annotate_only
- && is_from_limited_with_of_main (gnat_return_type))
- gnu_return_type = void_type_node;
- else
- gnu_return_type = gnat_to_gnu_type (gnat_return_type);
-
- /* If this function returns by reference, make the actual return
- type the pointer type and make a note of that. */
- if (Returns_By_Ref (gnat_entity))
- {
- gnu_return_type = build_reference_type (gnu_return_type);
- return_by_direct_ref_p = true;
- }
-
- /* If the return type is an unconstrained array type, the return
- value will be allocated on the secondary stack so the actual
- return type is the fat pointer type. */
- else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
- {
- gnu_return_type = TREE_TYPE (gnu_return_type);
- return_unconstrained_p = true;
- }
-
- /* Likewise, if the return type requires a transient scope, the
- return value will also be allocated on the secondary stack so
- the actual return type is the pointer type. */
- else if (Requires_Transient_Scope (gnat_return_type))
- {
- gnu_return_type = build_reference_type (gnu_return_type);
- return_unconstrained_p = true;
- }
-
- /* If the Mechanism is By_Reference, ensure this function uses the
- target's by-invisible-reference mechanism, which may not be the
- same as above (e.g. it might be passing an extra parameter). */
- else if (kind == E_Function
- && Mechanism (gnat_entity) == By_Reference)
- return_by_invisi_ref_p = true;
-
- /* Likewise, if the return type is itself By_Reference. */
- else if (TYPE_IS_BY_REFERENCE_P (gnu_return_type))
- return_by_invisi_ref_p = true;
-
- /* If the type is a padded type and the underlying type would not
- be passed by reference or the function has a foreign convention,
- return the underlying type. */
- else if (TYPE_IS_PADDING_P (gnu_return_type)
- && (!default_pass_by_ref
- (TREE_TYPE (TYPE_FIELDS (gnu_return_type)))
- || Has_Foreign_Convention (gnat_entity)))
- gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type));
-
- /* If the return type is unconstrained, that means it must have a
- maximum size. Use the padded type as the effective return type.
- And ensure the function uses the target's by-invisible-reference
- mechanism to avoid copying too much data when it returns. */
- if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type)))
- {
- tree orig_type = gnu_return_type;
- tree max_return_size
- = max_size (TYPE_SIZE (gnu_return_type), true);
-
- /* If the size overflows to 0, set it to an arbitrary positive
- value so that assignments in the type are preserved. Their
- actual size is independent of this positive value. */
- if (TREE_CODE (max_return_size) == INTEGER_CST
- && TREE_OVERFLOW (max_return_size)
- && integer_zerop (max_return_size))
- {
- max_return_size = copy_node (bitsize_unit_node);
- TREE_OVERFLOW (max_return_size) = 1;
- }
-
- gnu_return_type
- = maybe_pad_type (gnu_return_type, max_return_size, 0,
- gnat_entity, false, false, definition,
- true);
-
- /* Declare it now since it will never be declared otherwise.
- This is necessary to ensure that its subtrees are properly
- marked. */
- if (gnu_return_type != orig_type
- && !DECL_P (TYPE_NAME (gnu_return_type)))
- create_type_decl (TYPE_NAME (gnu_return_type),
- gnu_return_type, true, debug_info_p,
- gnat_entity);
-
- return_by_invisi_ref_p = true;
- }
-
- /* If the return type has a size that overflows, we cannot have
- a function that returns that type. This usage doesn't make
- sense anyway, so give an error here. */
- if (!return_by_invisi_ref_p
- && TYPE_SIZE_UNIT (gnu_return_type)
- && TREE_CODE (TYPE_SIZE_UNIT (gnu_return_type)) == INTEGER_CST
- && !valid_constant_size_p (TYPE_SIZE_UNIT (gnu_return_type)))
- {
- post_error ("cannot return type whose size overflows",
- gnat_entity);
- gnu_return_type = copy_node (gnu_return_type);
- TYPE_SIZE (gnu_return_type) = bitsize_zero_node;
- TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node;
- TYPE_MAIN_VARIANT (gnu_return_type) = gnu_return_type;
- TYPE_NEXT_VARIANT (gnu_return_type) = NULL_TREE;
- }
- }
-
- /* Loop over the parameters and get their associated GCC tree. While
- doing this, build a copy-in copy-out structure if we need one. */
- for (gnat_param = First_Formal_With_Extras (gnat_entity), parmnum = 0;
- Present (gnat_param);
- gnat_param = Next_Formal_With_Extras (gnat_param), parmnum++)
- {
- Entity_Id gnat_param_type = Etype (gnat_param);
- tree gnu_param_name = get_entity_name (gnat_param);
- tree gnu_param_type, gnu_param, gnu_field;
- Mechanism_Type mech = Mechanism (gnat_param);
- bool copy_in_copy_out = false, fake_param_type;
-
- /* Ada 2012 (AI05-0151): Incomplete types coming from a limited
- context may now appear in parameter and result profiles. If
- we are only annotating types, break circularities here. */
- if (type_annotate_only
- && is_from_limited_with_of_main (gnat_param_type))
- {
- gnu_param_type = void_type_node;
- fake_param_type = true;
- }
- else
- {
- gnu_param_type = gnat_to_gnu_type (gnat_param_type);
- fake_param_type = false;
- }
-
- /* Builtins are expanded inline and there is no real call sequence
- involved. So the type expected by the underlying expander is
- always the type of each argument "as is". */
- if (gnu_builtin_decl)
- mech = By_Copy;
- /* Handle the first parameter of a valued procedure specially. */
- else if (Is_Valued_Procedure (gnat_entity) && parmnum == 0)
- mech = By_Copy_Return;
- /* Otherwise, see if a Mechanism was supplied that forced this
- parameter to be passed one way or another. */
- else if (mech == Default
- || mech == By_Copy
- || mech == By_Reference)
- ;
- else if (mech > 0)
- {
- if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE
- || TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST
- || 0 < compare_tree_int (TYPE_SIZE (gnu_param_type),
- mech))
- mech = By_Reference;
- else
- mech = By_Copy;
- }
- else
- {
- post_error ("unsupported mechanism for&", gnat_param);
- mech = Default;
- }
-
- /* Do not call gnat_to_gnu_param for a fake parameter type since
- it will try to use the real type again. */
- if (fake_param_type)
- {
- if (Ekind (gnat_param) == E_Out_Parameter)
- gnu_param = NULL_TREE;
- else
- {
- gnu_param
- = create_param_decl (gnu_param_name, gnu_param_type,
- false);
- Set_Mechanism (gnat_param,
- mech == Default ? By_Copy : mech);
- if (Ekind (gnat_param) == E_In_Out_Parameter)
- copy_in_copy_out = true;
- }
- }
- else
- gnu_param
- = gnat_to_gnu_param (gnat_param, mech, gnat_entity,
- Has_Foreign_Convention (gnat_entity),
- &copy_in_copy_out);
-
- /* We are returned either a PARM_DECL or a type if no parameter
- needs to be passed; in either case, adjust the type. */
- if (DECL_P (gnu_param))
- gnu_param_type = TREE_TYPE (gnu_param);
- else
- {
- gnu_param_type = gnu_param;
- gnu_param = NULL_TREE;
- }
-
- /* The failure of this assertion will very likely come from an
- order of elaboration issue for the type of the parameter. */
- gcc_assert (kind == E_Subprogram_Type
- || !TYPE_IS_DUMMY_P (gnu_param_type)
- || type_annotate_only);
-
- if (gnu_param)
- {
- gnu_param_list = chainon (gnu_param, gnu_param_list);
- Sloc_to_locus (Sloc (gnat_param),
- &DECL_SOURCE_LOCATION (gnu_param));
- save_gnu_tree (gnat_param, gnu_param, false);
-
- /* If a parameter is a pointer, this function may modify
- memory through it and thus shouldn't be considered
- a const function. Also, the memory may be modified
- between two calls, so they can't be CSE'ed. The latter
- case also handles by-ref parameters. */
- if (POINTER_TYPE_P (gnu_param_type)
- || TYPE_IS_FAT_POINTER_P (gnu_param_type))
- const_flag = false;
- }
-
- if (copy_in_copy_out)
- {
- if (!gnu_cico_list)
- {
- tree gnu_new_ret_type = make_node (RECORD_TYPE);
-
- /* If this is a function, we also need a field for the
- return value to be placed. */
- if (TREE_CODE (gnu_return_type) != VOID_TYPE)
- {
- gnu_field
- = create_field_decl (get_identifier ("RETVAL"),
- gnu_return_type,
- gnu_new_ret_type, NULL_TREE,
- NULL_TREE, 0, 0);
- Sloc_to_locus (Sloc (gnat_entity),
- &DECL_SOURCE_LOCATION (gnu_field));
- gnu_field_list = gnu_field;
- gnu_cico_list
- = tree_cons (gnu_field, void_type_node, NULL_TREE);
- }
-
- gnu_return_type = gnu_new_ret_type;
- TYPE_NAME (gnu_return_type) = get_identifier ("RETURN");
- /* Set a default alignment to speed up accesses. But we
- shouldn't increase the size of the structure too much,
- lest it doesn't fit in return registers anymore. */
- TYPE_ALIGN (gnu_return_type)
- = get_mode_alignment (ptr_mode);
- }
-
- gnu_field
- = create_field_decl (gnu_param_name, gnu_param_type,
- gnu_return_type, NULL_TREE, NULL_TREE,
- 0, 0);
- Sloc_to_locus (Sloc (gnat_param),
- &DECL_SOURCE_LOCATION (gnu_field));
- DECL_CHAIN (gnu_field) = gnu_field_list;
- gnu_field_list = gnu_field;
- gnu_cico_list
- = tree_cons (gnu_field, gnu_param, gnu_cico_list);
- }
- }
-
- if (gnu_cico_list)
+ /* Get the GCC tree for the (underlying) subprogram type. If the
+ entity is an actual subprogram, also get the parameter list. */
+ gnu_type
+ = gnat_to_gnu_subprog_type (gnat_entity, definition, debug_info_p,
+ &gnu_param_list);
+ if (DECL_P (gnu_type))
{
- /* If we have a CICO list but it has only one entry, we convert
- this function into a function that returns this object. */
- if (list_length (gnu_cico_list) == 1)
- gnu_return_type = TREE_TYPE (TREE_PURPOSE (gnu_cico_list));
-
- /* Do not finalize the return type if the subprogram is stubbed
- since structures are incomplete for the back-end. */
- else if (Convention (gnat_entity) != Convention_Stubbed)
- {
- finish_record_type (gnu_return_type, nreverse (gnu_field_list),
- 0, false);
-
- /* Try to promote the mode of the return type if it is passed
- in registers, again to speed up accesses. */
- if (TYPE_MODE (gnu_return_type) == BLKmode
- && !targetm.calls.return_in_memory (gnu_return_type,
- NULL_TREE))
- {
- unsigned int size
- = TREE_INT_CST_LOW (TYPE_SIZE (gnu_return_type));
- unsigned int i = BITS_PER_UNIT;
- machine_mode mode;
-
- while (i < size)
- i <<= 1;
- mode = mode_for_size (i, MODE_INT, 0);
- if (mode != BLKmode)
- {
- SET_TYPE_MODE (gnu_return_type, mode);
- TYPE_ALIGN (gnu_return_type)
- = GET_MODE_ALIGNMENT (mode);
- TYPE_SIZE (gnu_return_type)
- = bitsize_int (GET_MODE_BITSIZE (mode));
- TYPE_SIZE_UNIT (gnu_return_type)
- = size_int (GET_MODE_SIZE (mode));
- }
- }
-
- if (debug_info_p)
- rest_of_record_type_compilation (gnu_return_type);
- }
+ gnu_decl = gnu_type;
+ gnu_type = TREE_TYPE (gnu_decl);
+ break;
}
/* Deal with platform-specific calling conventions. */
@@ -4658,59 +4258,6 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
prepend_one_attribute_pragma (&attr_list,
Linker_Section_Pragma (gnat_entity));
- /* The lists have been built in reverse. */
- gnu_param_list = nreverse (gnu_param_list);
- gnu_cico_list = nreverse (gnu_cico_list);
-
- if (kind == E_Function)
- Set_Mechanism (gnat_entity, return_unconstrained_p
- || return_by_direct_ref_p
- || return_by_invisi_ref_p
- ? By_Reference : By_Copy);
- gnu_type
- = create_subprog_type (gnu_return_type, gnu_param_list,
- gnu_cico_list, return_unconstrained_p,
- return_by_direct_ref_p,
- return_by_invisi_ref_p);
-
- /* A procedure (something that doesn't return anything) shouldn't be
- considered const since there would be no reason for calling such a
- subprogram. Note that procedures with Out (or In Out) parameters
- have already been converted into a function with a return type.
- Similarly, if the function returns an unconstrained type, then the
- function will allocate the return value on the secondary stack and
- thus calls to it cannot be CSE'ed, lest the stack be reclaimed. */
- if (TREE_CODE (gnu_return_type) == VOID_TYPE || return_unconstrained_p)
- const_flag = false;
-
- /* If we have a builtin decl for that function, use it. Check if the
- profiles are compatible and warn if they are not. The checker is
- expected to post extra diagnostics in this case. */
- if (gnu_builtin_decl)
- {
- intrin_binding_t inb;
-
- inb.gnat_entity = gnat_entity;
- inb.ada_fntype = gnu_type;
- inb.btin_fntype = TREE_TYPE (gnu_builtin_decl);
-
- if (!intrin_profiles_compatible_p (&inb))
- post_error
- ("?profile of& doesn''t match the builtin it binds!",
- gnat_entity);
-
- gnu_decl = gnu_builtin_decl;
- gnu_type = TREE_TYPE (gnu_builtin_decl);
- break;
- }
-
- /* If there was no specified Interface_Name and the external and
- internal names of the subprogram are the same, only use the
- internal name to allow disambiguation of nested subprograms. */
- if (No (Interface_Name (gnat_entity))
- && gnu_ext_name == gnu_entity_name)
- gnu_ext_name = NULL_TREE;
-
/* If we are defining the subprogram and it has an Address clause
we must get the address expression from the saved GCC tree for the
subprogram if it has a Freeze_Node. Otherwise, we elaborate
@@ -4745,33 +4292,38 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
DECL_BY_REF_P (gnu_decl) = 1;
}
+ /* If this is a mere subprogram type, just create the declaration. */
else if (kind == E_Subprogram_Type)
{
process_attributes (&gnu_type, &attr_list, false, gnat_entity);
- if (const_flag || volatile_flag)
- {
- const int quals
- = (const_flag ? TYPE_QUAL_CONST : 0)
- | (volatile_flag ? TYPE_QUAL_VOLATILE : 0);
- gnu_type = change_qualified_type (gnu_type, quals);
- }
-
gnu_decl
= create_type_decl (gnu_entity_name, gnu_type, artificial_p,
debug_info_p, gnat_entity);
}
+
+ /* Otherwise create the subprogram declaration with the external name,
+ the type and the parameter list. However, if this a reference to
+ the allocation routines, reuse the canonical declaration nodes as
+ they come with special properties. */
else
{
- gnu_decl
- = create_subprog_decl (gnu_entity_name, gnu_ext_name, gnu_type,
- gnu_param_list, inline_status, const_flag,
- public_flag, extern_flag, volatile_flag,
- artificial_p, debug_info_p,
- attr_list, gnat_entity);
- /* This is unrelated to the stub built right above. */
- DECL_STUBBED_P (gnu_decl)
- = Convention (gnat_entity) == Convention_Stubbed;
+ if (extern_flag && gnu_ext_name == DECL_NAME (malloc_decl))
+ gnu_decl = malloc_decl;
+ else if (extern_flag && gnu_ext_name == DECL_NAME (realloc_decl))
+ gnu_decl = realloc_decl;
+ else
+ {
+ gnu_decl
+ = create_subprog_decl (gnu_entity_name, gnu_ext_name,
+ gnu_type, gnu_param_list,
+ inline_status, public_flag,
+ extern_flag, artificial_p,
+ debug_info_p, attr_list, gnat_entity);
+
+ DECL_STUBBED_P (gnu_decl)
+ = (Convention (gnat_entity) == Convention_Stubbed);
+ }
}
}
break;
@@ -4785,14 +4337,14 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
case E_Record_Type_With_Private:
case E_Record_Subtype_With_Private:
{
- bool is_from_limited_with
+ const bool is_from_limited_with
= (IN (kind, Incomplete_Kind) && From_Limited_With (gnat_entity));
/* Get the "full view" of this entity. If this is an incomplete
entity from a limited with, treat its non-limited view as the
full view. Otherwise, use either the full view or the underlying
full view, whichever is present. This is used in all the tests
below. */
- Entity_Id full_view
+ const Entity_Id full_view
= is_from_limited_with
? Non_Limited_View (gnat_entity)
: Present (Full_View (gnat_entity))
@@ -4802,8 +4354,9 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
: Empty;
/* If this is an incomplete type with no full view, it must be a Taft
- Amendment type, in which case we return a dummy type. Otherwise,
- just get the type from its Etype. */
+ Amendment type or an incomplete type coming from a limited context,
+ in which cases we return a dummy type. Otherwise, we just get the
+ type from its Etype. */
if (No (full_view))
{
if (kind == E_Incomplete_Type)
@@ -4813,51 +4366,47 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
}
else
{
- gnu_decl = gnat_to_gnu_entity (Etype (gnat_entity),
- NULL_TREE, 0);
+ gnu_decl
+ = gnat_to_gnu_entity (Etype (gnat_entity), NULL_TREE, false);
maybe_present = true;
}
- break;
}
- /* If we already made a type for the full view, reuse it. */
+ /* Or else, if we already made a type for the full view, reuse it. */
else if (present_gnu_tree (full_view))
- {
- gnu_decl = get_gnu_tree (full_view);
- break;
- }
+ gnu_decl = get_gnu_tree (full_view);
- /* Otherwise, if we are not defining the type now, get the type
- from the full view. But always get the type from the full view
- for define on use types, since otherwise we won't see them.
- Likewise if this is a non-limited view not declared in the main
- unit, which can happen for incomplete formal types instantiated
- on a type coming from a limited_with clause. */
+ /* Or else, if we are not defining the type or there is no freeze
+ node on it, get the type for the full view. Likewise if this is
+ a limited_with'ed type not declared in the main unit, which can
+ happen for incomplete formal types instantiated on a type coming
+ from a limited_with clause. */
else if (!definition
- || (Is_Itype (full_view) && No (Freeze_Node (gnat_entity)))
- || (Is_Itype (gnat_entity) && No (Freeze_Node (full_view)))
+ || No (Freeze_Node (full_view))
|| (is_from_limited_with
&& !In_Extended_Main_Code_Unit (full_view)))
{
- gnu_decl = gnat_to_gnu_entity (full_view, NULL_TREE, 0);
+ gnu_decl = gnat_to_gnu_entity (full_view, NULL_TREE, false);
maybe_present = true;
- break;
}
- /* For incomplete types, make a dummy type entry which will be
- replaced later. Save it as the full declaration's type so
- we can do any needed updates when we see it. */
- gnu_type = make_dummy_type (gnat_entity);
- gnu_decl = TYPE_STUB_DECL (gnu_type);
- if (Has_Completion_In_Body (gnat_entity))
- DECL_TAFT_TYPE_P (gnu_decl) = 1;
- save_gnu_tree (full_view, gnu_decl, 0);
- break;
+ /* Otherwise, make a dummy type entry which will be replaced later.
+ Save it as the full declaration's type so we can do any needed
+ updates when we see it. */
+ else
+ {
+ gnu_type = make_dummy_type (gnat_entity);
+ gnu_decl = TYPE_STUB_DECL (gnu_type);
+ if (Has_Completion_In_Body (gnat_entity))
+ DECL_TAFT_TYPE_P (gnu_decl) = 1;
+ save_gnu_tree (full_view, gnu_decl, false);
+ }
}
+ break;
case E_Class_Wide_Type:
/* Class-wide types are always transformed into their root type. */
- gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
+ gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, false);
maybe_present = true;
break;
@@ -4869,7 +4418,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
just return void_type, except for root types that have discriminants
because the discriminants will very likely be used in the declarative
part of the associated body so they need to be translated. */
- if (type_annotate_only && No (gnat_equiv_type))
+ if (type_annotate_only && gnat_equiv_type == gnat_entity)
{
if (Has_Discriminants (gnat_entity)
&& Root_Type (gnat_entity) == gnat_entity)
@@ -4908,7 +4457,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
/* Concurrent types are always transformed into their record type. */
else
- gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, 0);
+ gnu_decl = gnat_to_gnu_entity (gnat_equiv_type, NULL_TREE, false);
maybe_present = true;
break;
@@ -4949,6 +4498,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
handling alignment and possible padding. */
if (is_type && (!gnu_decl || this_made_decl))
{
+ gcc_assert (!TYPE_IS_DUMMY_P (gnu_type));
+
/* Process the attributes, if not already done. Note that the type is
already defined so we cannot pass true for IN_PLACE here. */
process_attributes (&gnu_type, &attr_list, false, gnat_entity);
@@ -5055,10 +4606,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
a constant or self-referential, call elaborate_expression_1 to
make a variable for the size rather than calculating it each time.
Handle both the RM size and the actual size. */
- if (global_bindings_p ()
- && TYPE_SIZE (gnu_type)
+ if (TYPE_SIZE (gnu_type)
&& !TREE_CONSTANT (TYPE_SIZE (gnu_type))
- && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type)))
+ && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_type))
+ && global_bindings_p ())
{
tree size = TYPE_SIZE (gnu_type);
@@ -5140,11 +4691,10 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
}
}
- /* If this is a record type or subtype, call elaborate_expression_2 on
- any field position. Do this for both global and local types.
- Skip any fields that we haven't made trees for to avoid problems with
- class wide types. */
- if (IN (kind, Record_Kind))
+ /* Similarly, if this is a record type or subtype at global level, call
+ elaborate_expression_2 on any field position. Skip any fields that
+ we haven't made trees for to avoid problems with class-wide types. */
+ if (IN (kind, Record_Kind) && global_bindings_p ())
for (gnat_temp = First_Entity (gnat_entity); Present (gnat_temp);
gnat_temp = Next_Entity (gnat_temp))
if (Ekind (gnat_temp) == E_Component && present_gnu_tree (gnat_temp))
@@ -5153,7 +4703,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
/* ??? For now, store the offset as a multiple of the alignment
in bytes so that we can see the alignment from the tree. */
- if (!CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field)))
+ if (!TREE_CONSTANT (DECL_FIELD_OFFSET (gnu_field))
+ && !CONTAINS_PLACEHOLDER_P (DECL_FIELD_OFFSET (gnu_field)))
{
DECL_FIELD_OFFSET (gnu_field)
= elaborate_expression_2 (DECL_FIELD_OFFSET (gnu_field),
@@ -5164,8 +4715,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
/* ??? The context of gnu_field is not necessarily gnu_type
so the MULT_EXPR node built above may not be marked by
the call to create_type_decl below. */
- if (global_bindings_p ())
- MARK_VISITED (DECL_FIELD_OFFSET (gnu_field));
+ MARK_VISITED (DECL_FIELD_OFFSET (gnu_field));
}
}
@@ -5178,7 +4728,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
if (Present (Alignment_Clause (gnat_entity)))
TYPE_USER_ALIGN (gnu_type) = 1;
- if (Universal_Aliasing (gnat_entity))
+ if (Universal_Aliasing (gnat_entity) && !TYPE_IS_DUMMY_P (gnu_type))
TYPE_UNIVERSAL_ALIASING_P (gnu_type) = 1;
/* If it is passed by reference, force BLKmode to ensure that
@@ -5187,31 +4737,8 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
&& AGGREGATE_TYPE_P (gnu_type)
&& TYPE_BY_REFERENCE_P (gnu_type))
SET_TYPE_MODE (gnu_type, BLKmode);
-
- if (Treat_As_Volatile (gnat_entity))
- {
- const int quals
- = TYPE_QUAL_VOLATILE
- | (Is_Atomic_Or_VFA (gnat_entity) ? TYPE_QUAL_ATOMIC : 0);
- gnu_type = change_qualified_type (gnu_type, quals);
- }
}
- if (!gnu_decl)
- gnu_decl = create_type_decl (gnu_entity_name, gnu_type,
- artificial_p, debug_info_p,
- gnat_entity);
- else
- {
- TREE_TYPE (gnu_decl) = gnu_type;
- TYPE_STUB_DECL (gnu_type) = gnu_decl;
- }
- }
-
- if (is_type && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)))
- {
- gnu_type = TREE_TYPE (gnu_decl);
-
/* If this is a derived type, relate its alias set to that of its parent
to avoid troubles when a call to an inherited primitive is inlined in
a context where a derived object is accessed. The inlined code works
@@ -5290,8 +4817,31 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
? ALIAS_SET_COPY : ALIAS_SET_SUPERSET);
}
- /* Back-annotate the Alignment of the type if not already in the
- tree. Likewise for sizes. */
+ if (Treat_As_Volatile (gnat_entity))
+ {
+ const int quals
+ = TYPE_QUAL_VOLATILE
+ | (Is_Atomic_Or_VFA (gnat_entity) ? TYPE_QUAL_ATOMIC : 0);
+ gnu_type = change_qualified_type (gnu_type, quals);
+ }
+
+ if (!gnu_decl)
+ gnu_decl = create_type_decl (gnu_entity_name, gnu_type,
+ artificial_p, debug_info_p,
+ gnat_entity);
+ else
+ {
+ TREE_TYPE (gnu_decl) = gnu_type;
+ TYPE_STUB_DECL (gnu_type) = gnu_decl;
+ }
+ }
+
+ /* If we got a type that is not dummy, back-annotate the alignment of the
+ type if not already in the tree. Likewise for the size, if any. */
+ if (is_type && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_decl)))
+ {
+ gnu_type = TREE_TYPE (gnu_decl);
+
if (Unknown_Alignment (gnat_entity))
{
unsigned int double_align, align;
@@ -5377,7 +4927,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
Set_Esize (gnat_entity, annotate_value (gnu_size));
}
- if (Unknown_RM_Size (gnat_entity) && rm_size (gnu_type))
+ if (Unknown_RM_Size (gnat_entity) && TYPE_SIZE (gnu_type))
Set_RM_Size (gnat_entity, annotate_value (rm_size (gnu_type)));
}
@@ -5463,11 +5013,13 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
p->old_type = NULL_TREE;
}
- for (p = defer_limited_with; p; p = p->next)
+ for (p = defer_limited_with_list; p; p = p->next)
if (p->old_type && Non_Limited_View (p->full_type) == gnat_entity)
{
update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
TREE_TYPE (gnu_decl));
+ if (TYPE_DUMMY_IN_PROFILE_P (p->old_type))
+ update_profiles_with (p->old_type);
p->old_type = NULL_TREE;
}
}
@@ -5481,7 +5033,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
&& Is_Itype (Original_Array_Type (gnat_entity))
&& No (Freeze_Node (Original_Array_Type (gnat_entity)))
&& !present_gnu_tree (Original_Array_Type (gnat_entity)))
- gnat_to_gnu_entity (Original_Array_Type (gnat_entity), NULL_TREE, 0);
+ gnat_to_gnu_entity (Original_Array_Type (gnat_entity), NULL_TREE, false);
return gnu_decl;
}
@@ -5492,7 +5044,7 @@ gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr, int definition)
tree
gnat_to_gnu_field_decl (Entity_Id gnat_entity)
{
- tree gnu_field = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
+ tree gnu_field = gnat_to_gnu_entity (gnat_entity, NULL_TREE, false);
if (TREE_CODE (gnu_field) == COMPONENT_REF)
gnu_field = TREE_OPERAND (gnu_field, 1);
@@ -5512,7 +5064,7 @@ gnat_to_gnu_type (Entity_Id gnat_entity)
if (Is_Generic_Type (gnat_entity) && type_annotate_only)
return void_type_node;
- gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
+ gnu_decl = gnat_to_gnu_entity (gnat_entity, NULL_TREE, false);
gcc_assert (TREE_CODE (gnu_decl) == TYPE_DECL);
return TREE_TYPE (gnu_decl);
@@ -5532,47 +5084,6 @@ get_unpadded_type (Entity_Id gnat_entity)
return type;
}
-/* Return the DECL associated with the public subprogram GNAT_ENTITY but whose
- type has been changed to that of the parameterless procedure, except if an
- alias is already present, in which case it is returned instead. */
-
-tree
-get_minimal_subprog_decl (Entity_Id gnat_entity)
-{
- tree gnu_entity_name, gnu_ext_name;
- struct attrib *attr_list = NULL;
-
- /* See the E_Function/E_Procedure case of gnat_to_gnu_entity for the model
- of the handling applied here. */
-
- while (Present (Alias (gnat_entity)))
- {
- gnat_entity = Alias (gnat_entity);
- if (present_gnu_tree (gnat_entity))
- return get_gnu_tree (gnat_entity);
- }
-
- gnu_entity_name = get_entity_name (gnat_entity);
- gnu_ext_name = create_concat_name (gnat_entity, NULL);
-
- if (Has_Stdcall_Convention (gnat_entity))
- prepend_one_attribute (&attr_list, ATTR_MACHINE_ATTRIBUTE,
- get_identifier ("stdcall"), NULL_TREE,
- gnat_entity);
- else if (Has_Thiscall_Convention (gnat_entity))
- prepend_one_attribute (&attr_list, ATTR_MACHINE_ATTRIBUTE,
- get_identifier ("thiscall"), NULL_TREE,
- gnat_entity);
-
- if (No (Interface_Name (gnat_entity)) && gnu_ext_name == gnu_entity_name)
- gnu_ext_name = NULL_TREE;
-
- return
- create_subprog_decl (gnu_entity_name, gnu_ext_name, void_ftype, NULL_TREE,
- is_disabled, false, true, true, false, true, false,
- attr_list, gnat_entity);
-}
-
/* Return whether the E_Subprogram_Type/E_Function/E_Procedure GNAT_ENTITY is
a C++ imported method or equivalent.
@@ -5583,10 +5094,6 @@ get_minimal_subprog_decl (Entity_Id gnat_entity)
bool
is_cplusplus_method (Entity_Id gnat_entity)
{
- /* Check that the subprogram has C++ convention. */
- if (Convention (gnat_entity) != Convention_CPP)
- return false;
-
/* A constructor is a method on the C++ side. We deal with it now because
it is declared without the 'this' parameter in the sources and, although
the front-end will create a version with the 'this' parameter for code
@@ -5594,6 +5101,10 @@ is_cplusplus_method (Entity_Id gnat_entity)
if (Is_Constructor (gnat_entity))
return true;
+ /* Check that the subprogram has C++ convention. */
+ if (Convention (gnat_entity) != Convention_CPP)
+ return false;
+
/* And that the type of the first parameter (indirectly) has it too. */
Entity_Id gnat_first = First_Formal (gnat_entity);
if (No (gnat_first))
@@ -5605,19 +5116,75 @@ is_cplusplus_method (Entity_Id gnat_entity)
if (Convention (gnat_type) != Convention_CPP)
return false;
- /* This is the main case: C++ method imported as a primitive operation.
- Note that a C++ class with no virtual functions can be imported as a
- limited record type so the operation is not necessarily dispatching. */
- if (Is_Primitive (gnat_entity))
+ /* This is the main case: a C++ virtual method imported as a primitive
+ operation of a tagged type. */
+ if (Is_Dispatching_Operation (gnat_entity))
+ return true;
+
+ /* This is set on the E_Subprogram_Type built for a dispatching call. */
+ if (Is_Dispatch_Table_Entity (gnat_entity))
return true;
/* A thunk needs to be handled like its associated primitive operation. */
if (Is_Subprogram (gnat_entity) && Is_Thunk (gnat_entity))
return true;
- /* This is set on the E_Subprogram_Type built for a dispatching call. */
- if (Is_Dispatch_Table_Entity (gnat_entity))
- return true;
+ /* Now on to the annoying case: a C++ non-virtual method, imported either
+ as a non-primitive operation of a tagged type or as a primitive operation
+ of an untagged type. We cannot reliably differentiate these cases from
+ their static member or regular function equivalents in Ada, so we ask
+ the C++ side through the mangled name of the function, as the implicit
+ 'this' parameter is not encoded in the mangled name of a method. */
+ if (Is_Subprogram (gnat_entity) && Present (Interface_Name (gnat_entity)))
+ {
+ String_Pointer sp = { NULL, NULL };
+ Get_External_Name (gnat_entity, false, sp);
+
+ void *mem;
+ struct demangle_component *cmp
+ = cplus_demangle_v3_components (Name_Buffer,
+ DMGL_GNU_V3
+ | DMGL_TYPES
+ | DMGL_PARAMS
+ | DMGL_RET_DROP,
+ &mem);
+ if (!cmp)
+ return false;
+
+ /* We need to release MEM once we have a successful demangling. */
+ bool ret = false;
+
+ if (cmp->type == DEMANGLE_COMPONENT_TYPED_NAME
+ && cmp->u.s_binary.right->type == DEMANGLE_COMPONENT_FUNCTION_TYPE
+ && (cmp = cmp->u.s_binary.right->u.s_binary.right) != NULL
+ && cmp->type == DEMANGLE_COMPONENT_ARGLIST)
+ {
+ /* Make sure there is at least one parameter in C++ too. */
+ if (cmp->u.s_binary.left)
+ {
+ unsigned int n_ada_args = 0;
+ do {
+ n_ada_args++;
+ gnat_first = Next_Formal (gnat_first);
+ } while (Present (gnat_first));
+
+ unsigned int n_cpp_args = 0;
+ do {
+ n_cpp_args++;
+ cmp = cmp->u.s_binary.right;
+ } while (cmp);
+
+ if (n_cpp_args < n_ada_args)
+ ret = true;
+ }
+ else
+ ret = true;
+ }
+
+ free (mem);
+
+ return ret;
+ }
return false;
}
@@ -5629,16 +5196,21 @@ finalize_from_limited_with (void)
{
struct incomplete *p, *next;
- p = defer_limited_with;
- defer_limited_with = NULL;
+ p = defer_limited_with_list;
+ defer_limited_with_list = NULL;
for (; p; p = next)
{
next = p->next;
if (p->old_type)
- update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
- gnat_to_gnu_type (p->full_type));
+ {
+ update_pointer_to (TYPE_MAIN_VARIANT (p->old_type),
+ gnat_to_gnu_type (p->full_type));
+ if (TYPE_DUMMY_IN_PROFILE_P (p->old_type))
+ update_profiles_with (p->old_type);
+ }
+
free (p);
}
}
@@ -5667,26 +5239,26 @@ Gigi_Equivalent_Type (Entity_Id gnat_entity)
case E_Access_Protected_Subprogram_Type:
case E_Anonymous_Access_Protected_Subprogram_Type:
- gnat_equiv = Equivalent_Type (gnat_entity);
+ if (Present (Equivalent_Type (gnat_entity)))
+ gnat_equiv = Equivalent_Type (gnat_entity);
break;
case E_Class_Wide_Type:
gnat_equiv = Root_Type (gnat_entity);
break;
- case E_Task_Type:
- case E_Task_Subtype:
case E_Protected_Type:
case E_Protected_Subtype:
- gnat_equiv = Corresponding_Record_Type (gnat_entity);
+ case E_Task_Type:
+ case E_Task_Subtype:
+ if (Present (Corresponding_Record_Type (gnat_entity)))
+ gnat_equiv = Corresponding_Record_Type (gnat_entity);
break;
default:
break;
}
- gcc_assert (Present (gnat_equiv) || type_annotate_only);
-
return gnat_equiv;
}
@@ -5702,17 +5274,26 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
const Entity_Id gnat_type = Component_Type (gnat_array);
tree gnu_type = gnat_to_gnu_type (gnat_type);
tree gnu_comp_size;
+ unsigned int max_align;
+
+ /* If an alignment is specified, use it as a cap on the component type
+ so that it can be honored for the whole type. But ignore it for the
+ original type of packed array types. */
+ if (No (Packed_Array_Impl_Type (gnat_array))
+ && Known_Alignment (gnat_array))
+ max_align = validate_alignment (Alignment (gnat_array), gnat_array, 0);
+ else
+ max_align = 0;
/* Try to get a smaller form of the component if needed. */
- if ((Is_Packed (gnat_array)
- || Has_Component_Size_Clause (gnat_array))
+ if ((Is_Packed (gnat_array) || Has_Component_Size_Clause (gnat_array))
&& !Is_Bit_Packed_Array (gnat_array)
&& !Has_Aliased_Components (gnat_array)
&& !Strict_Alignment (gnat_type)
&& RECORD_OR_UNION_TYPE_P (gnu_type)
&& !TYPE_FAT_POINTER_P (gnu_type)
&& tree_fits_uhwi_p (TYPE_SIZE (gnu_type)))
- gnu_type = make_packable_type (gnu_type, false);
+ gnu_type = make_packable_type (gnu_type, false, max_align);
if (Has_Atomic_Components (gnat_array))
check_ok_for_atomic_type (gnu_type, gnat_array, true);
@@ -5745,16 +5326,6 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
if (gnu_comp_size && !Is_Bit_Packed_Array (gnat_array))
{
tree orig_type = gnu_type;
- unsigned int max_align;
-
- /* If an alignment is specified, use it as a cap on the component type
- so that it can be honored for the whole type. But ignore it for the
- original type of packed array types. */
- if (No (Packed_Array_Impl_Type (gnat_array))
- && Known_Alignment (gnat_array))
- max_align = validate_alignment (Alignment (gnat_array), gnat_array, 0);
- else
- max_align = 0;
gnu_type = make_type_from_size (gnu_type, gnu_comp_size, false);
if (max_align > 0 && TYPE_ALIGN (gnu_type) > max_align)
@@ -5794,39 +5365,76 @@ gnat_to_gnu_component_type (Entity_Id gnat_array, bool definition,
return gnu_type;
}
-/* Return a GCC tree for a parameter corresponding to GNAT_PARAM and
- using MECH as its passing mechanism, to be placed in the parameter
- list built for GNAT_SUBPROG. Assume a foreign convention for the
- latter if FOREIGN is true. Also set CICO to true if the parameter
- must use the copy-in copy-out implementation mechanism.
+/* Return a GCC tree for a parameter corresponding to GNAT_PARAM, to be placed
+ in the parameter list of GNAT_SUBPROG. GNU_PARAM_TYPE is the GCC tree for
+ the type of the parameter. FIRST is true if this is the first parameter in
+ the list of GNAT_SUBPROG. Also set CICO to true if the parameter must use
+ the copy-in copy-out implementation mechanism.
- The returned tree is a PARM_DECL, except for those cases where no
- parameter needs to be actually passed to the subprogram; the type
- of this "shadow" parameter is then returned instead. */
+ The returned tree is a PARM_DECL, except for the cases where no parameter
+ needs to be actually passed to the subprogram; the type of this "shadow"
+ parameter is then returned instead. */
static tree
-gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
- Entity_Id gnat_subprog, bool foreign, bool *cico)
+gnat_to_gnu_param (Entity_Id gnat_param, tree gnu_param_type, bool first,
+ Entity_Id gnat_subprog, bool *cico)
{
+ Entity_Id gnat_param_type = Etype (gnat_param);
+ Mechanism_Type mech = Mechanism (gnat_param);
tree gnu_param_name = get_entity_name (gnat_param);
- tree gnu_param_type = gnat_to_gnu_type (Etype (gnat_param));
+ bool foreign = Has_Foreign_Convention (gnat_subprog);
bool in_param = (Ekind (gnat_param) == E_In_Parameter);
/* The parameter can be indirectly modified if its address is taken. */
bool ro_param = in_param && !Address_Taken (gnat_param);
bool by_return = false, by_component_ptr = false;
bool by_ref = false;
bool restricted_aliasing_p = false;
+ location_t saved_location = input_location;
tree gnu_param;
- /* Copy-return is used only for the first parameter of a valued procedure.
- It's a copy mechanism for which a parameter is never allocated. */
- if (mech == By_Copy_Return)
+ /* Make sure to use the proper SLOC for vector ABI warnings. */
+ if (VECTOR_TYPE_P (gnu_param_type))
+ Sloc_to_locus (Sloc (gnat_subprog), &input_location);
+
+ /* Builtins are expanded inline and there is no real call sequence involved.
+ So the type expected by the underlying expander is always the type of the
+ argument "as is". */
+ if (Convention (gnat_subprog) == Convention_Intrinsic
+ && Present (Interface_Name (gnat_subprog)))
+ mech = By_Copy;
+
+ /* Handle the first parameter of a valued procedure specially: it's a copy
+ mechanism for which the parameter is never allocated. */
+ else if (first && Is_Valued_Procedure (gnat_subprog))
{
gcc_assert (Ekind (gnat_param) == E_Out_Parameter);
mech = By_Copy;
by_return = true;
}
+ /* Or else, see if a Mechanism was supplied that forced this parameter
+ to be passed one way or another. */
+ else if (mech == Default || mech == By_Copy || mech == By_Reference)
+ ;
+
+ /* Positive mechanism means by copy for sufficiently small parameters. */
+ else if (mech > 0)
+ {
+ if (TREE_CODE (gnu_param_type) == UNCONSTRAINED_ARRAY_TYPE
+ || TREE_CODE (TYPE_SIZE (gnu_param_type)) != INTEGER_CST
+ || compare_tree_int (TYPE_SIZE (gnu_param_type), mech) > 0)
+ mech = By_Reference;
+ else
+ mech = By_Copy;
+ }
+
+ /* Otherwise, it's an unsupported mechanism so error out. */
+ else
+ {
+ post_error ("unsupported mechanism for&", gnat_param);
+ mech = Default;
+ }
+
/* If this is either a foreign function or if the underlying type won't
be passed by reference and is as aligned as the original type, strip
off possible padding type. */
@@ -5843,12 +5451,9 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
}
/* If this is a read-only parameter, make a variant of the type that is
- read-only. ??? However, if this is an unconstrained array, that type
- can be very complex, so skip it for now. Likewise for any other
- self-referential type. */
- if (ro_param
- && TREE_CODE (gnu_param_type) != UNCONSTRAINED_ARRAY_TYPE
- && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type)))
+ read-only. ??? However, if this is a self-referential type, the type
+ can be very complex, so skip it for now. */
+ if (ro_param && !CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_param_type)))
gnu_param_type = change_qualified_type (gnu_param_type, TYPE_QUAL_CONST);
/* For foreign conventions, pass arrays as pointers to the element type.
@@ -5857,12 +5462,6 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
gnu_param_type
= TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (gnu_param_type))));
- /* For GCC builtins, pass Address integer types as (void *) */
- if (Convention (gnat_subprog) == Convention_Intrinsic
- && Present (Interface_Name (gnat_subprog))
- && Is_Descendent_Of_Address (Etype (gnat_param)))
- gnu_param_type = ptr_type_node;
-
/* Arrays are passed as pointers to element type for foreign conventions. */
if (foreign && mech != By_Copy && TREE_CODE (gnu_param_type) == ARRAY_TYPE)
{
@@ -5887,14 +5486,14 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
gnu_param_type
= make_type_from_size (gnu_param_type, size_int (POINTER_SIZE), 0);
- /* If we must pass or were requested to pass by reference, do so.
+ /* If we were requested or muss pass by reference, do so.
If we were requested to pass by copy, do so.
Otherwise, for foreign conventions, pass In Out or Out parameters
or aggregates by reference. For COBOL and Fortran, pass all
integer and FP types that way too. For Convention Ada, use
the standard Ada default. */
- else if (must_pass_by_ref (gnu_param_type)
- || mech == By_Reference
+ else if (mech == By_Reference
+ || must_pass_by_ref (gnu_param_type)
|| (mech != By_Copy
&& ((foreign
&& (!in_param || AGGREGATE_TYPE_P (gnu_param_type)))
@@ -5906,12 +5505,12 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
|| (!foreign
&& default_pass_by_ref (gnu_param_type)))))
{
- gnu_param_type = build_reference_type (gnu_param_type);
/* We take advantage of 6.2(12) by considering that references built for
parameters whose type isn't by-ref and for which the mechanism hasn't
been forced to by-ref allow only a restricted form of aliasing. */
restricted_aliasing_p
= !TYPE_IS_BY_REFERENCE_P (gnu_param_type) && mech != By_Reference;
+ gnu_param_type = build_reference_type (gnu_param_type);
by_ref = true;
}
@@ -5919,6 +5518,8 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
else if (!in_param)
*cico = true;
+ input_location = saved_location;
+
if (mech == By_Copy && (by_ref || by_component_ptr))
post_error ("?cannot pass & by copy", gnat_param);
@@ -5946,20 +5547,21 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
&& (by_return
|| (!POINTER_TYPE_P (gnu_param_type)
&& !AGGREGATE_TYPE_P (gnu_param_type)
- && !Has_Default_Aspect (Etype (gnat_param))))
- && !(Is_Array_Type (Etype (gnat_param))
- && Is_Packed (Etype (gnat_param))
- && Is_Composite_Type (Component_Type (Etype (gnat_param)))))
+ && !Has_Default_Aspect (gnat_param_type)))
+ && !(Is_Array_Type (gnat_param_type)
+ && Is_Packed (gnat_param_type)
+ && Is_Composite_Type (Component_Type (gnat_param_type))))
return gnu_param_type;
- gnu_param = create_param_decl (gnu_param_name, gnu_param_type,
- ro_param || by_ref || by_component_ptr);
+ gnu_param = create_param_decl (gnu_param_name, gnu_param_type);
+ TREE_READONLY (gnu_param) = ro_param || by_ref || by_component_ptr;
DECL_BY_REF_P (gnu_param) = by_ref;
DECL_BY_COMPONENT_PTR_P (gnu_param) = by_component_ptr;
DECL_POINTS_TO_READONLY_P (gnu_param)
= (ro_param && (by_ref || by_component_ptr));
DECL_CAN_NEVER_BE_NULL_P (gnu_param) = Can_Never_Be_Null (gnat_param);
DECL_RESTRICTED_ALIASING_P (gnu_param) = restricted_aliasing_p;
+ Sloc_to_locus (Sloc (gnat_param), &DECL_SOURCE_LOCATION (gnu_param));
/* If no Mechanism was specified, indicate what we're using, then
back-annotate it. */
@@ -5970,28 +5572,740 @@ gnat_to_gnu_param (Entity_Id gnat_param, Mechanism_Type mech,
return gnu_param;
}
-/* Return true if GNAT_ENTITY is an incomplete entity coming from a limited
- with of the main unit and whose full view has not been elaborated yet. */
+/* Associate GNAT_SUBPROG with GNU_TYPE, which must be a dummy type, so that
+ GNAT_SUBPROG is updated when GNU_TYPE is completed.
-static bool
-is_from_limited_with_of_main (Entity_Id gnat_entity)
+ Ada 2012 (AI05-019) says that freezing a subprogram does not always freeze
+ the corresponding profile, which means that, by the time the freeze node
+ of the subprogram is encountered, types involved in its profile may still
+ be not yet frozen. That's why we need to update GNAT_SUBPROG when we see
+ the freeze node of types involved in its profile, either types of formal
+ parameters or the return type. */
+
+static void
+associate_subprog_with_dummy_type (Entity_Id gnat_subprog, tree gnu_type)
{
- /* Class-wide types are always transformed into their root type. */
- if (Ekind (gnat_entity) == E_Class_Wide_Type)
- gnat_entity = Root_Type (gnat_entity);
+ gcc_assert (TYPE_IS_DUMMY_P (gnu_type));
- if (IN (Ekind (gnat_entity), Incomplete_Kind)
- && From_Limited_With (gnat_entity))
+ struct tree_entity_vec_map in;
+ in.base.from = gnu_type;
+ struct tree_entity_vec_map **slot
+ = dummy_to_subprog_map->find_slot (&in, INSERT);
+ if (!*slot)
{
- Entity_Id gnat_full_view = Non_Limited_View (gnat_entity);
+ tree_entity_vec_map *e = ggc_alloc<tree_entity_vec_map> ();
+ e->base.from = gnu_type;
+ e->to = NULL;
+ *slot = e;
+ }
- if (present_gnu_tree (gnat_full_view))
- return false;
+ /* Even if there is already a slot for GNU_TYPE, we need to set the flag
+ because the vector might have been just emptied by update_profiles_with.
+ This can happen when there are 2 freeze nodes associated with different
+ views of the same type; the type will be really complete only after the
+ second freeze node is encountered. */
+ TYPE_DUMMY_IN_PROFILE_P (gnu_type) = 1;
+
+ vec<Entity_Id, va_gc_atomic> *v = (*slot)->to;
- return In_Extended_Main_Code_Unit (gnat_full_view);
+ /* Make sure GNAT_SUBPROG is not associated twice with the same dummy type,
+ since this would mean updating twice its profile. */
+ if (v)
+ {
+ const unsigned len = v->length ();
+ unsigned int l = 0, u = len;
+
+ /* Entity_Id is a simple integer so we can implement a stable order on
+ the vector with an ordered insertion scheme and binary search. */
+ while (l < u)
+ {
+ unsigned int m = (l + u) / 2;
+ int diff = (int) (*v)[m] - (int) gnat_subprog;
+ if (diff > 0)
+ u = m;
+ else if (diff < 0)
+ l = m + 1;
+ else
+ return;
+ }
+
+ /* l == u and therefore is the insertion point. */
+ vec_safe_insert (v, l, gnat_subprog);
}
+ else
+ vec_safe_push (v, gnat_subprog);
- return false;
+ (*slot)->to = v;
+}
+
+/* Update the GCC tree previously built for the profile of GNAT_SUBPROG. */
+
+static void
+update_profile (Entity_Id gnat_subprog)
+{
+ tree gnu_param_list;
+ tree gnu_type = gnat_to_gnu_subprog_type (gnat_subprog, true,
+ Needs_Debug_Info (gnat_subprog),
+ &gnu_param_list);
+ if (DECL_P (gnu_type))
+ {
+ /* Builtins cannot have their address taken so we can reset them. */
+ gcc_assert (DECL_BUILT_IN (gnu_type));
+ save_gnu_tree (gnat_subprog, NULL_TREE, false);
+ save_gnu_tree (gnat_subprog, gnu_type, false);
+ return;
+ }
+
+ tree gnu_subprog = get_gnu_tree (gnat_subprog);
+
+ TREE_TYPE (gnu_subprog) = gnu_type;
+
+ /* If GNAT_SUBPROG is an actual subprogram, GNU_SUBPROG is a FUNCTION_DECL
+ and needs to be adjusted too. */
+ if (Ekind (gnat_subprog) != E_Subprogram_Type)
+ {
+ tree gnu_entity_name = get_entity_name (gnat_subprog);
+ tree gnu_ext_name
+ = gnu_ext_name_for_subprog (gnat_subprog, gnu_entity_name);
+
+ DECL_ARGUMENTS (gnu_subprog) = gnu_param_list;
+ finish_subprog_decl (gnu_subprog, gnu_ext_name, gnu_type);
+ }
+}
+
+/* Update the GCC trees previously built for the profiles involving GNU_TYPE,
+ a dummy type which appears in profiles. */
+
+void
+update_profiles_with (tree gnu_type)
+{
+ struct tree_entity_vec_map in;
+ in.base.from = gnu_type;
+ struct tree_entity_vec_map *e = dummy_to_subprog_map->find (&in);
+ gcc_assert (e);
+ vec<Entity_Id, va_gc_atomic> *v = e->to;
+ e->to = NULL;
+
+ /* The flag needs to be reset before calling update_profile, in case
+ associate_subprog_with_dummy_type is again invoked on GNU_TYPE. */
+ TYPE_DUMMY_IN_PROFILE_P (gnu_type) = 0;
+
+ unsigned int i;
+ Entity_Id *iter;
+ FOR_EACH_VEC_ELT (*v, i, iter)
+ update_profile (*iter);
+
+ vec_free (v);
+}
+
+/* Return the GCC tree for GNAT_TYPE present in the profile of a subprogram.
+
+ Ada 2012 (AI05-0151) says that incomplete types coming from a limited
+ context may now appear as parameter and result types. As a consequence,
+ we may need to defer their translation until after a freeze node is seen
+ or to the end of the current unit. We also aim at handling temporarily
+ incomplete types created by the usual delayed elaboration scheme. */
+
+static tree
+gnat_to_gnu_profile_type (Entity_Id gnat_type)
+{
+ /* This is the same logic as the E_Access_Type case of gnat_to_gnu_entity
+ so the rationale is exposed in that place. These processings probably
+ ought to be merged at some point. */
+ Entity_Id gnat_equiv = Gigi_Equivalent_Type (gnat_type);
+ const bool is_from_limited_with
+ = (IN (Ekind (gnat_equiv), Incomplete_Kind)
+ && From_Limited_With (gnat_equiv));
+ Entity_Id gnat_full_direct_first
+ = (is_from_limited_with
+ ? Non_Limited_View (gnat_equiv)
+ : (IN (Ekind (gnat_equiv), Incomplete_Or_Private_Kind)
+ ? Full_View (gnat_equiv) : Empty));
+ Entity_Id gnat_full_direct
+ = ((is_from_limited_with
+ && Present (gnat_full_direct_first)
+ && IN (Ekind (gnat_full_direct_first), Private_Kind))
+ ? Full_View (gnat_full_direct_first)
+ : gnat_full_direct_first);
+ Entity_Id gnat_full = Gigi_Equivalent_Type (gnat_full_direct);
+ Entity_Id gnat_rep = Present (gnat_full) ? gnat_full : gnat_equiv;
+ const bool in_main_unit = In_Extended_Main_Code_Unit (gnat_rep);
+ tree gnu_type;
+
+ if (Present (gnat_full) && present_gnu_tree (gnat_full))
+ gnu_type = TREE_TYPE (get_gnu_tree (gnat_full));
+
+ else if (is_from_limited_with
+ && ((!in_main_unit
+ && !present_gnu_tree (gnat_equiv)
+ && Present (gnat_full)
+ && (Is_Record_Type (gnat_full)
+ || Is_Array_Type (gnat_full)
+ || Is_Access_Type (gnat_full)))
+ || (in_main_unit && Present (Freeze_Node (gnat_rep)))))
+ {
+ gnu_type = make_dummy_type (gnat_equiv);
+
+ if (!in_main_unit)
+ {
+ struct incomplete *p = XNEW (struct incomplete);
+
+ p->old_type = gnu_type;
+ p->full_type = gnat_equiv;
+ p->next = defer_limited_with_list;
+ defer_limited_with_list = p;
+ }
+ }
+
+ else if (type_annotate_only && No (gnat_equiv))
+ gnu_type = void_type_node;
+
+ else
+ gnu_type = gnat_to_gnu_type (gnat_equiv);
+
+ /* Access-to-unconstrained-array types need a special treatment. */
+ if (Is_Array_Type (gnat_rep) && !Is_Constrained (gnat_rep))
+ {
+ if (!TYPE_POINTER_TO (gnu_type))
+ build_dummy_unc_pointer_types (gnat_equiv, gnu_type);
+ }
+
+ return gnu_type;
+}
+
+/* Return a GCC tree for a subprogram type corresponding to GNAT_SUBPROG.
+ DEFINITION is true if this is for a subprogram being defined. DEBUG_INFO_P
+ is true if we need to write debug information for other types that we may
+ create in the process. Also set PARAM_LIST to the list of parameters.
+ If GNAT_SUBPROG is bound to a GCC builtin, return the DECL for the builtin
+ directly instead of its type. */
+
+static tree
+gnat_to_gnu_subprog_type (Entity_Id gnat_subprog, bool definition,
+ bool debug_info_p, tree *param_list)
+{
+ const Entity_Kind kind = Ekind (gnat_subprog);
+ Entity_Id gnat_return_type = Etype (gnat_subprog);
+ Entity_Id gnat_param;
+ tree gnu_type = present_gnu_tree (gnat_subprog)
+ ? TREE_TYPE (get_gnu_tree (gnat_subprog)) : NULL_TREE;
+ tree gnu_return_type;
+ tree gnu_param_type_list = NULL_TREE;
+ tree gnu_param_list = NULL_TREE;
+ /* Non-null for subprograms containing parameters passed by copy-in copy-out
+ (In Out or Out parameters not passed by reference), in which case it is
+ the list of nodes used to specify the values of the In Out/Out parameters
+ that are returned as a record upon procedure return. The TREE_PURPOSE of
+ an element of this list is a FIELD_DECL of the record and the TREE_VALUE
+ is the PARM_DECL corresponding to that field. This list will be saved in
+ the TYPE_CI_CO_LIST field of the FUNCTION_TYPE node we create. */
+ tree gnu_cico_list = NULL_TREE;
+ tree gnu_cico_return_type = NULL_TREE;
+ /* Fields in return type of procedure with copy-in copy-out parameters. */
+ tree gnu_field_list = NULL_TREE;
+ /* The semantics of "pure" in Ada essentially matches that of "const"
+ in the back-end. In particular, both properties are orthogonal to
+ the "nothrow" property if the EH circuitry is explicit in the
+ internal representation of the back-end. If we are to completely
+ hide the EH circuitry from it, we need to declare that calls to pure
+ Ada subprograms that can throw have side effects since they can
+ trigger an "abnormal" transfer of control flow; thus they can be
+ neither "const" nor "pure" in the back-end sense. */
+ bool const_flag = (Back_End_Exceptions () && Is_Pure (gnat_subprog));
+ bool return_by_direct_ref_p = false;
+ bool return_by_invisi_ref_p = false;
+ bool return_unconstrained_p = false;
+ bool incomplete_profile_p = false;
+ unsigned int num;
+
+ /* Look into the return type and get its associated GCC tree if it is not
+ void, and then compute various flags for the subprogram type. But make
+ sure not to do this processing multiple times. */
+ if (Ekind (gnat_return_type) == E_Void)
+ gnu_return_type = void_type_node;
+
+ else if (gnu_type
+ && TREE_CODE (gnu_type) == FUNCTION_TYPE
+ && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_type)))
+ {
+ gnu_return_type = TREE_TYPE (gnu_type);
+ return_unconstrained_p = TYPE_RETURN_UNCONSTRAINED_P (gnu_type);
+ return_by_direct_ref_p = TYPE_RETURN_BY_DIRECT_REF_P (gnu_type);
+ return_by_invisi_ref_p = TREE_ADDRESSABLE (gnu_type);
+ }
+
+ else
+ {
+ /* For foreign convention subprograms, return System.Address as void *
+ or equivalent. Note that this comprises GCC builtins. */
+ if (Has_Foreign_Convention (gnat_subprog)
+ && Is_Descendant_Of_Address (gnat_return_type))
+ gnu_return_type = ptr_type_node;
+ else
+ gnu_return_type = gnat_to_gnu_profile_type (gnat_return_type);
+
+ /* If this function returns by reference, make the actual return type
+ the reference type and make a note of that. */
+ if (Returns_By_Ref (gnat_subprog))
+ {
+ gnu_return_type = build_reference_type (gnu_return_type);
+ return_by_direct_ref_p = true;
+ }
+
+ /* If the return type is an unconstrained array type, the return value
+ will be allocated on the secondary stack so the actual return type
+ is the fat pointer type. */
+ else if (TREE_CODE (gnu_return_type) == UNCONSTRAINED_ARRAY_TYPE)
+ {
+ gnu_return_type = TYPE_REFERENCE_TO (gnu_return_type);
+ return_unconstrained_p = true;
+ }
+
+ /* This is the same unconstrained array case, but for a dummy type. */
+ else if (TYPE_REFERENCE_TO (gnu_return_type)
+ && TYPE_IS_FAT_POINTER_P (TYPE_REFERENCE_TO (gnu_return_type)))
+ {
+ gnu_return_type = TYPE_REFERENCE_TO (gnu_return_type);
+ return_unconstrained_p = true;
+ }
+
+ /* Likewise, if the return type requires a transient scope, the return
+ value will also be allocated on the secondary stack so the actual
+ return type is the reference type. */
+ else if (Requires_Transient_Scope (gnat_return_type))
+ {
+ gnu_return_type = build_reference_type (gnu_return_type);
+ return_unconstrained_p = true;
+ }
+
+ /* If the Mechanism is By_Reference, ensure this function uses the
+ target's by-invisible-reference mechanism, which may not be the
+ same as above (e.g. it might be passing an extra parameter). */
+ else if (kind == E_Function && Mechanism (gnat_subprog) == By_Reference)
+ return_by_invisi_ref_p = true;
+
+ /* Likewise, if the return type is itself By_Reference. */
+ else if (TYPE_IS_BY_REFERENCE_P (gnu_return_type))
+ return_by_invisi_ref_p = true;
+
+ /* If the type is a padded type and the underlying type would not be
+ passed by reference or the function has a foreign convention, return
+ the underlying type. */
+ else if (TYPE_IS_PADDING_P (gnu_return_type)
+ && (!default_pass_by_ref
+ (TREE_TYPE (TYPE_FIELDS (gnu_return_type)))
+ || Has_Foreign_Convention (gnat_subprog)))
+ gnu_return_type = TREE_TYPE (TYPE_FIELDS (gnu_return_type));
+
+ /* If the return type is unconstrained, it must have a maximum size.
+ Use the padded type as the effective return type. And ensure the
+ function uses the target's by-invisible-reference mechanism to
+ avoid copying too much data when it returns. */
+ if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (gnu_return_type)))
+ {
+ tree orig_type = gnu_return_type;
+ tree max_return_size = max_size (TYPE_SIZE (gnu_return_type), true);
+
+ /* If the size overflows to 0, set it to an arbitrary positive
+ value so that assignments in the type are preserved. Their
+ actual size is independent of this positive value. */
+ if (TREE_CODE (max_return_size) == INTEGER_CST
+ && TREE_OVERFLOW (max_return_size)
+ && integer_zerop (max_return_size))
+ {
+ max_return_size = copy_node (bitsize_unit_node);
+ TREE_OVERFLOW (max_return_size) = 1;
+ }
+
+ gnu_return_type = maybe_pad_type (gnu_return_type, max_return_size,
+ 0, gnat_subprog, false, false,
+ definition, true);
+
+ /* Declare it now since it will never be declared otherwise. This
+ is necessary to ensure that its subtrees are properly marked. */
+ if (gnu_return_type != orig_type
+ && !DECL_P (TYPE_NAME (gnu_return_type)))
+ create_type_decl (TYPE_NAME (gnu_return_type), gnu_return_type,
+ true, debug_info_p, gnat_subprog);
+
+ return_by_invisi_ref_p = true;
+ }
+
+ /* If the return type has a size that overflows, we usually cannot have
+ a function that returns that type. This usage doesn't really make
+ sense anyway, so issue an error here. */
+ if (!return_by_invisi_ref_p
+ && TYPE_SIZE_UNIT (gnu_return_type)
+ && TREE_CODE (TYPE_SIZE_UNIT (gnu_return_type)) == INTEGER_CST
+ && !valid_constant_size_p (TYPE_SIZE_UNIT (gnu_return_type)))
+ {
+ post_error ("cannot return type whose size overflows", gnat_subprog);
+ gnu_return_type = copy_type (gnu_return_type);
+ TYPE_SIZE (gnu_return_type) = bitsize_zero_node;
+ TYPE_SIZE_UNIT (gnu_return_type) = size_zero_node;
+ }
+
+ /* If the return type is incomplete, there are 2 cases: if the function
+ returns by reference, then the return type is only linked indirectly
+ in the profile, so the profile can be seen as complete since it need
+ not be further modified, only the reference types need be adjusted;
+ otherwise the profile is incomplete and need be adjusted too. */
+ if (TYPE_IS_DUMMY_P (gnu_return_type))
+ {
+ associate_subprog_with_dummy_type (gnat_subprog, gnu_return_type);
+ incomplete_profile_p = true;
+ }
+
+ if (kind == E_Function)
+ Set_Mechanism (gnat_subprog, return_unconstrained_p
+ || return_by_direct_ref_p
+ || return_by_invisi_ref_p
+ ? By_Reference : By_Copy);
+ }
+
+ /* A procedure (something that doesn't return anything) shouldn't be
+ considered const since there would be no reason for calling such a
+ subprogram. Note that procedures with Out (or In Out) parameters
+ have already been converted into a function with a return type.
+ Similarly, if the function returns an unconstrained type, then the
+ function will allocate the return value on the secondary stack and
+ thus calls to it cannot be CSE'ed, lest the stack be reclaimed. */
+ if (TREE_CODE (gnu_return_type) == VOID_TYPE || return_unconstrained_p)
+ const_flag = false;
+
+ /* Loop over the parameters and get their associated GCC tree. While doing
+ this, build a copy-in copy-out structure if we need one. */
+ for (gnat_param = First_Formal_With_Extras (gnat_subprog), num = 0;
+ Present (gnat_param);
+ gnat_param = Next_Formal_With_Extras (gnat_param), num++)
+ {
+ const bool mech_is_by_ref
+ = Mechanism (gnat_param) == By_Reference
+ && !(num == 0 && Is_Valued_Procedure (gnat_subprog));
+ tree gnu_param_name = get_entity_name (gnat_param);
+ tree gnu_param, gnu_param_type;
+ bool cico = false;
+
+ /* Fetch an existing parameter with complete type and reuse it. But we
+ didn't save the CICO property so we can only do it for In parameters
+ or parameters passed by reference. */
+ if ((Ekind (gnat_param) == E_In_Parameter || mech_is_by_ref)
+ && present_gnu_tree (gnat_param)
+ && (gnu_param = get_gnu_tree (gnat_param))
+ && !TYPE_IS_DUMMY_P (TREE_TYPE (gnu_param)))
+ {
+ DECL_CHAIN (gnu_param) = NULL_TREE;
+ gnu_param_type = TREE_TYPE (gnu_param);
+ }
+
+ /* Otherwise translate the parameter type and act accordingly. */
+ else
+ {
+ Entity_Id gnat_param_type = Etype (gnat_param);
+
+ /* For foreign convention subprograms, pass System.Address as void *
+ or equivalent. Note that this comprises GCC builtins. */
+ if (Has_Foreign_Convention (gnat_subprog)
+ && Is_Descendant_Of_Address (gnat_param_type))
+ gnu_param_type = ptr_type_node;
+ else
+ gnu_param_type = gnat_to_gnu_profile_type (gnat_param_type);
+
+ /* If the parameter type is incomplete, there are 2 cases: if it is
+ passed by reference, then the type is only linked indirectly in
+ the profile, so the profile can be seen as complete since it need
+ not be further modified, only the reference type need be adjusted;
+ otherwise the profile is incomplete and need be adjusted too. */
+ if (TYPE_IS_DUMMY_P (gnu_param_type))
+ {
+ Node_Id gnat_decl;
+
+ if (mech_is_by_ref
+ || (TYPE_REFERENCE_TO (gnu_param_type)
+ && TYPE_IS_FAT_POINTER_P
+ (TYPE_REFERENCE_TO (gnu_param_type)))
+ || TYPE_IS_BY_REFERENCE_P (gnu_param_type))
+ {
+ gnu_param_type = build_reference_type (gnu_param_type);
+ gnu_param
+ = create_param_decl (gnu_param_name, gnu_param_type);
+ TREE_READONLY (gnu_param) = 1;
+ DECL_BY_REF_P (gnu_param) = 1;
+ DECL_POINTS_TO_READONLY_P (gnu_param)
+ = (Ekind (gnat_param) == E_In_Parameter
+ && !Address_Taken (gnat_param));
+ Set_Mechanism (gnat_param, By_Reference);
+ Sloc_to_locus (Sloc (gnat_param),
+ &DECL_SOURCE_LOCATION (gnu_param));
+ }
+
+ /* ??? This is a kludge to support null procedures in spec taking
+ a parameter with an untagged incomplete type coming from a
+ limited context. The front-end creates a body without knowing
+ anything about the non-limited view, which is illegal Ada and
+ cannot be supported. Create a parameter with a fake type. */
+ else if (kind == E_Procedure
+ && (gnat_decl = Parent (gnat_subprog))
+ && Nkind (gnat_decl) == N_Procedure_Specification
+ && Null_Present (gnat_decl)
+ && IN (Ekind (gnat_param_type), Incomplete_Kind))
+ gnu_param = create_param_decl (gnu_param_name, ptr_type_node);
+
+ else
+ {
+ /* Build a minimal PARM_DECL without DECL_ARG_TYPE so that
+ Call_to_gnu will stop if it encounters the PARM_DECL. */
+ gnu_param
+ = build_decl (input_location, PARM_DECL, gnu_param_name,
+ gnu_param_type);
+ associate_subprog_with_dummy_type (gnat_subprog,
+ gnu_param_type);
+ incomplete_profile_p = true;
+ }
+ }
+
+ /* Otherwise build the parameter declaration normally. */
+ else
+ {
+ gnu_param
+ = gnat_to_gnu_param (gnat_param, gnu_param_type, num == 0,
+ gnat_subprog, &cico);
+
+ /* We are returned either a PARM_DECL or a type if no parameter
+ needs to be passed; in either case, adjust the type. */
+ if (DECL_P (gnu_param))
+ gnu_param_type = TREE_TYPE (gnu_param);
+ else
+ {
+ gnu_param_type = gnu_param;
+ gnu_param = NULL_TREE;
+ }
+ }
+ }
+
+ /* If we have a GCC tree for the parameter, register it. */
+ save_gnu_tree (gnat_param, NULL_TREE, false);
+ if (gnu_param)
+ {
+ gnu_param_type_list
+ = tree_cons (NULL_TREE, gnu_param_type, gnu_param_type_list);
+ gnu_param_list = chainon (gnu_param, gnu_param_list);
+ save_gnu_tree (gnat_param, gnu_param, false);
+
+ /* If a parameter is a pointer, a function may modify memory through
+ it and thus shouldn't be considered a const function. Also, the
+ memory may be modified between two calls, so they can't be CSE'ed.
+ The latter case also handles by-ref parameters. */
+ if (POINTER_TYPE_P (gnu_param_type)
+ || TYPE_IS_FAT_POINTER_P (gnu_param_type))
+ const_flag = false;
+ }
+
+ /* If the parameter uses the copy-in copy-out mechanism, allocate a field
+ for it in the return type and register the association. */
+ if (cico && !incomplete_profile_p)
+ {
+ if (!gnu_cico_list)
+ {
+ gnu_cico_return_type = make_node (RECORD_TYPE);
+
+ /* If this is a function, we also need a field for the
+ return value to be placed. */
+ if (!VOID_TYPE_P (gnu_return_type))
+ {
+ tree gnu_field
+ = create_field_decl (get_identifier ("RETVAL"),
+ gnu_return_type,
+ gnu_cico_return_type, NULL_TREE,
+ NULL_TREE, 0, 0);
+ Sloc_to_locus (Sloc (gnat_subprog),
+ &DECL_SOURCE_LOCATION (gnu_field));
+ gnu_field_list = gnu_field;
+ gnu_cico_list
+ = tree_cons (gnu_field, void_type_node, NULL_TREE);
+ }
+
+ TYPE_NAME (gnu_cico_return_type) = get_identifier ("RETURN");
+ /* Set a default alignment to speed up accesses. But we should
+ not increase the size of the structure too much, lest it does
+ not fit in return registers anymore. */
+ SET_TYPE_ALIGN (gnu_cico_return_type,
+ get_mode_alignment (ptr_mode));
+ }
+
+ tree gnu_field
+ = create_field_decl (gnu_param_name, gnu_param_type,
+ gnu_cico_return_type, NULL_TREE, NULL_TREE,
+ 0, 0);
+ Sloc_to_locus (Sloc (gnat_param),
+ &DECL_SOURCE_LOCATION (gnu_field));
+ DECL_CHAIN (gnu_field) = gnu_field_list;
+ gnu_field_list = gnu_field;
+ gnu_cico_list = tree_cons (gnu_field, gnu_param, gnu_cico_list);
+ }
+ }
+
+ /* If the subprogram uses the copy-in copy-out mechanism, possibly adjust
+ and finish up the return type. */
+ if (gnu_cico_list && !incomplete_profile_p)
+ {
+ /* If we have a CICO list but it has only one entry, we convert
+ this function into a function that returns this object. */
+ if (list_length (gnu_cico_list) == 1)
+ gnu_cico_return_type = TREE_TYPE (TREE_PURPOSE (gnu_cico_list));
+
+ /* Do not finalize the return type if the subprogram is stubbed
+ since structures are incomplete for the back-end. */
+ else if (Convention (gnat_subprog) != Convention_Stubbed)
+ {
+ finish_record_type (gnu_cico_return_type, nreverse (gnu_field_list),
+ 0, false);
+
+ /* Try to promote the mode of the return type if it is passed
+ in registers, again to speed up accesses. */
+ if (TYPE_MODE (gnu_cico_return_type) == BLKmode
+ && !targetm.calls.return_in_memory (gnu_cico_return_type,
+ NULL_TREE))
+ {
+ unsigned int size
+ = TREE_INT_CST_LOW (TYPE_SIZE (gnu_cico_return_type));
+ unsigned int i = BITS_PER_UNIT;
+ machine_mode mode;
+
+ while (i < size)
+ i <<= 1;
+ mode = mode_for_size (i, MODE_INT, 0);
+ if (mode != BLKmode)
+ {
+ SET_TYPE_MODE (gnu_cico_return_type, mode);
+ SET_TYPE_ALIGN (gnu_cico_return_type,
+ GET_MODE_ALIGNMENT (mode));
+ TYPE_SIZE (gnu_cico_return_type)
+ = bitsize_int (GET_MODE_BITSIZE (mode));
+ TYPE_SIZE_UNIT (gnu_cico_return_type)
+ = size_int (GET_MODE_SIZE (mode));
+ }
+ }
+
+ if (debug_info_p)
+ rest_of_record_type_compilation (gnu_cico_return_type);
+ }
+
+ gnu_return_type = gnu_cico_return_type;
+ }
+
+ /* The lists have been built in reverse. */
+ gnu_param_type_list = nreverse (gnu_param_type_list);
+ gnu_param_type_list = chainon (gnu_param_type_list, void_list_node);
+ *param_list = nreverse (gnu_param_list);
+ gnu_cico_list = nreverse (gnu_cico_list);
+
+ /* If the profile is incomplete, we only set the (temporary) return and
+ parameter types; otherwise, we build the full type. In either case,
+ we reuse an already existing GCC tree that we built previously here. */
+ if (incomplete_profile_p)
+ {
+ if (gnu_type && TREE_CODE (gnu_type) == FUNCTION_TYPE)
+ ;
+ else
+ gnu_type = make_node (FUNCTION_TYPE);
+ TREE_TYPE (gnu_type) = gnu_return_type;
+ TYPE_ARG_TYPES (gnu_type) = gnu_param_type_list;
+ TYPE_RETURN_UNCONSTRAINED_P (gnu_type) = return_unconstrained_p;
+ TYPE_RETURN_BY_DIRECT_REF_P (gnu_type) = return_by_direct_ref_p;
+ TREE_ADDRESSABLE (gnu_type) = return_by_invisi_ref_p;
+ }
+ else
+ {
+ if (gnu_type && TREE_CODE (gnu_type) == FUNCTION_TYPE)
+ {
+ TREE_TYPE (gnu_type) = gnu_return_type;
+ TYPE_ARG_TYPES (gnu_type) = gnu_param_type_list;
+ TYPE_CI_CO_LIST (gnu_type) = gnu_cico_list;
+ TYPE_RETURN_UNCONSTRAINED_P (gnu_type) = return_unconstrained_p;
+ TYPE_RETURN_BY_DIRECT_REF_P (gnu_type) = return_by_direct_ref_p;
+ TREE_ADDRESSABLE (gnu_type) = return_by_invisi_ref_p;
+ TYPE_CANONICAL (gnu_type) = gnu_type;
+ layout_type (gnu_type);
+ }
+ else
+ {
+ gnu_type
+ = build_function_type (gnu_return_type, gnu_param_type_list);
+
+ /* GNU_TYPE may be shared since GCC hashes types. Unshare it if it
+ has a different TYPE_CI_CO_LIST or flags. */
+ if (!fntype_same_flags_p (gnu_type, gnu_cico_list,
+ return_unconstrained_p,
+ return_by_direct_ref_p,
+ return_by_invisi_ref_p))
+ {
+ gnu_type = copy_type (gnu_type);
+ TYPE_CI_CO_LIST (gnu_type) = gnu_cico_list;
+ TYPE_RETURN_UNCONSTRAINED_P (gnu_type) = return_unconstrained_p;
+ TYPE_RETURN_BY_DIRECT_REF_P (gnu_type) = return_by_direct_ref_p;
+ TREE_ADDRESSABLE (gnu_type) = return_by_invisi_ref_p;
+ }
+ }
+
+ if (const_flag)
+ gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_CONST);
+
+ if (No_Return (gnat_subprog))
+ gnu_type = change_qualified_type (gnu_type, TYPE_QUAL_VOLATILE);
+
+ /* If this subprogram is expectedly bound to a GCC builtin, fetch the
+ corresponding DECL node and check the parameter association. */
+ if (Convention (gnat_subprog) == Convention_Intrinsic
+ && Present (Interface_Name (gnat_subprog)))
+ {
+ tree gnu_ext_name = create_concat_name (gnat_subprog, NULL);
+ tree gnu_builtin_decl = builtin_decl_for (gnu_ext_name);
+
+ /* If we have a builtin DECL for that function, use it. Check if
+ the profiles are compatible and warn if they are not. Note that
+ the checker is expected to post diagnostics in this case. */
+ if (gnu_builtin_decl)
+ {
+ intrin_binding_t inb
+ = { gnat_subprog, gnu_type, TREE_TYPE (gnu_builtin_decl) };
+
+ if (!intrin_profiles_compatible_p (&inb))
+ post_error
+ ("?profile of& doesn''t match the builtin it binds!",
+ gnat_subprog);
+
+ return gnu_builtin_decl;
+ }
+
+ /* Inability to find the builtin DECL most often indicates a genuine
+ mistake, but imports of unregistered intrinsics are sometimes used
+ on purpose to allow hooking in alternate bodies; we post a warning
+ conditioned on Wshadow in this case, to let developers be notified
+ on demand without risking false positives with common default sets
+ of options. */
+ if (warn_shadow)
+ post_error ("?gcc intrinsic not found for&!", gnat_subprog);
+ }
+ }
+
+ return gnu_type;
+}
+
+/* Return the external name for GNAT_SUBPROG given its entity name. */
+
+static tree
+gnu_ext_name_for_subprog (Entity_Id gnat_subprog, tree gnu_entity_name)
+{
+ tree gnu_ext_name = create_concat_name (gnat_subprog, NULL);
+
+ /* If there was no specified Interface_Name and the external and
+ internal names of the subprogram are the same, only use the
+ internal name to allow disambiguation of nested subprograms. */
+ if (No (Interface_Name (gnat_subprog)) && gnu_ext_name == gnu_entity_name)
+ gnu_ext_name = NULL_TREE;
+
+ return gnu_ext_name;
}
/* Like build_qualified_type, but TYPE_QUALS is added to the existing
@@ -6000,9 +6314,33 @@ is_from_limited_with_of_main (Entity_Id gnat_entity)
static tree
change_qualified_type (tree type, int type_quals)
{
+ /* Qualifiers must be put on the associated array type. */
+ if (TREE_CODE (type) == UNCONSTRAINED_ARRAY_TYPE)
+ return type;
+
return build_qualified_type (type, TYPE_QUALS (type) | type_quals);
}
+/* Set TYPE_NONALIASED_COMPONENT on an array type built by means of
+ build_nonshared_array_type. */
+
+static void
+set_nonaliased_component_on_array_type (tree type)
+{
+ TYPE_NONALIASED_COMPONENT (type) = 1;
+ TYPE_NONALIASED_COMPONENT (TYPE_CANONICAL (type)) = 1;
+}
+
+/* Set TYPE_REVERSE_STORAGE_ORDER on an array type built by means of
+ build_nonshared_array_type. */
+
+static void
+set_reverse_storage_order_on_array_type (tree type)
+{
+ TYPE_REVERSE_STORAGE_ORDER (type) = 1;
+ TYPE_REVERSE_STORAGE_ORDER (TYPE_CANONICAL (type)) = 1;
+}
+
/* Return true if DISCR1 and DISCR2 represent the same discriminant. */
static bool
@@ -6058,6 +6396,15 @@ array_type_has_nonaliased_component (tree gnu_type, Entity_Id gnat_type)
static bool
compile_time_known_address_p (Node_Id gnat_address)
{
+ /* Handle reference to a constant. */
+ if (Is_Entity_Name (gnat_address)
+ && Ekind (Entity (gnat_address)) == E_Constant)
+ {
+ gnat_address = Constant_Value (Entity (gnat_address));
+ if (No (gnat_address))
+ return false;
+ }
+
/* Catch System'To_Address. */
if (Nkind (gnat_address) == N_Unchecked_Type_Conversion)
gnat_address = Expression (gnat_address);
@@ -6526,7 +6873,7 @@ elaborate_reference_1 (tree ref, void *data)
&& TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (ref, 0))))
return build3 (COMPONENT_REF, TREE_TYPE (ref),
elaborate_reference_1 (TREE_OPERAND (ref, 0), data),
- TREE_OPERAND (ref, 1), TREE_OPERAND (ref, 2));
+ TREE_OPERAND (ref, 1), NULL_TREE);
sprintf (suffix, "EXP%d", ++er->n);
return
@@ -6548,7 +6895,7 @@ elaborate_reference (tree ref, Entity_Id gnat_entity, bool definition,
/* Given a GNU tree and a GNAT list of choices, generate an expression to test
the value passed against the list of choices. */
-tree
+static tree
choices_to_gnu (tree operand, Node_Id choices)
{
Node_Id choice;
@@ -6567,9 +6914,10 @@ choices_to_gnu (tree operand, Node_Id choices)
this_test
= build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
build_binary_op (GE_EXPR, boolean_type_node,
- operand, low),
+ operand, low, true),
build_binary_op (LE_EXPR, boolean_type_node,
- operand, high));
+ operand, high, true),
+ true);
break;
@@ -6581,9 +6929,10 @@ choices_to_gnu (tree operand, Node_Id choices)
this_test
= build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
build_binary_op (GE_EXPR, boolean_type_node,
- operand, low),
+ operand, low, true),
build_binary_op (LE_EXPR, boolean_type_node,
- operand, high));
+ operand, high, true),
+ true);
break;
case N_Identifier:
@@ -6602,9 +6951,10 @@ choices_to_gnu (tree operand, Node_Id choices)
this_test
= build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
build_binary_op (GE_EXPR, boolean_type_node,
- operand, low),
+ operand, low, true),
build_binary_op (LE_EXPR, boolean_type_node,
- operand, high));
+ operand, high, true),
+ true);
break;
}
@@ -6614,7 +6964,7 @@ choices_to_gnu (tree operand, Node_Id choices)
case N_Integer_Literal:
single = gnat_to_gnu (choice);
this_test = build_binary_op (EQ_EXPR, boolean_type_node, operand,
- single);
+ single, true);
break;
case N_Others_Choice:
@@ -6625,8 +6975,11 @@ choices_to_gnu (tree operand, Node_Id choices)
gcc_unreachable ();
}
- result = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, result,
- this_test);
+ if (result == boolean_false_node)
+ result = this_test;
+ else
+ result = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node, result,
+ this_test, true);
}
return result;
@@ -6678,6 +7031,7 @@ static tree
gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
bool definition, bool debug_info_p)
{
+ const Entity_Id gnat_record_type = Underlying_Type (Scope (gnat_field));
const Entity_Id gnat_field_type = Etype (gnat_field);
const bool is_aliased
= Is_Aliased (gnat_field);
@@ -6764,8 +7118,7 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
if (Present (Component_Clause (gnat_field)))
{
Node_Id gnat_clause = Component_Clause (gnat_field);
- Entity_Id gnat_parent
- = Parent_Subtype (Underlying_Type (Scope (gnat_field)));
+ Entity_Id gnat_parent = Parent_Subtype (gnat_record_type);
gnu_pos = UI_To_gnu (Component_Bit_Offset (gnat_field), bitsizetype);
gnu_size = validate_size (Esize (gnat_field), gnu_field_type,
@@ -6799,7 +7152,7 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
const unsigned int type_align = TYPE_ALIGN (gnu_field_type);
if (TYPE_ALIGN (gnu_record_type) < type_align)
- TYPE_ALIGN (gnu_record_type) = type_align;
+ SET_TYPE_ALIGN (gnu_record_type, type_align);
/* If the position is not a multiple of the alignment of the type,
then error out and reset the position. */
@@ -6884,7 +7237,7 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
/* If the record has rep clauses and this is the tag field, make a rep
clause for it as well. */
- else if (Has_Specified_Layout (Scope (gnat_field))
+ else if (Has_Specified_Layout (gnat_record_type)
&& Chars (gnat_field) == Name_uTag)
{
gnu_pos = bitsize_zero_node;
@@ -6921,11 +7274,14 @@ gnat_to_gnu_field (Entity_Id gnat_field, tree gnu_record_type, int packed,
/* If the field's type is justified modular, we would need to remove
the wrapper to (better) meet the layout requirements. However we
can do so only if the field is not aliased to preserve the unique
- layout and if the prescribed size is not greater than that of the
- packed array to preserve the justification. */
+ layout, if it has the same storage order as the enclosing record
+ and if the prescribed size is not greater than that of the packed
+ array to preserve the justification. */
if (!needs_strict_alignment
&& TREE_CODE (gnu_field_type) == RECORD_TYPE
&& TYPE_JUSTIFIED_MODULAR_P (gnu_field_type)
+ && TYPE_REVERSE_STORAGE_ORDER (gnu_field_type)
+ == Reverse_Storage_Order (gnat_record_type)
&& tree_int_cst_compare (gnu_size, TYPE_ADA_SIZE (gnu_field_type))
<= 0)
gnu_field_type = TREE_TYPE (TYPE_FIELDS (gnu_field_type));
@@ -7286,7 +7642,7 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list,
= make_node (unchecked_union ? UNION_TYPE : QUAL_UNION_TYPE);
TYPE_NAME (gnu_union_type) = gnu_union_name;
- TYPE_ALIGN (gnu_union_type) = 0;
+ SET_TYPE_ALIGN (gnu_union_type, 0);
TYPE_PACKED (gnu_union_type) = TYPE_PACKED (gnu_record_type);
TYPE_REVERSE_STORAGE_ORDER (gnu_union_type)
= TYPE_REVERSE_STORAGE_ORDER (gnu_record_type);
@@ -7339,7 +7695,7 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list,
/* Set the alignment of the inner type in case we need to make
inner objects into bitfields, but then clear it out so the
record actually gets only the alignment required. */
- TYPE_ALIGN (gnu_variant_type) = TYPE_ALIGN (gnu_record_type);
+ SET_TYPE_ALIGN (gnu_variant_type, TYPE_ALIGN (gnu_record_type));
TYPE_PACKED (gnu_variant_type) = TYPE_PACKED (gnu_record_type);
TYPE_REVERSE_STORAGE_ORDER (gnu_variant_type)
= TYPE_REVERSE_STORAGE_ORDER (gnu_record_type);
@@ -7571,9 +7927,9 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list,
SET_DECL_OFFSET_ALIGN (gnu_field, BIGGEST_ALIGNMENT);
DECL_FIELD_BIT_OFFSET (gnu_field) = bitsize_zero_node;
if (field_is_aliased (gnu_field))
- TYPE_ALIGN (gnu_record_type)
- = MAX (TYPE_ALIGN (gnu_record_type),
- TYPE_ALIGN (TREE_TYPE (gnu_field)));
+ SET_TYPE_ALIGN (gnu_record_type,
+ MAX (TYPE_ALIGN (gnu_record_type),
+ TYPE_ALIGN (TREE_TYPE (gnu_field))));
MOVE_FROM_FIELD_LIST_TO (gnu_zero_list);
continue;
}
@@ -7684,7 +8040,7 @@ components_to_record (tree gnu_record_type, Node_Id gnat_component_list,
gnu_field_list = chainon (gnu_field_list, gnu_variant_part);
if (cancel_alignment)
- TYPE_ALIGN (gnu_record_type) = 0;
+ SET_TYPE_ALIGN (gnu_record_type, 0);
TYPE_ARTIFICIAL (gnu_record_type) = artificial;
@@ -7732,6 +8088,14 @@ annotate_value (tree gnu_size)
switch (TREE_CODE (gnu_size))
{
case INTEGER_CST:
+ /* For negative values, build NEGATE_EXPR of the opposite. Such values
+ can appear for discriminants in expressions for variants. */
+ if (tree_int_cst_sgn (gnu_size) < 0)
+ {
+ tree t = wide_int_to_tree (sizetype, wi::neg (gnu_size));
+ return annotate_value (build1 (NEGATE_EXPR, sizetype, t));
+ }
+
return TREE_OVERFLOW (gnu_size) ? No_Uint : UI_From_gnu (gnu_size);
case COMPONENT_REF:
@@ -8605,10 +8969,6 @@ intrin_return_compatible_p (intrin_binding_t * inb)
&& !VOID_TYPE_P (btin_return_type))
return true;
- /* If return type is Address (integer type), map it to void *. */
- if (Is_Descendent_Of_Address (Etype (inb->gnat_entity)))
- ada_return_type = ptr_type_node;
-
/* Check return types compatibility otherwise. Note that this
handles void/void as well. */
if (intrin_types_incompatible_p (btin_return_type, ada_return_type))
@@ -8797,7 +9157,7 @@ create_variant_part_from (tree old_variant_part,
SET_TYPE_ADA_SIZE (new_union_type,
size_binop (MINUS_EXPR, TYPE_ADA_SIZE (record_type),
first_bit));
- TYPE_ALIGN (new_union_type) = TYPE_ALIGN (old_union_type);
+ SET_TYPE_ALIGN (new_union_type, TYPE_ALIGN (old_union_type));
relate_alias_sets (new_union_type, old_union_type, ALIAS_SET_COPY);
}
else
@@ -8894,7 +9254,7 @@ copy_and_substitute_in_size (tree new_type, tree old_type,
TYPE_SIZE (new_type) = TYPE_SIZE (old_type);
TYPE_SIZE_UNIT (new_type) = TYPE_SIZE_UNIT (old_type);
SET_TYPE_ADA_SIZE (new_type, TYPE_ADA_SIZE (old_type));
- TYPE_ALIGN (new_type) = TYPE_ALIGN (old_type);
+ SET_TYPE_ALIGN (new_type, TYPE_ALIGN (old_type));
relate_alias_sets (new_type, old_type, ALIAS_SET_COPY);
if (CONTAINS_PLACEHOLDER_P (TYPE_SIZE (new_type)))
@@ -9037,14 +9397,17 @@ substitute_in_type (tree t, tree f, tree r)
return t;
nt = build_nonshared_array_type (component, domain);
- TYPE_ALIGN (nt) = TYPE_ALIGN (t);
+ SET_TYPE_ALIGN (nt, TYPE_ALIGN (t));
TYPE_USER_ALIGN (nt) = TYPE_USER_ALIGN (t);
SET_TYPE_MODE (nt, TYPE_MODE (t));
TYPE_SIZE (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE (t), f, r);
TYPE_SIZE_UNIT (nt) = SUBSTITUTE_IN_EXPR (TYPE_SIZE_UNIT (t), f, r);
- TYPE_NONALIASED_COMPONENT (nt) = TYPE_NONALIASED_COMPONENT (t);
TYPE_MULTI_ARRAY_P (nt) = TYPE_MULTI_ARRAY_P (t);
TYPE_CONVENTION_FORTRAN_P (nt) = TYPE_CONVENTION_FORTRAN_P (t);
+ if (TYPE_REVERSE_STORAGE_ORDER (t))
+ set_reverse_storage_order_on_array_type (nt);
+ if (TYPE_NONALIASED_COMPONENT (t))
+ set_nonaliased_component_on_array_type (nt);
return nt;
}
@@ -9210,6 +9573,9 @@ init_gnat_decl (void)
{
/* Initialize the cache of annotated values. */
annotate_value_cache = hash_table<value_annotation_hasher>::create_ggc (512);
+
+ /* Initialize the association of dummy types with subprograms. */
+ dummy_to_subprog_map = hash_table<dummy_type_hasher>::create_ggc (512);
}
/* Destroy data structures of the decl.c module. */
@@ -9220,6 +9586,10 @@ destroy_gnat_decl (void)
/* Destroy the cache of annotated values. */
annotate_value_cache->empty ();
annotate_value_cache = NULL;
+
+ /* Destroy the association of dummy types with subprograms. */
+ dummy_to_subprog_map->empty ();
+ dummy_to_subprog_map = NULL;
}
#include "gt-ada-decl.h"
diff --git a/gcc/ada/gcc-interface/gigi.h b/gcc/ada/gcc-interface/gigi.h
index 2b58d4eadb..1d87b5be44 100644
--- a/gcc/ada/gcc-interface/gigi.h
+++ b/gcc/ada/gcc-interface/gigi.h
@@ -34,14 +34,12 @@
initial value (in GCC tree form). This is optional for variables.
For renamed entities, GNU_EXPR gives the object being renamed.
- DEFINITION is nonzero if this call is intended for a definition. This is
- used for separate compilation where it necessary to know whether an
- external declaration or a definition should be created if the GCC equivalent
- was not created previously. The value of 1 is normally used for a nonzero
- DEFINITION, but a value of 2 is used in special circumstances, defined in
- the code. */
+ DEFINITION is true if this call is intended for a definition. This is used
+ for separate compilation where it is necessary to know whether an external
+ declaration or a definition must be created if the GCC equivalent was not
+ created previously. */
extern tree gnat_to_gnu_entity (Entity_Id gnat_entity, tree gnu_expr,
- int definition);
+ bool definition);
/* Similar, but if the returned value is a COMPONENT_REF, return the
FIELD_DECL. */
@@ -51,6 +49,10 @@ extern tree gnat_to_gnu_field_decl (Entity_Id gnat_entity);
the GCC type corresponding to that entity. */
extern tree gnat_to_gnu_type (Entity_Id gnat_entity);
+/* Update the GCC tree previously built for the profiles involving GNU_TYPE,
+ a dummy type which appears in profiles. */
+extern void update_profiles_with (tree gnu_type);
+
/* Start a new statement group chained to the previous group. */
extern void start_stmt_group (void);
@@ -111,11 +113,6 @@ extern void elaborate_entity (Entity_Id gnat_entity);
/* Get the unpadded version of a GNAT type. */
extern tree get_unpadded_type (Entity_Id gnat_entity);
-/* Return the DECL associated with the public subprogram GNAT_ENTITY but whose
- type has been changed to that of the parameterless procedure, except if an
- alias is already present, in which case it is returned instead. */
-extern tree get_minimal_subprog_decl (Entity_Id gnat_entity);
-
/* Return whether the E_Subprogram_Type/E_Function/E_Procedure GNAT_ENTITY is
a C++ imported method or equivalent. */
extern bool is_cplusplus_method (Entity_Id gnat_entity);
@@ -132,9 +129,11 @@ extern tree make_aligning_type (tree type, unsigned int align, tree size,
as the field type of a packed record if IN_RECORD is true, or as the
component type of a packed array if IN_RECORD is false. See if we can
rewrite it either as a type that has a non-BLKmode, which we can pack
- tighter in the packed record case, or as a smaller type. If so, return
- the new type. If not, return the original type. */
-extern tree make_packable_type (tree type, bool in_record);
+ tighter in the packed record case, or as a smaller type with at most
+ MAX_ALIGN alignment if the value is non-zero. If so, return the new
+ type; if not, return the original type. */
+extern tree make_packable_type (tree type, bool in_record,
+ unsigned int max_align = 0);
/* Given a type TYPE, return a new type whose size is appropriate for SIZE.
If TYPE is the best type, return it. Otherwise, make a new type. We
@@ -148,7 +147,8 @@ extern tree make_type_from_size (tree type, tree size_tree, bool for_biased);
IS_COMPONENT_TYPE is true if this is being done for the component type of
an array. IS_USER_TYPE is true if the original type needs to be completed.
DEFINITION is true if this type is being defined. SET_RM_SIZE is true if
- the RM size of the resulting type is to be set to SIZE too. */
+ the RM size of the resulting type is to be set to SIZE too; in this case,
+ the padded type is canonicalized before being returned. */
extern tree maybe_pad_type (tree type, tree size, unsigned int align,
Entity_Id gnat_entity, bool is_component_type,
bool is_user_type, bool definition,
@@ -174,10 +174,6 @@ enum alias_set_op
extern void relate_alias_sets (tree gnu_new_type, tree gnu_old_type,
enum alias_set_op op);
-/* Given a GNU tree and a GNAT list of choices, generate an expression to test
- the value passed against the list of choices. */
-extern tree choices_to_gnu (tree operand, Node_Id choices);
-
/* Given GNAT_ENTITY, an object (constant, variable, parameter, exception)
and GNU_TYPE, its corresponding GCC type, set Esize and Alignment to the
size and alignment used by Gigi. Prefer SIZE over TYPE_SIZE if non-null.
@@ -394,13 +390,15 @@ enum standard_datatypes
/* Value BITS_PER_UNIT in signed bitsizetype. */
ADT_sbitsize_unit_node,
- /* Function declaration nodes for run-time functions for allocating memory.
- Ada allocators cause calls to this function to be generated. */
+ /* Function declaration node for run-time allocation function. */
ADT_malloc_decl,
- /* Likewise for freeing memory. */
+ /* Function declaration node for run-time freeing function. */
ADT_free_decl,
+ /* Function declaration node for run-time reallocation function. */
+ ADT_realloc_decl,
+
/* Function decl node for 64-bit multiplication with overflow checking. */
ADT_mulv64_decl,
@@ -471,6 +469,7 @@ extern GTY(()) tree gnat_raise_decls_ext[(int) LAST_REASON_CODE + 1];
#define sbitsize_unit_node gnat_std_decls[(int) ADT_sbitsize_unit_node]
#define malloc_decl gnat_std_decls[(int) ADT_malloc_decl]
#define free_decl gnat_std_decls[(int) ADT_free_decl]
+#define realloc_decl gnat_std_decls[(int) ADT_realloc_decl]
#define mulv64_decl gnat_std_decls[(int) ADT_mulv64_decl]
#define parent_name_id gnat_std_decls[(int) ADT_parent_name_id]
#define exception_data_name_id gnat_std_decls[(int) ADT_exception_data_name_id]
@@ -620,33 +619,18 @@ extern void finish_fat_pointer_type (tree record_type, tree field_list);
laid out already; only set the sizes and alignment. If REP_LEVEL is two,
this record is derived from a parent record and thus inherits its layout;
only make a pass on the fields to finalize them. DEBUG_INFO_P is true if
- we need to write debug information about this type. */
+ additional debug info needs to be output for this type. */
extern void finish_record_type (tree record_type, tree field_list,
int rep_level, bool debug_info_p);
-/* Wrap up compilation of RECORD_TYPE, i.e. output all the debug information
- associated with it. It need not be invoked directly in most cases since
- finish_record_type takes care of doing so, but this can be necessary if
- a parallel type is to be attached to the record type. */
+/* Wrap up compilation of RECORD_TYPE, i.e. output additional debug info
+ associated with it. It need not be invoked directly in most cases as
+ finish_record_type takes care of doing so. */
extern void rest_of_record_type_compilation (tree record_type);
/* Append PARALLEL_TYPE on the chain of parallel types for TYPE. */
extern void add_parallel_type (tree type, tree parallel_type);
-/* Return a FUNCTION_TYPE node. RETURN_TYPE is the type returned by the
- subprogram. If it is VOID_TYPE, then we are dealing with a procedure,
- otherwise we are dealing with a function. PARAM_DECL_LIST is a list of
- PARM_DECL nodes that are the subprogram parameters. CICO_LIST is the
- copy-in/copy-out list to be stored into the TYPE_CICO_LIST field.
- RETURN_UNCONSTRAINED_P is true if the function returns an unconstrained
- object. RETURN_BY_DIRECT_REF_P is true if the function returns by direct
- reference. RETURN_BY_INVISI_REF_P is true if the function returns by
- invisible reference. */
-extern tree create_subprog_type (tree return_type, tree param_decl_list,
- tree cico_list, bool return_unconstrained_p,
- bool return_by_direct_ref_p,
- bool return_by_invisi_ref_p);
-
/* Return a copy of TYPE, but safe to modify in any way. */
extern tree copy_type (tree type);
@@ -719,10 +703,8 @@ extern tree create_field_decl (tree name, tree type, tree record_type,
tree size, tree pos, int packed,
int addressable);
-/* Return a PARM_DECL node. NAME is the name of the parameter and TYPE is
- its type. READONLY is true if the parameter is readonly (either an In
- parameter or an address of a pass-by-ref parameter). */
-extern tree create_param_decl (tree name, tree type, bool readonly);
+/* Return a PARM_DECL node with NAME and TYPE. */
+extern tree create_param_decl (tree name, tree type);
/* Return a LABEL_DECL with NAME. GNAT_NODE is used for the position of
the decl. */
@@ -735,8 +717,10 @@ extern tree create_label_decl (tree name, Node_Id gnat_node);
INLINE_STATUS describes the inline flags to be set on the FUNCTION_DECL.
- CONST_FLAG, PUBLIC_FLAG, EXTERN_FLAG, VOLATILE_FLAG are used to set the
- appropriate flags on the FUNCTION_DECL.
+ PUBLIC_FLAG is true if this is for a reference to a public entity or for a
+ definition to be made visible outside of the current compilation unit.
+
+ EXTERN_FLAG is true when processing an external subprogram declaration.
ARTIFICIAL_P is true if the subprogram was generated by the compiler.
@@ -748,11 +732,14 @@ extern tree create_label_decl (tree name, Node_Id gnat_node);
extern tree create_subprog_decl (tree name, tree asm_name, tree type,
tree param_decl_list,
enum inline_status_t inline_status,
- bool const_flag, bool public_flag,
- bool extern_flag, bool volatile_flag,
+ bool public_flag, bool extern_flag,
bool artificial_p, bool debug_info_p,
struct attrib *attr_list, Node_Id gnat_node);
+/* Given a subprogram declaration DECL, its assembler name and its type,
+ finish constructing the subprogram declaration from ASM_NAME and TYPE. */
+extern void finish_subprog_decl (tree decl, tree asm_name, tree type);
+
/* Process the attributes in ATTR_LIST for NODE, which is either a DECL or
a TYPE. If IN_PLACE is true, the tree pointed to by NODE should not be
changed. GNAT_NODE is used for the position of error messages. */
@@ -869,9 +856,11 @@ extern tree build_load_modify_store (tree dest, tree src, Node_Id gnat_node);
/* Make a binary operation of kind OP_CODE. RESULT_TYPE is the type
desired for the result. Usually the operation is to be performed
in that type. For MODIFY_EXPR and ARRAY_REF, RESULT_TYPE may be 0
- in which case the type to be used will be derived from the operands. */
+ in which case the type to be used will be derived from the operands.
+ Don't fold the result if NO_FOLD is true. */
extern tree build_binary_op (enum tree_code op_code, tree result_type,
- tree left_operand, tree right_operand);
+ tree left_operand, tree right_operand,
+ bool no_fold=false);
/* Similar, but make unary operation. */
extern tree build_unary_op (enum tree_code op_code, tree result_type,
@@ -1025,6 +1014,11 @@ extern void process_deferred_decl_context (bool force);
IS_SUBPROGRAM to whether the returned entity is a subprogram. */
extern Entity_Id get_debug_scope (Node_Id gnat_node, bool *is_subprogram);
+/* Return whether EXPR, which is the renamed object in an object renaming
+ declaration, can be materialized as a reference (REFERENCE_TYPE). This
+ should be synchronized with Exp_Dbug.Debug_Renaming_Declaration. */
+extern bool can_materialize_object_renaming_p (Node_Id expr);
+
#ifdef __cplusplus
extern "C" {
#endif
diff --git a/gcc/ada/gcc-interface/lang.opt b/gcc/ada/gcc-interface/lang.opt
index ccae6fa361..241eafc90a 100644
--- a/gcc/ada/gcc-interface/lang.opt
+++ b/gcc/ada/gcc-interface/lang.opt
@@ -81,15 +81,15 @@ Ada AdaWhy AdaSCIL
Make \"char\" signed by default.
gant
-Ada AdaWhy AdaSCIL Joined Undocumented
+Ada AdaWhy AdaSCIL Driver Joined Undocumented
Catch typos.
gnatO
-Ada AdaWhy AdaSCIL Separate
+Ada AdaWhy AdaSCIL Driver Separate
Set name of output ALI file (internal switch).
gnat
-Ada AdaWhy AdaSCIL Joined
+Ada AdaWhy AdaSCIL Driver Joined
-gnat<options> Specify options to GNAT.
fbuiltin-printf
diff --git a/gcc/ada/gcc-interface/misc.c b/gcc/ada/gcc-interface/misc.c
index 521f8b9907..1b6b3eb265 100644
--- a/gcc/ada/gcc-interface/misc.c
+++ b/gcc/ada/gcc-interface/misc.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2016, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2017, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -149,7 +149,7 @@ gnat_handle_option (size_t scode, const char *arg, int value, int kind,
handle_generated_option (&global_options, &global_options_set,
OPT_Wunused, NULL, value,
gnat_option_lang_mask (), kind, loc,
- handlers, global_dc);
+ handlers, true, global_dc);
warn_uninitialized = value;
warn_maybe_uninitialized = value;
break;
@@ -255,8 +255,7 @@ static bool
gnat_post_options (const char **pfilename ATTRIBUTE_UNUSED)
{
/* Excess precision other than "fast" requires front-end support. */
- if (flag_excess_precision_cmdline == EXCESS_PRECISION_STANDARD
- && TARGET_FLT_EVAL_METHOD_NON_DEFAULT)
+ if (flag_excess_precision_cmdline == EXCESS_PRECISION_STANDARD)
sorry ("-fexcess-precision=standard for Ada");
flag_excess_precision_cmdline = EXCESS_PRECISION_FAST;
@@ -718,7 +717,9 @@ gnat_get_alias_set (tree type)
get_alias_set (TREE_TYPE (TREE_TYPE (TYPE_FIELDS (TREE_TYPE (type)))));
/* If the type can alias any other types, return the alias set 0. */
- else if (TYPE_P (type) && TYPE_UNIVERSAL_ALIASING_P (type))
+ else if (TYPE_P (type)
+ && !TYPE_IS_DUMMY_P (type)
+ && TYPE_UNIVERSAL_ALIASING_P (type))
return 0;
return -1;
@@ -735,22 +736,59 @@ gnat_type_max_size (const_tree gnu_type)
elaborated and possibly replaced by a VAR_DECL. */
tree max_unitsize = max_size (TYPE_SIZE_UNIT (gnu_type), true);
- /* If we don't have a constant, see what we can get from TYPE_ADA_SIZE,
- which should stay untouched. */
- if (!tree_fits_uhwi_p (max_unitsize)
- && RECORD_OR_UNION_TYPE_P (gnu_type)
- && !TYPE_FAT_POINTER_P (gnu_type)
- && TYPE_ADA_SIZE (gnu_type))
+ /* If we don't have a constant, try to look at attributes which should have
+ stayed untouched. */
+ if (!tree_fits_uhwi_p (max_unitsize))
{
- tree max_adasize = max_size (TYPE_ADA_SIZE (gnu_type), true);
-
- /* If we have succeeded in finding a constant, round it up to the
- type's alignment and return the result in units. */
- if (tree_fits_uhwi_p (max_adasize))
- max_unitsize
- = size_binop (CEIL_DIV_EXPR,
- round_up (max_adasize, TYPE_ALIGN (gnu_type)),
- bitsize_unit_node);
+ /* For record types, see what we can get from TYPE_ADA_SIZE. */
+ if (RECORD_OR_UNION_TYPE_P (gnu_type)
+ && !TYPE_FAT_POINTER_P (gnu_type)
+ && TYPE_ADA_SIZE (gnu_type))
+ {
+ tree max_adasize = max_size (TYPE_ADA_SIZE (gnu_type), true);
+
+ /* If we have succeeded in finding a constant, round it up to the
+ type's alignment and return the result in units. */
+ if (tree_fits_uhwi_p (max_adasize))
+ max_unitsize
+ = size_binop (CEIL_DIV_EXPR,
+ round_up (max_adasize, TYPE_ALIGN (gnu_type)),
+ bitsize_unit_node);
+ }
+
+ /* For array types, see what we can get from TYPE_INDEX_TYPE. */
+ else if (TREE_CODE (gnu_type) == ARRAY_TYPE
+ && TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type))
+ && tree_fits_uhwi_p (TYPE_SIZE_UNIT (TREE_TYPE (gnu_type))))
+ {
+ tree lb = TYPE_MIN_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
+ tree hb = TYPE_MAX_VALUE (TYPE_INDEX_TYPE (TYPE_DOMAIN (gnu_type)));
+ if (TREE_CODE (lb) != INTEGER_CST
+ && TYPE_RM_SIZE (TREE_TYPE (lb))
+ && compare_tree_int (TYPE_RM_SIZE (TREE_TYPE (lb)), 16) <= 0)
+ lb = TYPE_MIN_VALUE (TREE_TYPE (lb));
+ if (TREE_CODE (hb) != INTEGER_CST
+ && TYPE_RM_SIZE (TREE_TYPE (hb))
+ && compare_tree_int (TYPE_RM_SIZE (TREE_TYPE (hb)), 16) <= 0)
+ hb = TYPE_MAX_VALUE (TREE_TYPE (hb));
+ if (TREE_CODE (lb) == INTEGER_CST && TREE_CODE (hb) == INTEGER_CST)
+ {
+ tree ctype = get_base_type (TREE_TYPE (lb));
+ lb = fold_convert (ctype, lb);
+ hb = fold_convert (ctype, hb);
+ if (tree_int_cst_le (lb, hb))
+ {
+ tree length
+ = fold_build2 (PLUS_EXPR, ctype,
+ fold_build2 (MINUS_EXPR, ctype, hb, lb),
+ build_int_cst (ctype, 1));
+ max_unitsize
+ = fold_build2 (MULT_EXPR, sizetype,
+ fold_convert (sizetype, length),
+ TYPE_SIZE_UNIT (TREE_TYPE (gnu_type)));
+ }
+ }
+ }
}
return max_unitsize;
@@ -897,6 +935,7 @@ gnat_get_array_descr_info (const_tree const_type,
}
info->ndimensions = i;
+ info->rank = NULL_TREE;
/* Too many dimensions? Give up generating proper description: yield instead
nested arrays. Note that in this case, this hook is invoked once on each
@@ -932,7 +971,7 @@ gnat_get_array_descr_info (const_tree const_type,
and XUA types. */
if (TYPE_CONTEXT (first_dimen)
&& TREE_CODE (TYPE_CONTEXT (first_dimen)) != RECORD_TYPE
- && contains_placeholder_p (TYPE_MIN_VALUE (index_type))
+ && CONTAINS_PLACEHOLDER_P (TYPE_MIN_VALUE (index_type))
&& gnat_encodings != DWARF_GNAT_ENCODINGS_MINIMAL)
{
info->dimen[i].lower_bound = NULL_TREE;
@@ -1365,9 +1404,11 @@ get_lang_specific (tree node)
#undef LANG_HOOKS_TYPE_HASH_EQ
#define LANG_HOOKS_TYPE_HASH_EQ gnat_type_hash_eq
#undef LANG_HOOKS_GETDECLS
-#define LANG_HOOKS_GETDECLS lhd_return_null_tree_v
+#define LANG_HOOKS_GETDECLS hook_tree_void_null
#undef LANG_HOOKS_PUSHDECL
#define LANG_HOOKS_PUSHDECL gnat_return_tree
+#undef LANG_HOOKS_WARN_UNUSED_GLOBAL_DECL
+#define LANG_HOOKS_WARN_UNUSED_GLOBAL_DECL hook_bool_const_tree_false
#undef LANG_HOOKS_GET_ALIAS_SET
#define LANG_HOOKS_GET_ALIAS_SET gnat_get_alias_set
#undef LANG_HOOKS_PRINT_DECL
@@ -1401,20 +1442,19 @@ get_lang_specific (tree node)
#undef LANG_HOOKS_GET_DEBUG_TYPE
#define LANG_HOOKS_GET_DEBUG_TYPE gnat_get_debug_type
#undef LANG_HOOKS_GET_FIXED_POINT_TYPE_INFO
-#define LANG_HOOKS_GET_FIXED_POINT_TYPE_INFO \
- gnat_get_fixed_point_type_info
+#define LANG_HOOKS_GET_FIXED_POINT_TYPE_INFO gnat_get_fixed_point_type_info
#undef LANG_HOOKS_ATTRIBUTE_TABLE
#define LANG_HOOKS_ATTRIBUTE_TABLE gnat_internal_attribute_table
#undef LANG_HOOKS_BUILTIN_FUNCTION
#define LANG_HOOKS_BUILTIN_FUNCTION gnat_builtin_function
+#undef LANG_HOOKS_INIT_TS
+#define LANG_HOOKS_INIT_TS gnat_init_ts
#undef LANG_HOOKS_EH_PERSONALITY
#define LANG_HOOKS_EH_PERSONALITY gnat_eh_personality
#undef LANG_HOOKS_DEEP_UNSHARING
#define LANG_HOOKS_DEEP_UNSHARING true
-#undef LANG_HOOKS_INIT_TS
-#define LANG_HOOKS_INIT_TS gnat_init_ts
-#undef LANG_HOOKS_WARN_UNUSED_GLOBAL_DECL
-#define LANG_HOOKS_WARN_UNUSED_GLOBAL_DECL hook_bool_const_tree_false
+#undef LANG_HOOKS_CUSTOM_FUNCTION_DESCRIPTORS
+#define LANG_HOOKS_CUSTOM_FUNCTION_DESCRIPTORS true
struct lang_hooks lang_hooks = LANG_HOOKS_INITIALIZER;
diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c
index cf64d229a5..0a7ddfcfdb 100644
--- a/gcc/ada/gcc-interface/trans.c
+++ b/gcc/ada/gcc-interface/trans.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2016, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2017, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -387,29 +387,34 @@ gigi (Node_Id gnat_root,
true, false, NULL, gnat_literal);
save_gnu_tree (gnat_literal, t, false);
+ /* Declare the building blocks of function nodes. */
+ void_list_node = build_tree_list (NULL_TREE, void_type_node);
void_ftype = build_function_type_list (void_type_node, NULL_TREE);
ptr_void_ftype = build_pointer_type (void_ftype);
/* Now declare run-time functions. */
ftype = build_function_type_list (ptr_type_node, sizetype, NULL_TREE);
-
- /* malloc is a function declaration tree for a function to allocate
- memory. */
malloc_decl
= create_subprog_decl (get_identifier ("__gnat_malloc"), NULL_TREE,
ftype,
- NULL_TREE, is_disabled, false, true, true, false,
- true, false, NULL, Empty);
+ NULL_TREE, is_disabled, true, true, true, false,
+ NULL, Empty);
DECL_IS_MALLOC (malloc_decl) = 1;
- /* free is a function declaration tree for a function to free memory. */
+ ftype = build_function_type_list (void_type_node, ptr_type_node, NULL_TREE);
free_decl
= create_subprog_decl (get_identifier ("__gnat_free"), NULL_TREE,
- build_function_type_list (void_type_node,
- ptr_type_node,
- NULL_TREE),
- NULL_TREE, is_disabled, false, true, true, false,
- true, false, NULL, Empty);
+ ftype,
+ NULL_TREE, is_disabled, true, true, true, false,
+ NULL, Empty);
+
+ ftype = build_function_type_list (ptr_type_node, ptr_type_node, sizetype,
+ NULL_TREE);
+ realloc_decl
+ = create_subprog_decl (get_identifier ("__gnat_realloc"), NULL_TREE,
+ ftype,
+ NULL_TREE, is_disabled, true, true, true, false,
+ NULL, Empty);
/* This is used for 64-bit multiplication with overflow checking. */
int64_type = gnat_type_for_size (64, 0);
@@ -417,8 +422,8 @@ gigi (Node_Id gnat_root,
= create_subprog_decl (get_identifier ("__gnat_mulv64"), NULL_TREE,
build_function_type_list (int64_type, int64_type,
int64_type, NULL_TREE),
- NULL_TREE, is_disabled, false, true, true, false,
- true, false, NULL, Empty);
+ NULL_TREE, is_disabled, true, true, true, false,
+ NULL, Empty);
/* Name of the _Parent field in tagged record types. */
parent_name_id = get_identifier (Get_Name_String (Name_uParent));
@@ -441,24 +446,21 @@ gigi (Node_Id gnat_root,
= create_subprog_decl
(get_identifier ("system__soft_links__get_jmpbuf_address_soft"),
NULL_TREE, build_function_type_list (jmpbuf_ptr_type, NULL_TREE),
- NULL_TREE, is_disabled, false, true, true, false, true, false,
- NULL, Empty);
+ NULL_TREE, is_disabled, true, true, true, false, NULL, Empty);
set_jmpbuf_decl
= create_subprog_decl
(get_identifier ("system__soft_links__set_jmpbuf_address_soft"),
NULL_TREE, build_function_type_list (void_type_node, jmpbuf_ptr_type,
NULL_TREE),
- NULL_TREE, is_disabled, false, true, true, false, true, false,
- NULL, Empty);
+ NULL_TREE, is_disabled, true, true, true, false, NULL, Empty);
get_excptr_decl
= create_subprog_decl
(get_identifier ("system__soft_links__get_gnat_exception"), NULL_TREE,
build_function_type_list (build_pointer_type (except_type_node),
NULL_TREE),
- NULL_TREE, is_disabled, false, true, true, false, true, false,
- NULL, Empty);
+ NULL_TREE, is_disabled, true, true, true, false, NULL, Empty);
not_handled_by_others_decl = get_identifier ("not_handled_by_others");
for (t = TYPE_FIELDS (except_type_node); t; t = DECL_CHAIN (t))
@@ -476,8 +478,7 @@ gigi (Node_Id gnat_root,
(get_identifier ("__builtin_setjmp"), NULL_TREE,
build_function_type_list (integer_type_node, jmpbuf_ptr_type,
NULL_TREE),
- NULL_TREE, is_disabled, false, true, true, false, true, false,
- NULL, Empty);
+ NULL_TREE, is_disabled, true, true, true, false, NULL, Empty);
DECL_BUILT_IN_CLASS (setjmp_decl) = BUILT_IN_NORMAL;
DECL_FUNCTION_CODE (setjmp_decl) = BUILT_IN_SETJMP;
@@ -487,35 +488,26 @@ gigi (Node_Id gnat_root,
= create_subprog_decl
(get_identifier ("__builtin_update_setjmp_buf"), NULL_TREE,
build_function_type_list (void_type_node, jmpbuf_ptr_type, NULL_TREE),
- NULL_TREE, is_disabled, false, true, true, false, true, false,
- NULL, Empty);
+ NULL_TREE, is_disabled, true, true, true, false, NULL, Empty);
DECL_BUILT_IN_CLASS (update_setjmp_buf_decl) = BUILT_IN_NORMAL;
DECL_FUNCTION_CODE (update_setjmp_buf_decl) = BUILT_IN_UPDATE_SETJMP_BUF;
/* Indicate that it never returns. */
+ ftype = build_function_type_list (void_type_node,
+ build_pointer_type (except_type_node),
+ NULL_TREE);
+ ftype = build_qualified_type (ftype, TYPE_QUAL_VOLATILE);
raise_nodefer_decl
= create_subprog_decl
- (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE,
- build_function_type_list (void_type_node,
- build_pointer_type (except_type_node),
- NULL_TREE),
- NULL_TREE, is_disabled, false, true, true, true, true, false,
- NULL, Empty);
-
- /* Indicate that these never return. */
- reraise_zcx_decl
- = create_subprog_decl (get_identifier ("__gnat_reraise_zcx"), NULL_TREE,
- ftype, NULL_TREE,
- is_disabled, false, true, true, true, true, false,
- NULL, Empty);
+ (get_identifier ("__gnat_raise_nodefer_with_msg"), NULL_TREE, ftype,
+ NULL_TREE, is_disabled, true, true, true, false, NULL, Empty);
set_exception_parameter_decl
= create_subprog_decl
(get_identifier ("__gnat_set_exception_parameter"), NULL_TREE,
build_function_type_list (void_type_node, ptr_type_node, ptr_type_node,
NULL_TREE),
- NULL_TREE, is_disabled, false, true, true, false, true, false,
- NULL, Empty);
+ NULL_TREE, is_disabled, true, true, true, false, NULL, Empty);
/* Hooks to call when entering/leaving an exception handler. */
ftype = build_function_type_list (void_type_node, ptr_type_node, NULL_TREE);
@@ -523,20 +515,24 @@ gigi (Node_Id gnat_root,
begin_handler_decl
= create_subprog_decl (get_identifier ("__gnat_begin_handler"), NULL_TREE,
ftype, NULL_TREE,
- is_disabled, false, true, true, false, true, false,
- NULL, Empty);
+ is_disabled, true, true, true, false, NULL, Empty);
end_handler_decl
= create_subprog_decl (get_identifier ("__gnat_end_handler"), NULL_TREE,
ftype, NULL_TREE,
- is_disabled, false, true, true, false, true, false,
- NULL, Empty);
+ is_disabled, true, true, true, false, NULL, Empty);
unhandled_except_decl
= create_subprog_decl (get_identifier ("__gnat_unhandled_except_handler"),
NULL_TREE, ftype, NULL_TREE,
- is_disabled, false, true, true, false, true, false,
- NULL, Empty);
+ is_disabled, true, true, true, false, NULL, Empty);
+
+ /* Indicate that it never returns. */
+ ftype = build_qualified_type (ftype, TYPE_QUAL_VOLATILE);
+ reraise_zcx_decl
+ = create_subprog_decl (get_identifier ("__gnat_reraise_zcx"), NULL_TREE,
+ ftype, NULL_TREE,
+ is_disabled, true, true, true, false, NULL, Empty);
/* Dummy objects to materialize "others" and "all others" in the exception
tables. These are exported by a-exexpr-gcc.adb, so see this unit for
@@ -567,14 +563,15 @@ gigi (Node_Id gnat_root,
this procedure will never be called in this mode. */
if (No_Exception_Handlers_Set ())
{
+ /* Indicate that it never returns. */
+ ftype = build_function_type_list (void_type_node,
+ build_pointer_type (char_type_node),
+ integer_type_node, NULL_TREE);
+ ftype = build_qualified_type (ftype, TYPE_QUAL_VOLATILE);
tree decl
= create_subprog_decl
- (get_identifier ("__gnat_last_chance_handler"), NULL_TREE,
- build_function_type_list (void_type_node,
- build_pointer_type (char_type_node),
- integer_type_node, NULL_TREE),
- NULL_TREE, is_disabled, false, true, true, true, true, false,
- NULL, Empty);
+ (get_identifier ("__gnat_last_chance_handler"), NULL_TREE, ftype,
+ NULL_TREE, is_disabled, true, true, true, false, NULL, Empty);
for (i = 0; i < (int) ARRAY_SIZE (gnat_raise_decls); i++)
gnat_raise_decls[i] = decl;
}
@@ -736,10 +733,10 @@ build_raise_check (int check, enum exception_info_kind kind)
}
/* Indicate that it never returns. */
+ ftype = build_qualified_type (ftype, TYPE_QUAL_VOLATILE);
result
- = create_subprog_decl (get_identifier (Name_Buffer), NULL_TREE,
- ftype, NULL_TREE,
- is_disabled, false, true, true, true, true, false,
+ = create_subprog_decl (get_identifier (Name_Buffer), NULL_TREE, ftype,
+ NULL_TREE, is_disabled, true, true, true, false,
NULL, Empty);
return result;
@@ -963,14 +960,21 @@ fold_constant_decl_in_expr (tree exp)
return DECL_INITIAL (exp);
- case BIT_FIELD_REF:
case COMPONENT_REF:
op0 = fold_constant_decl_in_expr (TREE_OPERAND (exp, 0));
if (op0 == TREE_OPERAND (exp, 0))
return exp;
- return fold_build3 (code, TREE_TYPE (exp), op0, TREE_OPERAND (exp, 1),
- TREE_OPERAND (exp, 2));
+ return fold_build3 (COMPONENT_REF, TREE_TYPE (exp), op0,
+ TREE_OPERAND (exp, 1), NULL_TREE);
+
+ case BIT_FIELD_REF:
+ op0 = fold_constant_decl_in_expr (TREE_OPERAND (exp, 0));
+ if (op0 == TREE_OPERAND (exp, 0))
+ return exp;
+
+ return fold_build3 (BIT_FIELD_REF, TREE_TYPE (exp), op0,
+ TREE_OPERAND (exp, 1), TREE_OPERAND (exp, 2));
case ARRAY_REF:
case ARRAY_RANGE_REF:
@@ -982,7 +986,7 @@ fold_constant_decl_in_expr (tree exp)
return exp;
return fold (build4 (code, TREE_TYPE (exp), op0, TREE_OPERAND (exp, 1),
- TREE_OPERAND (exp, 2), TREE_OPERAND (exp, 3)));
+ TREE_OPERAND (exp, 2), NULL_TREE));
case REALPART_EXPR:
case IMAGPART_EXPR:
@@ -1020,15 +1024,15 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
address clause when the parent doesn't require an lvalue. */
bool use_constant_initializer = false;
- /* If the Etype of this node does not equal the Etype of the Entity,
- something is wrong with the entity map, probably in generic
- instantiation. However, this does not apply to types. Since we sometime
- have strange Ekind's, just do this test for objects. Also, if the Etype of
- the Entity is private, the Etype of the N_Identifier is allowed to be the
- full type and also we consider a packed array type to be the same as the
- original type. Similarly, a class-wide type is equivalent to a subtype of
- itself. Finally, if the types are Itypes, one may be a copy of the other,
- which is also legal. */
+ /* If the Etype of this node is not the same as that of the Entity, then
+ something went wrong, probably in generic instantiation. However, this
+ does not apply to types. Since we sometime have strange Ekind's, just
+ do this test for objects. Moreover, if the Etype of the Entity is private
+ or incomplete coming from a limited context, the Etype of the N_Identifier
+ is allowed to be the full/non-limited view and we also consider a packed
+ array type to be the same as the original type. Similarly, a CW type is
+ equivalent to a subtype of itself. Finally, if the types are Itypes, one
+ may be a copy of the other, which is also legal. */
gnat_temp = ((Nkind (gnat_node) == N_Defining_Identifier
|| Nkind (gnat_node) == N_Defining_Operator_Symbol)
? gnat_node : Entity (gnat_node));
@@ -1046,6 +1050,10 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
&& (Etype (gnat_node)
== Packed_Array_Impl_Type
(Full_View (gnat_temp_type))))))
+ || (IN (Ekind (gnat_temp_type), Incomplete_Kind)
+ && From_Limited_With (gnat_temp_type)
+ && Present (Non_Limited_View (gnat_temp_type))
+ && Etype (gnat_node) == Non_Limited_View (gnat_temp_type))
|| (Is_Itype (Etype (gnat_node)) && Is_Itype (gnat_temp_type))
|| !(Ekind (gnat_temp) == E_Variable
|| Ekind (gnat_temp) == E_Component
@@ -1120,7 +1128,7 @@ Identifier_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
gnu_result = gnat_to_gnu (Expression (Declaration_Node (gnat_temp)));
}
else
- gnu_result = gnat_to_gnu_entity (gnat_temp, NULL_TREE, 0);
+ gnu_result = gnat_to_gnu_entity (gnat_temp, NULL_TREE, false);
/* Some objects (such as parameters passed by reference, globals of
variable size, and renamed objects) actually represent the address
@@ -1569,25 +1577,11 @@ static tree
Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
{
const Node_Id gnat_prefix = Prefix (gnat_node);
- tree gnu_prefix, gnu_type, gnu_expr;
- tree gnu_result_type, gnu_result = error_mark_node;
+ tree gnu_prefix = gnat_to_gnu (gnat_prefix);
+ tree gnu_type = TREE_TYPE (gnu_prefix);
+ tree gnu_expr, gnu_result_type, gnu_result = error_mark_node;
bool prefix_unused = false;
- /* ??? If this is an access attribute for a public subprogram to be used in
- a dispatch table, do not translate its type as it's useless in this case
- and the parameter types might be incomplete types coming from a limited
- context in Ada 2012 (AI05-0151). */
- if (Ekind (Etype (gnat_node)) == E_Access_Subprogram_Type
- && Is_Dispatch_Table_Entity (Etype (gnat_node))
- && Nkind (gnat_prefix) == N_Identifier
- && Is_Subprogram (Entity (gnat_prefix))
- && Is_Public (Entity (gnat_prefix))
- && !present_gnu_tree (Entity (gnat_prefix)))
- gnu_prefix = get_minimal_subprog_decl (Entity (gnat_prefix));
- else
- gnu_prefix = gnat_to_gnu (gnat_prefix);
- gnu_type = TREE_TYPE (gnu_prefix);
-
/* If the input is a NULL_EXPR, make a new one. */
if (TREE_CODE (gnu_prefix) == NULL_EXPR)
{
@@ -1708,6 +1702,17 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
if (TREE_CODE (gnu_expr) == ADDR_EXPR)
TREE_NO_TRAMPOLINE (gnu_expr) = TREE_CONSTANT (gnu_expr) = 1;
+
+ /* On targets for which function symbols denote a descriptor, the
+ code address is stored within the first slot of the descriptor
+ so we do an additional dereference:
+ result = *((result_type *) result)
+ where we expect result to be of some pointer type already. */
+ if (targetm.calls.custom_function_descriptors == 0)
+ gnu_result
+ = build_unary_op (INDIRECT_REF, NULL_TREE,
+ convert (build_pointer_type (gnu_result_type),
+ gnu_result));
}
/* For 'Access, issue an error message if the prefix is a C++ method
@@ -1734,10 +1739,19 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
/* Also check the inlining status. */
check_inlining_for_nested_subprog (TREE_OPERAND (gnu_expr, 0));
- /* Check that we're not violating the No_Implicit_Dynamic_Code
- restriction. Be conservative if we don't know anything
- about the trampoline strategy for the target. */
- Check_Implicit_Dynamic_Code_Allowed (gnat_node);
+ /* Moreover, for 'Access or 'Unrestricted_Access with non-
+ foreign-compatible representation, mark the ADDR_EXPR so
+ that we can build a descriptor instead of a trampoline. */
+ if ((attribute == Attr_Access
+ || attribute == Attr_Unrestricted_Access)
+ && targetm.calls.custom_function_descriptors > 0
+ && Can_Use_Internal_Rep (Etype (gnat_node)))
+ FUNC_ADDR_BY_DESCRIPTOR (gnu_expr) = 1;
+
+ /* Otherwise, we need to check that we are not violating the
+ No_Implicit_Dynamic_Code restriction. */
+ else if (targetm.calls.custom_function_descriptors != 0)
+ Check_Implicit_Dynamic_Code_Allowed (gnat_node);
}
}
break;
@@ -2187,7 +2201,7 @@ Attribute_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, int attribute)
&& TREE_CODE (gnu_prefix) == FIELD_DECL));
get_inner_reference (gnu_prefix, &bitsize, &bitpos, &gnu_offset,
- &mode, &unsignedp, &reversep, &volatilep, false);
+ &mode, &unsignedp, &reversep, &volatilep);
if (TREE_CODE (gnu_prefix) == COMPONENT_REF)
{
@@ -3034,7 +3048,7 @@ Loop_Statement_to_gnu (Node_Id gnat_node)
gnu_loop_iv = NULL_TREE;
/* Declare the iteration variable and set it to its initial value. */
- gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, 1);
+ gnu_loop_var = gnat_to_gnu_entity (gnat_loop_var, gnu_first, true);
if (DECL_BY_REF_P (gnu_loop_var))
gnu_loop_var = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_loop_var);
else if (use_iv)
@@ -3600,9 +3614,16 @@ return_value_ok_for_nrv_p (tree ret_obj, tree ret_val)
if (TREE_ADDRESSABLE (ret_val))
return false;
+ /* For the constrained case, test for overalignment. */
if (ret_obj && DECL_ALIGN (ret_val) > DECL_ALIGN (ret_obj))
return false;
+ /* For the unconstrained case, test for bogus initialization. */
+ if (!ret_obj
+ && DECL_INITIAL (ret_val)
+ && TREE_CODE (DECL_INITIAL (ret_val)) == NULL_EXPR)
+ return false;
+
return true;
}
@@ -3799,7 +3820,7 @@ Subprogram_Body_to_gnu (Node_Id gnat_node)
gnu_cico_entry = TREE_CHAIN (gnu_cico_entry);
/* Do any needed dereferences for by-ref objects. */
- gnu_decl = gnat_to_gnu_entity (gnat_param, NULL_TREE, 1);
+ gnu_decl = gnat_to_gnu_entity (gnat_param, NULL_TREE, true);
gcc_assert (DECL_P (gnu_decl));
if (DECL_BY_REF_P (gnu_decl))
gnu_decl = build_unary_op (INDIRECT_REF, NULL_TREE, gnu_decl);
@@ -4234,6 +4255,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
tree gnu_after_list = NULL_TREE;
tree gnu_retval = NULL_TREE;
tree gnu_call, gnu_result;
+ bool by_descriptor = false;
bool went_into_elab_proc = false;
bool pushed_binding_level = false;
Entity_Id gnat_formal;
@@ -4273,7 +4295,15 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
type the access type is pointing to. Otherwise, get the formals from the
entity being called. */
if (Nkind (Name (gnat_node)) == N_Explicit_Dereference)
- gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
+ {
+ gnat_formal = First_Formal_With_Extras (Etype (Name (gnat_node)));
+
+ /* If the access type doesn't require foreign-compatible representation,
+ be prepared for descriptors. */
+ if (targetm.calls.custom_function_descriptors > 0
+ && Can_Use_Internal_Rep (Etype (Prefix (Name (gnat_node)))))
+ by_descriptor = true;
+ }
else if (Nkind (Name (gnat_node)) == N_Attribute_Reference)
/* Assume here that this must be 'Elab_Body or 'Elab_Spec. */
gnat_formal = Empty;
@@ -4352,9 +4382,9 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
gnat_actual = Next_Actual (gnat_actual))
{
Entity_Id gnat_formal_type = Etype (gnat_formal);
+ tree gnu_formal_type = gnat_to_gnu_type (gnat_formal_type);
tree gnu_formal = present_gnu_tree (gnat_formal)
? get_gnu_tree (gnat_formal) : NULL_TREE;
- tree gnu_formal_type = gnat_to_gnu_type (gnat_formal_type);
const bool is_true_formal_parm
= gnu_formal && TREE_CODE (gnu_formal) == PARM_DECL;
const bool is_by_ref_formal_parm
@@ -4380,7 +4410,6 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
Node_Id gnat_name = suppress_type_conversion
? Expression (gnat_actual) : gnat_actual;
tree gnu_name = gnat_to_gnu (gnat_name), gnu_name_type;
- tree gnu_actual;
/* If it's possible we may need to use this expression twice, make sure
that any side-effects are handled via SAVE_EXPRs; likewise if we need
@@ -4510,7 +4539,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
}
/* Start from the real object and build the actual. */
- gnu_actual = gnu_name;
+ tree gnu_actual = gnu_name;
/* If atomic access is required for an In or In Out actual parameter,
build the atomic load. */
@@ -4530,15 +4559,18 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
/* Put back the conversion we suppressed above in the computation of the
real object. And even if we didn't suppress any conversion there, we
may have suppressed a conversion to the Etype of the actual earlier,
- since the parent is a procedure call, so put it back here. */
- if (suppress_type_conversion
- && Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
- gnu_actual
- = unchecked_convert (gnat_to_gnu_type (Etype (gnat_actual)),
- gnu_actual, No_Truncation (gnat_actual));
+ since the parent is a procedure call, so put it back here. Note that
+ we might have a dummy type here if the actual is the dereference of a
+ pointer to it, but that's OK if the formal is passed by reference. */
+ tree gnu_actual_type = gnat_to_gnu_type (Etype (gnat_actual));
+ if (TYPE_IS_DUMMY_P (gnu_actual_type))
+ gcc_assert (is_true_formal_parm && DECL_BY_REF_P (gnu_formal));
+ else if (suppress_type_conversion
+ && Nkind (gnat_actual) == N_Unchecked_Type_Conversion)
+ gnu_actual = unchecked_convert (gnu_actual_type, gnu_actual,
+ No_Truncation (gnat_actual));
else
- gnu_actual
- = convert (gnat_to_gnu_type (Etype (gnat_actual)), gnu_actual);
+ gnu_actual = convert (gnu_actual_type, gnu_actual);
/* Make sure that the actual is in range of the formal's type. */
if (Ekind (gnat_formal) != E_Out_Parameter
@@ -4674,6 +4706,7 @@ Call_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p, tree gnu_target,
gnu_call
= build_call_vec (gnu_result_type, gnu_subprog_addr, gnu_actual_vec);
+ CALL_EXPR_BY_DESCRIPTOR (gnu_call) = by_descriptor;
set_expr_location_from_node (gnu_call, gnat_node);
/* If we have created a temporary for the return value, initialize it. */
@@ -4939,10 +4972,6 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
tree gnu_result;
tree gnu_expr;
Node_Id gnat_temp;
- /* Node providing the sloc for the cleanup actions. */
- Node_Id gnat_cleanup_loc_node = (Present (End_Label (gnat_node)) ?
- End_Label (gnat_node) :
- gnat_node);
/* The GCC exception handling mechanism can handle both ZCX and SJLJ schemes
and we have our own SJLJ mechanism. To call the GCC mechanism, we call
@@ -4992,7 +5021,8 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
/* When we exit this block, restore the saved value. */
add_cleanup (build_call_n_expr (set_jmpbuf_decl, 1, gnu_jmpsave_decl),
- gnat_cleanup_loc_node);
+ Present (End_Label (gnat_node))
+ ? End_Label (gnat_node) : gnat_node);
}
/* If we are to call a function when exiting this block, add a cleanup
@@ -5001,11 +5031,18 @@ Handled_Sequence_Of_Statements_to_gnu (Node_Id gnat_node)
if (at_end)
{
tree proc_decl = gnat_to_gnu (At_End_Proc (gnat_node));
+
/* When not optimizing, disable inlining of finalizers as this can
create a more complex CFG in the parent function. */
if (!optimize)
DECL_DECLARED_INLINE_P (proc_decl) = 0;
- add_cleanup (build_call_n_expr (proc_decl, 0), gnat_cleanup_loc_node);
+
+ /* If there is no end label attached, we use the location of the At_End
+ procedure because Expand_Cleanup_Actions might reset the location of
+ the enclosing construct to that of an inner statement. */
+ add_cleanup (build_call_n_expr (proc_decl, 0),
+ Present (End_Label (gnat_node))
+ ? End_Label (gnat_node) : At_End_Proc (gnat_node));
}
/* Now build the tree for the declarations and statements inside this block.
@@ -5200,7 +5237,7 @@ Exception_Handler_to_gnu_fe_sjlj (Node_Id gnat_node)
if (Present (Renamed_Object (gnat_ex_id)))
gnat_ex_id = Renamed_Object (gnat_ex_id);
- gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
+ gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, false);
this_choice
= build_binary_op
@@ -5255,7 +5292,7 @@ Exception_Handler_to_gnu_gcc (Node_Id gnat_node)
if (Present (Renamed_Object (gnat_ex_id)))
gnat_ex_id = Renamed_Object (gnat_ex_id);
- gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, 0);
+ gnu_expr = gnat_to_gnu_entity (gnat_ex_id, NULL_TREE, false);
gnu_etype = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_expr);
}
else
@@ -5310,7 +5347,7 @@ Exception_Handler_to_gnu_gcc (Node_Id gnat_node)
if (Present (Choice_Parameter (gnat_node)))
{
tree gnu_param
- = gnat_to_gnu_entity (Choice_Parameter (gnat_node), NULL_TREE, 1);
+ = gnat_to_gnu_entity (Choice_Parameter (gnat_node), NULL_TREE, true);
add_stmt (build_call_n_expr
(set_exception_parameter_decl, 2,
@@ -5347,8 +5384,7 @@ Compilation_Unit_to_gnu (Node_Id gnat_node)
= create_subprog_decl
(create_concat_name (gnat_unit_entity, body_p ? "elabb" : "elabs"),
NULL_TREE, void_ftype, NULL_TREE,
- is_disabled, false, true, false, false, true, true,
- NULL, gnat_unit);
+ is_disabled, true, false, true, true, NULL, gnat_unit);
struct elab_info *info;
vec_safe_push (gnu_elab_proc_stack, gnu_elab_proc_decl);
@@ -5413,7 +5449,7 @@ Compilation_Unit_to_gnu (Node_Id gnat_node)
}
/* Define the entity first so we set DECL_EXTERNAL. */
- gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
+ gnat_to_gnu_entity (gnat_entity, NULL_TREE, false);
add_stmt (gnat_to_gnu (gnat_body));
}
@@ -5465,6 +5501,38 @@ build_noreturn_cond (tree cond)
return build1 (NOP_EXPR, boolean_type_node, t);
}
+/* Subroutine of gnat_to_gnu to translate GNAT_RANGE, a node representing a
+ range of values, into GNU_LOW and GNU_HIGH bounds. */
+
+static void
+Range_to_gnu (Node_Id gnat_range, tree *gnu_low, tree *gnu_high)
+{
+ /* GNAT_RANGE is either an N_Range or an identifier denoting a subtype. */
+ switch (Nkind (gnat_range))
+ {
+ case N_Range:
+ *gnu_low = gnat_to_gnu (Low_Bound (gnat_range));
+ *gnu_high = gnat_to_gnu (High_Bound (gnat_range));
+ break;
+
+ case N_Expanded_Name:
+ case N_Identifier:
+ {
+ tree gnu_range_type = get_unpadded_type (Entity (gnat_range));
+ tree gnu_range_base_type = get_base_type (gnu_range_type);
+
+ *gnu_low
+ = convert (gnu_range_base_type, TYPE_MIN_VALUE (gnu_range_type));
+ *gnu_high
+ = convert (gnu_range_base_type, TYPE_MAX_VALUE (gnu_range_type));
+ }
+ break;
+
+ default:
+ gcc_unreachable ();
+ }
+}
+
/* Subroutine of gnat_to_gnu to translate GNAT_NODE, an N_Raise_xxx_Error,
to a GCC tree and return it. GNU_RESULT_TYPE_P is a pointer to where
we should place the result type. */
@@ -5495,7 +5563,7 @@ Raise_Error_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
case CE_Invalid_Data:
if (Present (gnat_cond) && Nkind (gnat_cond) == N_Op_Not)
{
- Node_Id gnat_range, gnat_index, gnat_type;
+ Node_Id gnat_index, gnat_type;
tree gnu_type, gnu_index, gnu_low_bound, gnu_high_bound, disp;
bool neg_p;
struct loop_info_d *loop;
@@ -5503,10 +5571,8 @@ Raise_Error_to_gnu (Node_Id gnat_node, tree *gnu_result_type_p)
switch (Nkind (Right_Opnd (gnat_cond)))
{
case N_In:
- gnat_range = Right_Opnd (Right_Opnd (gnat_cond));
- gcc_assert (Nkind (gnat_range) == N_Range);
- gnu_low_bound = gnat_to_gnu (Low_Bound (gnat_range));
- gnu_high_bound = gnat_to_gnu (High_Bound (gnat_range));
+ Range_to_gnu (Right_Opnd (Right_Opnd (gnat_cond)),
+ &gnu_low_bound, &gnu_high_bound);
break;
case N_Op_Ge:
@@ -6052,17 +6118,25 @@ gnat_to_gnu (Node_Id gnat_node)
}
}
else
- gnat_to_gnu_entity (gnat_temp, gnu_expr, 1);
+ gnat_to_gnu_entity (gnat_temp, gnu_expr, true);
break;
case N_Object_Renaming_Declaration:
gnat_temp = Defining_Entity (gnat_node);
gnu_result = alloc_stmt_list ();
- /* Don't do anything if this renaming is handled by the front end or if
- we are just annotating types and this object has a composite or task
- type, don't elaborate it. */
- if (!Is_Renaming_Of_Object (gnat_temp)
+ /* Don't do anything if this renaming is handled by the front end and it
+ does not need debug info. Note that we consider renamings don't need
+ debug info when optimizing: our way to describe them has a
+ memory/elaboration footprint.
+
+ Don't do anything neither if we are just annotating types and this
+ object has a composite or task type, don't elaborate it. */
+ if ((!Is_Renaming_Of_Object (gnat_temp)
+ || (Needs_Debug_Info (gnat_temp)
+ && !optimize
+ && can_materialize_object_renaming_p
+ (Renamed_Object (gnat_temp))))
&& ! (type_annotate_only
&& (Is_Array_Type (Etype (gnat_temp))
|| Is_Record_Type (Etype (gnat_temp))
@@ -6070,7 +6144,8 @@ gnat_to_gnu (Node_Id gnat_node)
{
tree gnu_temp
= gnat_to_gnu_entity (gnat_temp,
- gnat_to_gnu (Renamed_Object (gnat_temp)), 1);
+ gnat_to_gnu (Renamed_Object (gnat_temp)),
+ true);
/* See case 2 of renaming in gnat_to_gnu_entity. */
if (TREE_SIDE_EFFECTS (gnu_temp))
gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_temp);
@@ -6086,7 +6161,8 @@ gnat_to_gnu (Node_Id gnat_node)
{
tree gnu_temp
= gnat_to_gnu_entity (gnat_temp,
- gnat_to_gnu (Renamed_Entity (gnat_temp)), 1);
+ gnat_to_gnu (Renamed_Entity (gnat_temp)),
+ true);
if (TREE_SIDE_EFFECTS (gnu_temp))
gnu_result = build_unary_op (ADDR_EXPR, NULL_TREE, gnu_temp);
}
@@ -6116,12 +6192,12 @@ gnat_to_gnu (Node_Id gnat_node)
|| Ekind (gnat_renamed) == E_Procedure)
&& !Is_Intrinsic_Subprogram (gnat_renaming)
&& !Is_Intrinsic_Subprogram (gnat_renamed))
- gnat_to_gnu_entity (gnat_renaming, gnat_to_gnu (gnat_renamed), 1);
+ gnat_to_gnu_entity (gnat_renaming, gnat_to_gnu (gnat_renamed), true);
break;
}
case N_Implicit_Label_Declaration:
- gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
+ gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, true);
gnu_result = alloc_stmt_list ();
break;
@@ -6345,8 +6421,7 @@ gnat_to_gnu (Node_Id gnat_node)
(Entity (Prefix (gnat_node)),
attr == Attr_Elab_Body ? "elabb" : "elabs"),
NULL_TREE, void_ftype, NULL_TREE, is_disabled,
- false, true, true, false, true, true,
- NULL, gnat_node);
+ true, true, true, true, NULL, gnat_node);
gnu_result = Attribute_to_gnu (gnat_node, &gnu_result_type, attr);
}
@@ -6483,30 +6558,9 @@ gnat_to_gnu (Node_Id gnat_node)
case N_Not_In:
{
tree gnu_obj = gnat_to_gnu (Left_Opnd (gnat_node));
- Node_Id gnat_range = Right_Opnd (gnat_node);
tree gnu_low, gnu_high;
- /* GNAT_RANGE is either an N_Range node or an identifier denoting a
- subtype. */
- if (Nkind (gnat_range) == N_Range)
- {
- gnu_low = gnat_to_gnu (Low_Bound (gnat_range));
- gnu_high = gnat_to_gnu (High_Bound (gnat_range));
- }
- else if (Nkind (gnat_range) == N_Identifier
- || Nkind (gnat_range) == N_Expanded_Name)
- {
- tree gnu_range_type = get_unpadded_type (Entity (gnat_range));
- tree gnu_range_base_type = get_base_type (gnu_range_type);
-
- gnu_low
- = convert (gnu_range_base_type, TYPE_MIN_VALUE (gnu_range_type));
- gnu_high
- = convert (gnu_range_base_type, TYPE_MAX_VALUE (gnu_range_type));
- }
- else
- gcc_unreachable ();
-
+ Range_to_gnu (Right_Opnd (gnat_node), &gnu_low, &gnu_high);
gnu_result_type = get_unpadded_type (Etype (gnat_node));
tree gnu_op_type = maybe_character_type (TREE_TYPE (gnu_obj));
@@ -6675,10 +6729,7 @@ gnat_to_gnu (Node_Id gnat_node)
/* Instead of expanding overflow checks for addition, subtraction
and multiplication itself, the front end will leave this to
- the back end when Backend_Overflow_Checks_On_Target is set.
- As the back end itself does not know yet how to properly
- do overflow checking, do it here. The goal is to push
- the expansions further into the back end over time. */
+ the back end when Backend_Overflow_Checks_On_Target is set. */
if (Do_Overflow_Check (gnat_node)
&& Backend_Overflow_Checks_On_Target
&& (code == PLUS_EXPR || code == MINUS_EXPR || code == MULT_EXPR)
@@ -6749,7 +6800,11 @@ gnat_to_gnu (Node_Id gnat_node)
gnu_expr = gnat_to_gnu (Right_Opnd (gnat_node));
gnu_result_type = get_unpadded_type (Etype (gnat_node));
+ /* Instead of expanding overflow checks for negation and absolute
+ value itself, the front end will leave this to the back end
+ when Backend_Overflow_Checks_On_Target is set. */
if (Do_Overflow_Check (gnat_node)
+ && Backend_Overflow_Checks_On_Target
&& !TYPE_UNSIGNED (gnu_result_type)
&& !FLOAT_TYPE_P (gnu_result_type))
gnu_result
@@ -7146,14 +7201,22 @@ gnat_to_gnu (Node_Id gnat_node)
/***************************/
case N_Subprogram_Declaration:
- /* Unless there is a freeze node, declare the subprogram. We consider
- this a "definition" even though we're not generating code for
- the subprogram because we will be making the corresponding GCC
- node here. */
-
+ /* Unless there is a freeze node, declare the entity. We consider
+ this a definition even though we're not generating code for the
+ subprogram because we will be making the corresponding GCC node.
+ When there is a freeze node, it is considered the definition of
+ the subprogram and we do nothing until after it is encountered.
+ That's an efficiency issue: the types involved in the profile
+ are far more likely to be frozen between the declaration and
+ the freeze node than before the declaration, so we save some
+ updates of the GCC node by waiting until the freeze node.
+ The counterpart is that we assume that there is no reference
+ to the subprogram between the declaration and the freeze node
+ in the expanded code; otherwise, it will be interpreted as an
+ external reference and very likely give rise to a link failure. */
if (No (Freeze_Node (Defining_Entity (Specification (gnat_node)))))
gnat_to_gnu_entity (Defining_Entity (Specification (gnat_node)),
- NULL_TREE, 1);
+ NULL_TREE, true);
gnu_result = alloc_stmt_list ();
break;
@@ -7175,7 +7238,7 @@ gnat_to_gnu (Node_Id gnat_node)
gnat_temp = Next_Formal_With_Extras (gnat_temp))
if (Is_Itype (Etype (gnat_temp))
&& !From_Limited_With (Etype (gnat_temp)))
- gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, 0);
+ gnat_to_gnu_entity (Etype (gnat_temp), NULL_TREE, false);
/* Then the result type, set to Standard_Void_Type for procedures. */
{
@@ -7183,7 +7246,7 @@ gnat_to_gnu (Node_Id gnat_node)
= Etype (Defining_Entity (Specification (gnat_node)));
if (Is_Itype (gnat_temp_type) && !From_Limited_With (gnat_temp_type))
- gnat_to_gnu_entity (Etype (gnat_temp_type), NULL_TREE, 0);
+ gnat_to_gnu_entity (Etype (gnat_temp_type), NULL_TREE, false);
}
gnu_result = alloc_stmt_list ();
@@ -7260,7 +7323,7 @@ gnat_to_gnu (Node_Id gnat_node)
break;
case N_Single_Task_Declaration:
- gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, 1);
+ gnat_to_gnu_entity (Defining_Entity (gnat_node), NULL_TREE, true);
gnu_result = alloc_stmt_list ();
break;
@@ -7581,7 +7644,6 @@ gnat_to_gnu (Node_Id gnat_node)
case N_Itype_Reference:
if (!present_gnu_tree (Itype (gnat_node)))
process_type (Itype (gnat_node));
-
gnu_result = alloc_stmt_list ();
break;
@@ -7689,27 +7751,31 @@ gnat_to_gnu (Node_Id gnat_node)
current_function_decl = NULL_TREE;
/* When not optimizing, turn boolean rvalues B into B != false tests
- so that the code just below can put the location information of the
- reference to B on the inequality operator for better debug info. */
+ so that we can put the location information of the reference to B on
+ the inequality operator for better debug info. */
if (!optimize
&& TREE_CODE (gnu_result) != INTEGER_CST
+ && TREE_CODE (gnu_result) != TYPE_DECL
&& (kind == N_Identifier
|| kind == N_Expanded_Name
|| kind == N_Explicit_Dereference
- || kind == N_Function_Call
|| kind == N_Indexed_Component
|| kind == N_Selected_Component)
&& TREE_CODE (get_base_type (gnu_result_type)) == BOOLEAN_TYPE
&& !lvalue_required_p (gnat_node, gnu_result_type, false, false, false))
- gnu_result = build_binary_op (NE_EXPR, gnu_result_type,
- convert (gnu_result_type, gnu_result),
- convert (gnu_result_type,
- boolean_false_node));
-
- /* Set the location information on the result. Note that we may have
- no result if we tried to build a CALL_EXPR node to a procedure with
- no side-effects and optimization is enabled. */
- if (gnu_result && EXPR_P (gnu_result))
+ {
+ gnu_result
+ = build_binary_op (NE_EXPR, gnu_result_type,
+ convert (gnu_result_type, gnu_result),
+ convert (gnu_result_type, boolean_false_node));
+ if (TREE_CODE (gnu_result) != INTEGER_CST)
+ set_gnu_expr_location_from_node (gnu_result, gnat_node);
+ }
+
+ /* Set the location information on the result if it's not a simple name.
+ Note that we may have no result if we tried to build a CALL_EXPR node
+ to a procedure with no side-effects and optimization is enabled. */
+ else if (kind != N_Identifier && gnu_result && EXPR_P (gnu_result))
set_gnu_expr_location_from_node (gnu_result, gnat_node);
/* If we're supposed to return something of void_type, it means we have
@@ -7867,6 +7933,10 @@ gnat_to_gnu_external (Node_Id gnat_node)
if (went_into_elab_proc)
current_function_decl = NULL_TREE;
+ /* Do not import locations from external units. */
+ if (gnu_result && EXPR_P (gnu_result))
+ SET_EXPR_LOCATION (gnu_result, UNKNOWN_LOCATION);
+
return gnu_result;
}
@@ -7878,7 +7948,7 @@ static void
push_exception_label_stack (vec<tree, va_gc> **gnu_stack, Entity_Id gnat_label)
{
tree gnu_label = (Present (gnat_label)
- ? gnat_to_gnu_entity (gnat_label, NULL_TREE, 0)
+ ? gnat_to_gnu_entity (gnat_label, NULL_TREE, false)
: NULL_TREE);
vec_safe_push (*gnu_stack, gnu_label);
@@ -7993,7 +8063,7 @@ void
add_decl_expr (tree gnu_decl, Entity_Id gnat_entity)
{
tree type = TREE_TYPE (gnu_decl);
- tree gnu_stmt, gnu_init, t;
+ tree gnu_stmt, gnu_init;
/* If this is a variable that Gigi is to ignore, we may have been given
an ERROR_MARK. So test for it. We also might have been given a
@@ -8040,15 +8110,6 @@ add_decl_expr (tree gnu_decl, Entity_Id gnat_entity)
&& !initializer_constant_valid_p (gnu_init,
TREE_TYPE (gnu_init)))))
{
- /* If GNU_DECL has a padded type, convert it to the unpadded
- type so the assignment is done properly. */
- if (TYPE_IS_PADDING_P (type))
- t = convert (TREE_TYPE (TYPE_FIELDS (type)), gnu_decl);
- else
- t = gnu_decl;
-
- gnu_stmt = build_binary_op (INIT_EXPR, NULL_TREE, t, gnu_init);
-
DECL_INITIAL (gnu_decl) = NULL_TREE;
if (TREE_READONLY (gnu_decl))
{
@@ -8056,6 +8117,12 @@ add_decl_expr (tree gnu_decl, Entity_Id gnat_entity)
DECL_READONLY_ONCE_ELAB (gnu_decl) = 1;
}
+ /* If GNU_DECL has a padded type, convert it to the unpadded
+ type so the assignment is done properly. */
+ if (TYPE_IS_PADDING_P (type))
+ gnu_decl = convert (TREE_TYPE (TYPE_FIELDS (type)), gnu_decl);
+
+ gnu_stmt = build_binary_op (INIT_EXPR, NULL_TREE, gnu_decl, gnu_init);
add_stmt_with_node (gnu_stmt, gnat_entity);
}
}
@@ -8453,6 +8520,8 @@ elaborate_all_entities_for_package (Entity_Id gnat_package)
continue;
if (IN (kind, Subprogram_Kind) && Is_Intrinsic_Subprogram (gnat_entity))
continue;
+ if (Is_Itype (gnat_entity))
+ continue;
/* Skip named numbers. */
if (IN (kind, Named_Kind))
@@ -8462,6 +8531,10 @@ elaborate_all_entities_for_package (Entity_Id gnat_package)
if (IN (kind, Generic_Unit_Kind))
continue;
+ /* Skip formal objects. */
+ if (IN (kind, Formal_Object_Kind))
+ continue;
+
/* Skip package bodies. */
if (kind == E_Package_Body)
continue;
@@ -8484,7 +8557,7 @@ elaborate_all_entities_for_package (Entity_Id gnat_package)
elaborate_all_entities_for_package (gnat_entity);
}
else
- gnat_to_gnu_entity (gnat_entity, NULL_TREE, 0);
+ gnat_to_gnu_entity (gnat_entity, NULL_TREE, false);
}
}
@@ -8566,14 +8639,11 @@ process_freeze_entity (Node_Id gnat_node)
if (kind == E_Class_Wide_Type)
return;
- /* Check for an old definition. This freeze node might be for an Itype. */
+ /* Check for an old definition if this isn't an object with address clause,
+ since the saved GCC tree is the address expression in that case. */
gnu_old
- = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : NULL_TREE;
-
- /* If this entity has an address representation clause, GNU_OLD is the
- address, so discard it here. */
- if (Present (Address_Clause (gnat_entity)))
- gnu_old = NULL_TREE;
+ = present_gnu_tree (gnat_entity) && No (Address_Clause (gnat_entity))
+ ? get_gnu_tree (gnat_entity) : NULL_TREE;
/* Don't do anything for subprograms that may have been elaborated before
their freeze nodes. This can happen, for example, because of an inner
@@ -8586,9 +8656,8 @@ process_freeze_entity (Node_Id gnat_node)
&& kind == E_Subprogram_Type)))
return;
- /* If we have a non-dummy type old tree, we have nothing to do, except
- aborting if this is the public view of a private type whose full view was
- not delayed, as this node was never delayed as it should have been. We
+ /* If we have a non-dummy type old tree, we have nothing to do, except for
+ aborting, since this node was never delayed as it should have been. We
let this happen for concurrent types and their Corresponding_Record_Type,
however, because each might legitimately be elaborated before its own
freeze node, e.g. while processing the other. */
@@ -8596,10 +8665,7 @@ process_freeze_entity (Node_Id gnat_node)
&& !(TREE_CODE (gnu_old) == TYPE_DECL
&& TYPE_IS_DUMMY_P (TREE_TYPE (gnu_old))))
{
- gcc_assert ((IN (kind, Incomplete_Or_Private_Kind)
- && Present (Full_View (gnat_entity))
- && No (Freeze_Node (Full_View (gnat_entity))))
- || Is_Concurrent_Type (gnat_entity)
+ gcc_assert (Is_Concurrent_Type (gnat_entity)
|| (IN (kind, Record_Kind)
&& Is_Concurrent_Record_Type (gnat_entity)));
return;
@@ -8642,7 +8708,7 @@ process_freeze_entity (Node_Id gnat_node)
&& Present (Underlying_Full_View (full_view)))
full_view = Underlying_Full_View (full_view);
- gnu_new = gnat_to_gnu_entity (full_view, NULL_TREE, 1);
+ gnu_new = gnat_to_gnu_entity (full_view, NULL_TREE, true);
/* Propagate back-annotations from full view to partial view. */
if (Unknown_Alignment (gnat_entity))
@@ -8667,7 +8733,7 @@ process_freeze_entity (Node_Id gnat_node)
&& present_gnu_tree (Declaration_Node (gnat_entity)))
? get_gnu_tree (Declaration_Node (gnat_entity)) : NULL_TREE;
- gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, 1);
+ gnu_new = gnat_to_gnu_entity (gnat_entity, gnu_init, true);
}
if (IN (kind, Type_Kind)
@@ -8683,6 +8749,8 @@ process_freeze_entity (Node_Id gnat_node)
{
update_pointer_to (TYPE_MAIN_VARIANT (TREE_TYPE (gnu_old)),
TREE_TYPE (gnu_new));
+ if (TYPE_DUMMY_IN_PROFILE_P (TREE_TYPE (gnu_old)))
+ update_profiles_with (TREE_TYPE (gnu_old));
if (DECL_TAFT_TYPE_P (gnu_old))
used_types_insert (TREE_TYPE (gnu_new));
}
@@ -8759,7 +8827,7 @@ process_decls (List_Id gnat_decls, List_Id gnat_decls2,
if (Ekind (gnat_subprog_id) != E_Generic_Procedure
&& Ekind (gnat_subprog_id) != E_Generic_Function)
- gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
+ gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, true);
}
}
@@ -8774,7 +8842,7 @@ process_decls (List_Id gnat_decls, List_Id gnat_decls2,
if (Ekind (gnat_subprog_id) != E_Subprogram_Body
&& Ekind (gnat_subprog_id) != E_Generic_Procedure
&& Ekind (gnat_subprog_id) != E_Generic_Function)
- gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, 1);
+ gnat_to_gnu_entity (gnat_subprog_id, NULL_TREE, true);
}
/* Concurrent stubs stand for the corresponding subprogram bodies,
@@ -8860,19 +8928,16 @@ build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left,
tree rhs = gnat_protect_expr (right);
tree type_max = TYPE_MAX_VALUE (gnu_type);
tree type_min = TYPE_MIN_VALUE (gnu_type);
- tree zero = build_int_cst (gnu_type, 0);
- tree gnu_expr, rhs_lt_zero, tmp1, tmp2;
- tree check_pos, check_neg, check;
+ tree gnu_expr, check;
+ int sgn;
/* Assert that the precision is a power of 2. */
gcc_assert ((precision & (precision - 1)) == 0);
- /* Prefer a constant or known-positive rhs to simplify checks. */
- if (!TREE_CONSTANT (rhs)
- && commutative_tree_code (code)
- && (TREE_CONSTANT (lhs)
- || (!tree_expr_nonnegative_p (rhs)
- && tree_expr_nonnegative_p (lhs))))
+ /* Prefer a constant on the RHS to simplify checks. */
+ if (TREE_CODE (rhs) != INTEGER_CST
+ && TREE_CODE (lhs) == INTEGER_CST
+ && (code == PLUS_EXPR || code == MULT_EXPR))
{
tree tmp = lhs;
lhs = rhs;
@@ -8883,151 +8948,150 @@ build_binary_op_trapv (enum tree_code code, tree gnu_type, tree left,
/* If we can fold the expression to a constant, just return it.
The caller will deal with overflow, no need to generate a check. */
- if (TREE_CONSTANT (gnu_expr))
+ if (TREE_CODE (gnu_expr) == INTEGER_CST)
return gnu_expr;
- rhs_lt_zero = tree_expr_nonnegative_p (rhs)
- ? boolean_false_node
- : build_binary_op (LT_EXPR, boolean_type_node, rhs, zero);
-
- /* ??? Should use more efficient check for operand_equal_p (lhs, rhs, 0) */
-
- /* Try a few strategies that may be cheaper than the general
- code at the end of the function, if the rhs is not known.
- The strategies are:
- - Call library function for 64-bit multiplication (complex)
- - Widen, if input arguments are sufficiently small
- - Determine overflow using wrapped result for addition/subtraction. */
-
- if (!TREE_CONSTANT (rhs))
+ /* If no operand is a constant, we use the generic implementation. */
+ if (TREE_CODE (lhs) != INTEGER_CST && TREE_CODE (rhs) != INTEGER_CST)
{
- /* Even for add/subtract double size to get another base type. */
- const unsigned int needed_precision = precision * 2;
-
- if (code == MULT_EXPR && precision == 64)
+ /* Never inline a 64-bit mult for a 32-bit target, it's way too long. */
+ if (code == MULT_EXPR && precision == 64 && BITS_PER_WORD < 64)
{
- tree int_64 = gnat_type_for_size (64, 0);
-
+ tree int64 = gnat_type_for_size (64, 0);
return convert (gnu_type, build_call_n_expr (mulv64_decl, 2,
- convert (int_64, lhs),
- convert (int_64, rhs)));
+ convert (int64, lhs),
+ convert (int64, rhs)));
}
- if (needed_precision <= BITS_PER_WORD
- || (code == MULT_EXPR && needed_precision <= LONG_LONG_TYPE_SIZE))
- {
- tree wide_type = gnat_type_for_size (needed_precision, 0);
- tree wide_result = build_binary_op (code, wide_type,
- convert (wide_type, lhs),
- convert (wide_type, rhs));
-
- check = build_binary_op
- (TRUTH_ORIF_EXPR, boolean_type_node,
- build_binary_op (LT_EXPR, boolean_type_node, wide_result,
- convert (wide_type, type_min)),
- build_binary_op (GT_EXPR, boolean_type_node, wide_result,
- convert (wide_type, type_max)));
+ enum internal_fn icode;
- return
- emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node);
- }
-
- if (code == PLUS_EXPR || code == MINUS_EXPR)
+ switch (code)
{
- tree unsigned_type = gnat_type_for_size (precision, 1);
- tree wrapped_expr
- = convert (gnu_type,
- build_binary_op (code, unsigned_type,
- convert (unsigned_type, lhs),
- convert (unsigned_type, rhs)));
-
- /* Overflow when (rhs < 0) ^ (wrapped_expr < lhs)), for addition
- or when (rhs < 0) ^ (wrapped_expr > lhs) for subtraction. */
- check
- = build_binary_op (TRUTH_XOR_EXPR, boolean_type_node, rhs_lt_zero,
- build_binary_op (code == PLUS_EXPR
- ? LT_EXPR : GT_EXPR,
- boolean_type_node,
- wrapped_expr, lhs));
-
- return
- emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node);
+ case PLUS_EXPR:
+ icode = IFN_ADD_OVERFLOW;
+ break;
+ case MINUS_EXPR:
+ icode = IFN_SUB_OVERFLOW;
+ break;
+ case MULT_EXPR:
+ icode = IFN_MUL_OVERFLOW;
+ break;
+ default:
+ gcc_unreachable ();
}
+
+ tree gnu_ctype = build_complex_type (gnu_type);
+ tree call
+ = build_call_expr_internal_loc (UNKNOWN_LOCATION, icode, gnu_ctype, 2,
+ lhs, rhs);
+ tree tgt = save_expr (call);
+ gnu_expr = build1 (REALPART_EXPR, gnu_type, tgt);
+ check = fold_build2 (NE_EXPR, boolean_type_node,
+ build1 (IMAGPART_EXPR, gnu_type, tgt),
+ build_int_cst (gnu_type, 0));
+ return
+ emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node);
}
+ /* If one operand is a constant, we expose the overflow condition to enable
+ a subsequent simplication or even elimination. */
switch (code)
{
case PLUS_EXPR:
- /* When rhs >= 0, overflow when lhs > type_max - rhs. */
- check_pos = build_binary_op (GT_EXPR, boolean_type_node, lhs,
- build_binary_op (MINUS_EXPR, gnu_type,
- type_max, rhs)),
-
- /* When rhs < 0, overflow when lhs < type_min - rhs. */
- check_neg = build_binary_op (LT_EXPR, boolean_type_node, lhs,
- build_binary_op (MINUS_EXPR, gnu_type,
- type_min, rhs));
+ sgn = tree_int_cst_sgn (rhs);
+ if (sgn > 0)
+ /* When rhs > 0, overflow when lhs > type_max - rhs. */
+ check = build_binary_op (GT_EXPR, boolean_type_node, lhs,
+ build_binary_op (MINUS_EXPR, gnu_type,
+ type_max, rhs));
+ else if (sgn < 0)
+ /* When rhs < 0, overflow when lhs < type_min - rhs. */
+ check = build_binary_op (LT_EXPR, boolean_type_node, lhs,
+ build_binary_op (MINUS_EXPR, gnu_type,
+ type_min, rhs));
+ else
+ return gnu_expr;
break;
case MINUS_EXPR:
- /* When rhs >= 0, overflow when lhs < type_min + rhs. */
- check_pos = build_binary_op (LT_EXPR, boolean_type_node, lhs,
- build_binary_op (PLUS_EXPR, gnu_type,
- type_min, rhs)),
-
- /* When rhs < 0, overflow when lhs > type_max + rhs. */
- check_neg = build_binary_op (GT_EXPR, boolean_type_node, lhs,
- build_binary_op (PLUS_EXPR, gnu_type,
- type_max, rhs));
+ if (TREE_CODE (lhs) == INTEGER_CST)
+ {
+ sgn = tree_int_cst_sgn (lhs);
+ if (sgn > 0)
+ /* When lhs > 0, overflow when rhs < lhs - type_max. */
+ check = build_binary_op (LT_EXPR, boolean_type_node, rhs,
+ build_binary_op (MINUS_EXPR, gnu_type,
+ lhs, type_max));
+ else if (sgn < 0)
+ /* When lhs < 0, overflow when rhs > lhs - type_min. */
+ check = build_binary_op (GT_EXPR, boolean_type_node, rhs,
+ build_binary_op (MINUS_EXPR, gnu_type,
+ lhs, type_min));
+ else
+ return gnu_expr;
+ }
+ else
+ {
+ sgn = tree_int_cst_sgn (rhs);
+ if (sgn > 0)
+ /* When rhs > 0, overflow when lhs < type_min + rhs. */
+ check = build_binary_op (LT_EXPR, boolean_type_node, lhs,
+ build_binary_op (PLUS_EXPR, gnu_type,
+ type_min, rhs));
+ else if (sgn < 0)
+ /* When rhs < 0, overflow when lhs > type_max + rhs. */
+ check = build_binary_op (GT_EXPR, boolean_type_node, lhs,
+ build_binary_op (PLUS_EXPR, gnu_type,
+ type_max, rhs));
+ else
+ return gnu_expr;
+ }
break;
case MULT_EXPR:
- /* The check here is designed to be efficient if the rhs is constant,
- but it will work for any rhs by using integer division.
- Four different check expressions determine whether X * C overflows,
- depending on C.
- C == 0 => false
- C > 0 => X > type_max / C || X < type_min / C
- C == -1 => X == type_min
- C < -1 => X > type_min / C || X < type_max / C */
-
- tmp1 = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_max, rhs);
- tmp2 = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_min, rhs);
-
- check_pos
- = build_binary_op (TRUTH_ANDIF_EXPR, boolean_type_node,
- build_binary_op (NE_EXPR, boolean_type_node, zero,
- rhs),
- build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
- build_binary_op (GT_EXPR,
- boolean_type_node,
- lhs, tmp1),
- build_binary_op (LT_EXPR,
- boolean_type_node,
- lhs, tmp2)));
-
- check_neg
- = fold_build3 (COND_EXPR, boolean_type_node,
- build_binary_op (EQ_EXPR, boolean_type_node, rhs,
- build_int_cst (gnu_type, -1)),
- build_binary_op (EQ_EXPR, boolean_type_node, lhs,
- type_min),
- build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
- build_binary_op (GT_EXPR,
- boolean_type_node,
- lhs, tmp2),
- build_binary_op (LT_EXPR,
- boolean_type_node,
- lhs, tmp1)));
+ sgn = tree_int_cst_sgn (rhs);
+ if (sgn > 0)
+ {
+ if (integer_onep (rhs))
+ return gnu_expr;
+
+ tree lb = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_min, rhs);
+ tree ub = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_max, rhs);
+
+ /* When rhs > 1, overflow outside [type_min/rhs; type_max/rhs]. */
+ check
+ = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
+ build_binary_op (LT_EXPR, boolean_type_node,
+ lhs, lb),
+ build_binary_op (GT_EXPR, boolean_type_node,
+ lhs, ub));
+ }
+ else if (sgn < 0)
+ {
+ tree lb = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_max, rhs);
+ tree ub = build_binary_op (TRUNC_DIV_EXPR, gnu_type, type_min, rhs);
+
+ if (integer_minus_onep (rhs))
+ /* When rhs == -1, overflow if lhs == type_min. */
+ check
+ = build_binary_op (EQ_EXPR, boolean_type_node, lhs, type_min);
+ else
+ /* When rhs < -1, overflow outside [type_max/rhs; type_min/rhs]. */
+ check
+ = build_binary_op (TRUTH_ORIF_EXPR, boolean_type_node,
+ build_binary_op (LT_EXPR, boolean_type_node,
+ lhs, lb),
+ build_binary_op (GT_EXPR, boolean_type_node,
+ lhs, ub));
+ }
+ else
+ return gnu_expr;
break;
default:
gcc_unreachable ();
}
- check = fold_build3 (COND_EXPR, boolean_type_node, rhs_lt_zero, check_neg,
- check_pos);
-
return emit_check (check, gnu_expr, CE_Overflow_Check_Failed, gnat_node);
}
@@ -9469,28 +9533,22 @@ addressable_p (tree gnu_expr, tree gnu_type)
}
}
-/* Do the processing for the declaration of a GNAT_ENTITY, a type. If
- a separate Freeze node exists, delay the bulk of the processing. Otherwise
- make a GCC type for GNAT_ENTITY and set up the correspondence. */
+/* Do the processing for the declaration of a GNAT_ENTITY, a type or subtype.
+ If a Freeze node exists for the entity, delay the bulk of the processing.
+ Otherwise make a GCC type for GNAT_ENTITY and set up the correspondence. */
void
process_type (Entity_Id gnat_entity)
{
tree gnu_old
- = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : 0;
- tree gnu_new;
-
- /* If we are to delay elaboration of this type, just do any
- elaborations needed for expressions within the declaration and
- make a dummy type entry for this node and its Full_View (if
- any) in case something points to it. Don't do this if it
- has already been done (the only way that can happen is if
- the private completion is also delayed). */
- if (Present (Freeze_Node (gnat_entity))
- || (IN (Ekind (gnat_entity), Incomplete_Or_Private_Kind)
- && Present (Full_View (gnat_entity))
- && Present (Freeze_Node (Full_View (gnat_entity)))
- && !present_gnu_tree (Full_View (gnat_entity))))
+ = present_gnu_tree (gnat_entity) ? get_gnu_tree (gnat_entity) : NULL_TREE;
+
+ /* If we are to delay elaboration of this type, just do any elaboration
+ needed for expressions within the declaration and make a dummy node
+ for it and its Full_View (if any), in case something points to it.
+ Do not do this if it has already been done (the only way that can
+ happen is if the private completion is also delayed). */
+ if (Present (Freeze_Node (gnat_entity)))
{
elaborate_entity (gnat_entity);
@@ -9510,10 +9568,11 @@ process_type (Entity_Id gnat_entity)
return;
}
- /* If we saved away a dummy type for this node it means that this
- made the type that corresponds to the full type of an incomplete
- type. Clear that type for now and then update the type in the
- pointers. */
+ /* If we saved away a dummy type for this node, it means that this made the
+ type that corresponds to the full type of an incomplete type. Clear that
+ type for now and then update the type in the pointers below. But, if the
+ saved type is not dummy, it very likely means that we have a use before
+ declaration for the type in the tree, what we really cannot handle. */
if (gnu_old)
{
gcc_assert (TREE_CODE (gnu_old) == TYPE_DECL
@@ -9523,7 +9582,7 @@ process_type (Entity_Id gnat_entity)
}
/* Now fully elaborate the type. */
- gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, 1);
+ tree gnu_new = gnat_to_gnu_entity (gnat_entity, NULL_TREE, true);
gcc_assert (TREE_CODE (gnu_new) == TYPE_DECL);
/* If we have an old type and we've made pointers to this type, update those
diff --git a/gcc/ada/gcc-interface/utils.c b/gcc/ada/gcc-interface/utils.c
index 4226f95463..0a6d6af5b5 100644
--- a/gcc/ada/gcc-interface/utils.c
+++ b/gcc/ada/gcc-interface/utils.c
@@ -238,6 +238,7 @@ static GTY ((cache))
hash_table<pad_type_hasher> *pad_type_hash_table;
static tree merge_sizes (tree, tree, tree, bool, bool);
+static tree fold_bit_position (const_tree);
static tree compute_related_constant (tree, tree);
static tree split_plus (tree, tree *);
static tree float_type_for_precision (int, machine_mode);
@@ -245,17 +246,24 @@ static tree convert_to_fat_pointer (tree, tree);
static unsigned int scale_by_factor_of (tree, unsigned int);
static bool potential_alignment_gap (tree, tree, tree);
-/* A linked list used as a queue to defer the initialization of the
- DECL_CONTEXT attribute of ..._DECL nodes and of the TYPE_CONTEXT attribute
- of ..._TYPE nodes. */
+/* Linked list used as a queue to defer the initialization of the DECL_CONTEXT
+ of ..._DECL nodes and of the TYPE_CONTEXT of ..._TYPE nodes. */
struct deferred_decl_context_node
{
- tree decl; /* The ..._DECL node to work on. */
- Entity_Id gnat_scope; /* The corresponding entity's Scope attribute. */
- int force_global; /* force_global value when pushing DECL. */
- vec<tree, va_heap, vl_ptr> types; /* A list of ..._TYPE nodes to propagate the
- context to. */
- struct deferred_decl_context_node *next; /* The next queue item. */
+ /* The ..._DECL node to work on. */
+ tree decl;
+
+ /* The corresponding entity's Scope. */
+ Entity_Id gnat_scope;
+
+ /* The value of force_global when DECL was pushed. */
+ int force_global;
+
+ /* The list of ..._TYPE nodes to propagate the context to. */
+ vec<tree> types;
+
+ /* The next queue item. */
+ struct deferred_decl_context_node *next;
};
static struct deferred_decl_context_node *deferred_decl_context_queue = NULL;
@@ -427,6 +435,7 @@ build_dummy_unc_pointer_types (Entity_Id gnat_desig_type, tree gnu_desig_type)
TYPE_DUMMY_P (gnu_object_type) = 1;
TYPE_POINTER_TO (gnu_desig_type) = gnu_fat_type;
+ TYPE_REFERENCE_TO (gnu_desig_type) = gnu_fat_type;
TYPE_OBJECT_RECORD_TYPE (gnu_desig_type) = gnu_object_type;
}
@@ -658,7 +667,8 @@ get_global_context (void)
{
if (!global_context)
{
- global_context = build_translation_unit_decl (NULL_TREE);
+ global_context
+ = build_translation_unit_decl (get_identifier (main_input_filename));
debug_hooks->register_main_translation_unit (global_context);
}
@@ -781,24 +791,11 @@ gnat_pushdecl (tree decl, Node_Id gnat_node)
|| TREE_CODE (t) == POINTER_TYPE
|| TYPE_IS_FAT_POINTER_P (t)))
{
- tree tt;
- /* ??? Copy and original type are not supposed to be variant but we
- really need a variant for the placeholder machinery to work. */
- if (TYPE_IS_FAT_POINTER_P (t))
- tt = build_variant_type_copy (t);
- else
- {
- /* TYPE_NEXT_PTR_TO is a chain of main variants. */
- tt = build_distinct_type_copy (TYPE_MAIN_VARIANT (t));
- if (TREE_CODE (t) == POINTER_TYPE)
- TYPE_NEXT_PTR_TO (TYPE_MAIN_VARIANT (t)) = tt;
- tt = build_qualified_type (tt, TYPE_QUALS (t));
- }
+ tree tt = build_variant_type_copy (t);
TYPE_NAME (tt) = decl;
defer_or_set_type_context (tt,
DECL_CONTEXT (decl),
deferred_decl_context);
- TREE_USED (tt) = TREE_USED (t);
TREE_TYPE (decl) = tt;
if (TYPE_NAME (t)
&& TREE_CODE (TYPE_NAME (t)) == TYPE_DECL
@@ -910,7 +907,7 @@ make_aligning_type (tree type, unsigned int align, tree size,
pos, 1, -1);
TYPE_FIELDS (record_type) = field;
- TYPE_ALIGN (record_type) = base_align;
+ SET_TYPE_ALIGN (record_type, base_align);
TYPE_USER_ALIGN (record_type) = 1;
TYPE_SIZE (record_type)
@@ -935,23 +932,24 @@ make_aligning_type (tree type, unsigned int align, tree size,
/* TYPE is a RECORD_TYPE, UNION_TYPE or QUAL_UNION_TYPE that is being used
as the field type of a packed record if IN_RECORD is true, or as the
component type of a packed array if IN_RECORD is false. See if we can
- rewrite it either as a type that has a non-BLKmode, which we can pack
- tighter in the packed record case, or as a smaller type. If so, return
- the new type. If not, return the original type. */
+ rewrite it either as a type that has non-BLKmode, which we can pack
+ tighter in the packed record case, or as a smaller type with at most
+ MAX_ALIGN alignment if the value is non-zero. If so, return the new
+ type; if not, return the original type. */
tree
-make_packable_type (tree type, bool in_record)
+make_packable_type (tree type, bool in_record, unsigned int max_align)
{
unsigned HOST_WIDE_INT size = tree_to_uhwi (TYPE_SIZE (type));
unsigned HOST_WIDE_INT new_size;
- tree new_type, old_field, field_list = NULL_TREE;
- unsigned int align;
+ unsigned int align = TYPE_ALIGN (type);
+ unsigned int new_align;
/* No point in doing anything if the size is zero. */
if (size == 0)
return type;
- new_type = make_node (TREE_CODE (type));
+ tree new_type = make_node (TREE_CODE (type));
/* Copy the name and flags from the old type to that of the new.
Note that we rely on the pointer equality created here for
@@ -968,49 +966,50 @@ make_packable_type (tree type, bool in_record)
type with BLKmode. */
if (in_record && size <= MAX_FIXED_MODE_SIZE)
{
- align = ceil_pow2 (size);
- TYPE_ALIGN (new_type) = align;
- new_size = (size + align - 1) & -align;
+ new_size = ceil_pow2 (size);
+ new_align = MIN (new_size, BIGGEST_ALIGNMENT);
+ SET_TYPE_ALIGN (new_type, new_align);
}
else
{
- unsigned HOST_WIDE_INT align;
-
/* Do not try to shrink the size if the RM size is not constant. */
if (TYPE_CONTAINS_TEMPLATE_P (type)
|| !tree_fits_uhwi_p (TYPE_ADA_SIZE (type)))
return type;
/* Round the RM size up to a unit boundary to get the minimal size
- for a BLKmode record. Give up if it's already the size. */
+ for a BLKmode record. Give up if it's already the size and we
+ don't need to lower the alignment. */
new_size = tree_to_uhwi (TYPE_ADA_SIZE (type));
new_size = (new_size + BITS_PER_UNIT - 1) & -BITS_PER_UNIT;
- if (new_size == size)
+ if (new_size == size && (max_align == 0 || align <= max_align))
return type;
- align = new_size & -new_size;
- TYPE_ALIGN (new_type) = MIN (TYPE_ALIGN (type), align);
+ new_align = MIN (new_size & -new_size, BIGGEST_ALIGNMENT);
+ if (max_align > 0 && new_align > max_align)
+ new_align = max_align;
+ SET_TYPE_ALIGN (new_type, MIN (align, new_align));
}
TYPE_USER_ALIGN (new_type) = 1;
/* Now copy the fields, keeping the position and size as we don't want
to change the layout by propagating the packedness downwards. */
- for (old_field = TYPE_FIELDS (type); old_field;
- old_field = DECL_CHAIN (old_field))
+ tree new_field_list = NULL_TREE;
+ for (tree field = TYPE_FIELDS (type); field; field = DECL_CHAIN (field))
{
- tree new_field_type = TREE_TYPE (old_field);
+ tree new_field_type = TREE_TYPE (field);
tree new_field, new_size;
if (RECORD_OR_UNION_TYPE_P (new_field_type)
&& !TYPE_FAT_POINTER_P (new_field_type)
&& tree_fits_uhwi_p (TYPE_SIZE (new_field_type)))
- new_field_type = make_packable_type (new_field_type, true);
+ new_field_type = make_packable_type (new_field_type, true, max_align);
/* However, for the last field in a not already packed record type
that is of an aggregate type, we need to use the RM size in the
packable version of the record type, see finish_record_type. */
- if (!DECL_CHAIN (old_field)
+ if (!DECL_CHAIN (field)
&& !TYPE_PACKED (type)
&& RECORD_OR_UNION_TYPE_P (new_field_type)
&& !TYPE_FAT_POINTER_P (new_field_type)
@@ -1018,24 +1017,24 @@ make_packable_type (tree type, bool in_record)
&& TYPE_ADA_SIZE (new_field_type))
new_size = TYPE_ADA_SIZE (new_field_type);
else
- new_size = DECL_SIZE (old_field);
+ new_size = DECL_SIZE (field);
new_field
- = create_field_decl (DECL_NAME (old_field), new_field_type, new_type,
- new_size, bit_position (old_field),
+ = create_field_decl (DECL_NAME (field), new_field_type, new_type,
+ new_size, bit_position (field),
TYPE_PACKED (type),
- !DECL_NONADDRESSABLE_P (old_field));
+ !DECL_NONADDRESSABLE_P (field));
- DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (old_field);
- SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, old_field);
+ DECL_INTERNAL_P (new_field) = DECL_INTERNAL_P (field);
+ SET_DECL_ORIGINAL_FIELD_TO_FIELD (new_field, field);
if (TREE_CODE (new_type) == QUAL_UNION_TYPE)
- DECL_QUALIFIER (new_field) = DECL_QUALIFIER (old_field);
+ DECL_QUALIFIER (new_field) = DECL_QUALIFIER (field);
- DECL_CHAIN (new_field) = field_list;
- field_list = new_field;
+ DECL_CHAIN (new_field) = new_field_list;
+ new_field_list = new_field;
}
- finish_record_type (new_type, nreverse (field_list), 2, false);
+ finish_record_type (new_type, nreverse (new_field_list), 2, false);
relate_alias_sets (new_type, type, ALIAS_SET_COPY);
if (TYPE_STUB_DECL (type))
SET_DECL_PARALLEL_TYPE (TYPE_STUB_DECL (new_type),
@@ -1052,8 +1051,7 @@ make_packable_type (tree type, bool in_record)
else
{
TYPE_SIZE (new_type) = bitsize_int (new_size);
- TYPE_SIZE_UNIT (new_type)
- = size_int ((new_size + BITS_PER_UNIT - 1) / BITS_PER_UNIT);
+ TYPE_SIZE_UNIT (new_type) = size_int (new_size / BITS_PER_UNIT);
}
if (!TYPE_CONTAINS_TEMPLATE_P (type))
@@ -1067,13 +1065,32 @@ make_packable_type (tree type, bool in_record)
SET_TYPE_MODE (new_type,
mode_for_size_tree (TYPE_SIZE (new_type), MODE_INT, 1));
- /* If neither the mode nor the size has shrunk, return the old type. */
- if (TYPE_MODE (new_type) == BLKmode && new_size >= size)
+ /* If neither mode nor size nor alignment shrunk, return the old type. */
+ if (TYPE_MODE (new_type) == BLKmode && new_size >= size && max_align == 0)
return type;
return new_type;
}
+/* Return true if TYPE has an unsigned representation. This needs to be used
+ when the representation of types whose precision is not equal to their size
+ is manipulated based on the RM size. */
+
+static inline bool
+type_unsigned_for_rm (tree type)
+{
+ /* This is the common case. */
+ if (TYPE_UNSIGNED (type))
+ return true;
+
+ /* See the E_Signed_Integer_Subtype case of gnat_to_gnu_entity. */
+ if (TREE_CODE (TYPE_MIN_VALUE (type)) == INTEGER_CST
+ && tree_int_cst_sgn (TYPE_MIN_VALUE (type)) >= 0)
+ return true;
+
+ return false;
+}
+
/* Given a type TYPE, return a new type whose size is appropriate for SIZE.
If TYPE is the best type, return it. Otherwise, make a new type. We
only support new integral and pointer types. FOR_BIASED is true if
@@ -1113,7 +1130,11 @@ make_type_from_size (tree type, tree size_tree, bool for_biased)
break;
biased_p |= for_biased;
- if (TYPE_UNSIGNED (type) || biased_p)
+
+ /* The type should be an unsigned type if the original type is unsigned
+ or if the lower bound is constant and non-negative or if the type is
+ biased, see E_Signed_Integer_Subtype case of gnat_to_gnu_entity. */
+ if (type_unsigned_for_rm (type) || biased_p)
new_type = make_unsigned_type (size);
else
new_type = make_signed_type (size);
@@ -1223,7 +1244,8 @@ lookup_and_insert_pad_type (tree type)
IS_COMPONENT_TYPE is true if this is being done for the component type of
an array. IS_USER_TYPE is true if the original type needs to be completed.
DEFINITION is true if this type is being defined. SET_RM_SIZE is true if
- the RM size of the resulting type is to be set to SIZE too. */
+ the RM size of the resulting type is to be set to SIZE too; in this case,
+ the padded type is canonicalized before being returned. */
tree
maybe_pad_type (tree type, tree size, unsigned int align,
@@ -1286,8 +1308,6 @@ maybe_pad_type (tree type, tree size, unsigned int align,
type and name. */
record = make_node (RECORD_TYPE);
TYPE_PADDING_P (record) = 1;
- if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
- SET_TYPE_DEBUG_TYPE (record, type);
/* ??? Padding types around packed array implementation types will be
considered as root types in the array descriptor language hook (see
@@ -1301,7 +1321,7 @@ maybe_pad_type (tree type, tree size, unsigned int align,
else if (Present (gnat_entity))
TYPE_NAME (record) = create_concat_name (gnat_entity, "PAD");
- TYPE_ALIGN (record) = align ? align : orig_align;
+ SET_TYPE_ALIGN (record, align ? align : orig_align);
TYPE_SIZE (record) = size ? size : orig_size;
TYPE_SIZE_UNIT (record)
= convert (sizetype,
@@ -1343,9 +1363,12 @@ maybe_pad_type (tree type, tree size, unsigned int align,
bitsize_zero_node, 0, 1);
DECL_INTERNAL_P (field) = 1;
- /* Do not emit debug info until after the auxiliary record is built. */
+ /* We will output additional debug info manually below. */
finish_record_type (record, field, 1, false);
+ if (gnat_encodings == DWARF_GNAT_ENCODINGS_MINIMAL)
+ SET_TYPE_DEBUG_TYPE (record, type);
+
/* Set the RM size if requested. */
if (set_rm_size)
{
@@ -1415,8 +1438,6 @@ maybe_pad_type (tree type, tree size, unsigned int align,
}
}
- rest_of_record_type_compilation (record);
-
built:
/* If a simple size was explicitly given, maybe issue a warning. */
if (!size
@@ -1622,10 +1643,7 @@ record_builtin_type (const char *name, tree type, bool artificial_p)
character subtypes with RM_Size = Esize = CHAR_TYPE_SIZE into signed
types. The idea is to ensure that the bit pattern contained in the
Esize'd objects is not changed, even though the numerical value will
- be interpreted differently depending on the signedness.
-
- For character types, the bounds are implicit and, therefore, need to
- be adjusted. Morever, the debug info needs the unsigned version. */
+ be interpreted differently depending on the signedness. */
void
finish_character_type (tree char_type)
@@ -1639,11 +1657,32 @@ finish_character_type (tree char_type)
? unsigned_char_type_node
: copy_type (gnat_unsigned_type_for (char_type)));
+ /* Create an unsigned version of the type and set it as debug type. */
TYPE_NAME (unsigned_char_type) = TYPE_NAME (char_type);
TYPE_STRING_FLAG (unsigned_char_type) = TYPE_STRING_FLAG (char_type);
TYPE_ARTIFICIAL (unsigned_char_type) = TYPE_ARTIFICIAL (char_type);
-
SET_TYPE_DEBUG_TYPE (char_type, unsigned_char_type);
+
+ /* If this is a subtype, make the debug type a subtype of the debug type
+ of the base type and convert literal RM bounds to unsigned. */
+ if (TREE_TYPE (char_type))
+ {
+ tree base_unsigned_char_type = TYPE_DEBUG_TYPE (TREE_TYPE (char_type));
+ tree min_value = TYPE_RM_MIN_VALUE (char_type);
+ tree max_value = TYPE_RM_MAX_VALUE (char_type);
+
+ if (TREE_CODE (min_value) == INTEGER_CST)
+ min_value = fold_convert (base_unsigned_char_type, min_value);
+ if (TREE_CODE (max_value) == INTEGER_CST)
+ max_value = fold_convert (base_unsigned_char_type, max_value);
+
+ TREE_TYPE (unsigned_char_type) = base_unsigned_char_type;
+ SET_TYPE_RM_MIN_VALUE (unsigned_char_type, min_value);
+ SET_TYPE_RM_MAX_VALUE (unsigned_char_type, max_value);
+ }
+
+ /* Adjust the RM bounds of the original type to unsigned; that's especially
+ important for types since they are implicit in this case. */
SET_TYPE_RM_MIN_VALUE (char_type, TYPE_MIN_VALUE (unsigned_char_type));
SET_TYPE_RM_MAX_VALUE (char_type, TYPE_MAX_VALUE (unsigned_char_type));
}
@@ -1656,7 +1695,7 @@ finish_fat_pointer_type (tree record_type, tree field_list)
{
/* Make sure we can put it into a register. */
if (STRICT_ALIGNMENT)
- TYPE_ALIGN (record_type) = MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE);
+ SET_TYPE_ALIGN (record_type, MIN (BIGGEST_ALIGNMENT, 2 * POINTER_SIZE));
/* Show what it really is. */
TYPE_FAT_POINTER_P (record_type) = 1;
@@ -1678,7 +1717,7 @@ finish_fat_pointer_type (tree record_type, tree field_list)
laid out already; only set the sizes and alignment. If REP_LEVEL is two,
this record is derived from a parent record and thus inherits its layout;
only make a pass on the fields to finalize them. DEBUG_INFO_P is true if
- we need to write debug information about this type. */
+ additional debug info needs to be output for this type. */
void
finish_record_type (tree record_type, tree field_list, int rep_level,
@@ -1703,7 +1742,8 @@ finish_record_type (tree record_type, tree field_list, int rep_level,
that just means some initializations; otherwise, layout the record. */
if (rep_level > 0)
{
- TYPE_ALIGN (record_type) = MAX (BITS_PER_UNIT, TYPE_ALIGN (record_type));
+ SET_TYPE_ALIGN (record_type, MAX (BITS_PER_UNIT,
+ TYPE_ALIGN (record_type)));
if (!had_size_unit)
TYPE_SIZE_UNIT (record_type) = size_zero_node;
@@ -1781,7 +1821,7 @@ finish_record_type (tree record_type, tree field_list, int rep_level,
maximum alignment, if any. */
if (TYPE_ALIGN (record_type) >= align)
{
- DECL_ALIGN (field) = MAX (DECL_ALIGN (field), align);
+ SET_DECL_ALIGN (field, MAX (DECL_ALIGN (field), align));
DECL_BIT_FIELD (field) = 0;
}
else if (!had_align
@@ -1790,8 +1830,8 @@ finish_record_type (tree record_type, tree field_list, int rep_level,
&& (!TYPE_MAX_ALIGN (record_type)
|| TYPE_MAX_ALIGN (record_type) >= align))
{
- TYPE_ALIGN (record_type) = align;
- DECL_ALIGN (field) = MAX (DECL_ALIGN (field), align);
+ SET_TYPE_ALIGN (record_type, align);
+ SET_DECL_ALIGN (field, MAX (DECL_ALIGN (field), align));
DECL_BIT_FIELD (field) = 0;
}
}
@@ -1814,8 +1854,8 @@ finish_record_type (tree record_type, tree field_list, int rep_level,
/* A type must be as aligned as its most aligned field that is not
a bit-field. But this is already enforced by layout_type. */
if (rep_level > 0 && !DECL_BIT_FIELD (field))
- TYPE_ALIGN (record_type)
- = MAX (TYPE_ALIGN (record_type), DECL_ALIGN (field));
+ SET_TYPE_ALIGN (record_type,
+ MAX (TYPE_ALIGN (record_type), DECL_ALIGN (field)));
switch (code)
{
@@ -1932,10 +1972,9 @@ has_parallel_type (tree type)
return DECL_PARALLEL_TYPE (decl) != NULL_TREE;
}
-/* Wrap up compilation of RECORD_TYPE, i.e. output all the debug information
- associated with it. It need not be invoked directly in most cases since
- finish_record_type takes care of doing so, but this can be necessary if
- a parallel type is to be attached to the record type. */
+/* Wrap up compilation of RECORD_TYPE, i.e. output additional debug info
+ associated with it. It need not be invoked directly in most cases as
+ finish_record_type takes care of doing so. */
void
rest_of_record_type_compilation (tree record_type)
@@ -1986,7 +2025,7 @@ rest_of_record_type_compilation (tree record_type)
= concat_name (orig_name, TREE_CODE (record_type) == QUAL_UNION_TYPE
? "XVU" : "XVE");
TYPE_NAME (new_record_type) = new_name;
- TYPE_ALIGN (new_record_type) = BIGGEST_ALIGNMENT;
+ SET_TYPE_ALIGN (new_record_type, BIGGEST_ALIGNMENT);
TYPE_STUB_DECL (new_record_type)
= create_type_stub_decl (new_name, new_record_type);
DECL_IGNORED_P (TYPE_STUB_DECL (new_record_type))
@@ -2003,15 +2042,11 @@ rest_of_record_type_compilation (tree record_type)
{
tree field_type = TREE_TYPE (old_field);
tree field_name = DECL_NAME (old_field);
- tree curpos = bit_position (old_field);
+ tree curpos = fold_bit_position (old_field);
tree pos, new_field;
bool var = false;
unsigned int align = 0;
- /* We're going to do some pattern matching below so remove as many
- conversions as possible. */
- curpos = remove_conversions (curpos, true);
-
/* See how the position was modified from the last position.
There are two basic cases we support: a value was added
@@ -2077,8 +2112,8 @@ rest_of_record_type_compilation (tree record_type)
field_type = build_pointer_type (field_type);
if (align != 0 && TYPE_ALIGN (field_type) > align)
{
- field_type = copy_node (field_type);
- TYPE_ALIGN (field_type) = align;
+ field_type = copy_type (field_type);
+ SET_TYPE_ALIGN (field_type, align);
}
var = true;
}
@@ -2108,7 +2143,7 @@ rest_of_record_type_compilation (tree record_type)
is when there are other components at fixed positions after
it (meaning there was a rep clause for every field) and we
want to be able to encode them. */
- last_pos = size_binop (PLUS_EXPR, bit_position (old_field),
+ last_pos = size_binop (PLUS_EXPR, curpos,
(TREE_CODE (TREE_TYPE (old_field))
== QUAL_UNION_TYPE)
? bitsize_zero_node
@@ -2163,23 +2198,51 @@ merge_sizes (tree last_size, tree first_bit, tree size, bool special,
return new_size;
}
+/* Return the bit position of FIELD, in bits from the start of the record,
+ and fold it as much as possible. This is a tree of type bitsizetype. */
+
+static tree
+fold_bit_position (const_tree field)
+{
+ tree offset = DECL_FIELD_OFFSET (field);
+ if (TREE_CODE (offset) == MULT_EXPR || TREE_CODE (offset) == PLUS_EXPR)
+ offset = size_binop (TREE_CODE (offset),
+ fold_convert (bitsizetype, TREE_OPERAND (offset, 0)),
+ fold_convert (bitsizetype, TREE_OPERAND (offset, 1)));
+ else
+ offset = fold_convert (bitsizetype, offset);
+ return size_binop (PLUS_EXPR, DECL_FIELD_BIT_OFFSET (field),
+ size_binop (MULT_EXPR, offset, bitsize_unit_node));
+}
+
/* Utility function of above to see if OP0 and OP1, both of SIZETYPE, are
related by the addition of a constant. Return that constant if so. */
static tree
compute_related_constant (tree op0, tree op1)
{
- tree op0_var, op1_var;
- tree op0_con = split_plus (op0, &op0_var);
- tree op1_con = split_plus (op1, &op1_var);
- tree result = size_binop (MINUS_EXPR, op0_con, op1_con);
+ tree factor, op0_var, op1_var, op0_cst, op1_cst, result;
- if (operand_equal_p (op0_var, op1_var, 0))
- return result;
- else if (operand_equal_p (op0, size_binop (PLUS_EXPR, op1_var, result), 0))
- return result;
+ if (TREE_CODE (op0) == MULT_EXPR
+ && TREE_CODE (op1) == MULT_EXPR
+ && TREE_CODE (TREE_OPERAND (op0, 1)) == INTEGER_CST
+ && TREE_OPERAND (op1, 1) == TREE_OPERAND (op0, 1))
+ {
+ factor = TREE_OPERAND (op0, 1);
+ op0 = TREE_OPERAND (op0, 0);
+ op1 = TREE_OPERAND (op1, 0);
+ }
else
- return 0;
+ factor = NULL_TREE;
+
+ op0_cst = split_plus (op0, &op0_var);
+ op1_cst = split_plus (op1, &op1_var);
+ result = size_binop (MINUS_EXPR, op0_cst, op1_cst);
+
+ if (operand_equal_p (op0_var, op1_var, 0))
+ return factor ? size_binop (MULT_EXPR, factor, result) : result;
+
+ return NULL_TREE;
}
/* Utility function of above to split a tree OP which may be a sum, into a
@@ -2220,47 +2283,6 @@ split_plus (tree in, tree *pvar)
return bitsize_zero_node;
}
-/* Return a FUNCTION_TYPE node. RETURN_TYPE is the type returned by the
- subprogram. If it is VOID_TYPE, then we are dealing with a procedure,
- otherwise we are dealing with a function. PARAM_DECL_LIST is a list of
- PARM_DECL nodes that are the subprogram parameters. CICO_LIST is the
- copy-in/copy-out list to be stored into the TYPE_CICO_LIST field.
- RETURN_UNCONSTRAINED_P is true if the function returns an unconstrained
- object. RETURN_BY_DIRECT_REF_P is true if the function returns by direct
- reference. RETURN_BY_INVISI_REF_P is true if the function returns by
- invisible reference. */
-
-tree
-create_subprog_type (tree return_type, tree param_decl_list, tree cico_list,
- bool return_unconstrained_p, bool return_by_direct_ref_p,
- bool return_by_invisi_ref_p)
-{
- /* A list of the data type nodes of the subprogram formal parameters.
- This list is generated by traversing the input list of PARM_DECL
- nodes. */
- vec<tree, va_gc> *param_type_list = NULL;
- tree t, type;
-
- for (t = param_decl_list; t; t = DECL_CHAIN (t))
- vec_safe_push (param_type_list, TREE_TYPE (t));
-
- type = build_function_type_vec (return_type, param_type_list);
-
- /* TYPE may have been shared since GCC hashes types. If it has a different
- CICO_LIST, make a copy. Likewise for the various flags. */
- if (!fntype_same_flags_p (type, cico_list, return_unconstrained_p,
- return_by_direct_ref_p, return_by_invisi_ref_p))
- {
- type = copy_type (type);
- TYPE_CI_CO_LIST (type) = cico_list;
- TYPE_RETURN_UNCONSTRAINED_P (type) = return_unconstrained_p;
- TYPE_RETURN_BY_DIRECT_REF_P (type) = return_by_direct_ref_p;
- TREE_ADDRESSABLE (type) = return_by_invisi_ref_p;
- }
-
- return type;
-}
-
/* Return a copy of TYPE but safe to modify in any way. */
tree
@@ -2289,10 +2311,10 @@ copy_type (tree type)
aliased with TREE_CHAIN. */
TYPE_STUB_DECL (new_type) = TYPE_STUB_DECL (type);
- TYPE_POINTER_TO (new_type) = 0;
- TYPE_REFERENCE_TO (new_type) = 0;
+ TYPE_POINTER_TO (new_type) = NULL_TREE;
+ TYPE_REFERENCE_TO (new_type) = NULL_TREE;
TYPE_MAIN_VARIANT (new_type) = new_type;
- TYPE_NEXT_VARIANT (new_type) = 0;
+ TYPE_NEXT_VARIANT (new_type) = NULL_TREE;
TYPE_CANONICAL (new_type) = new_type;
return new_type;
@@ -2468,8 +2490,9 @@ create_var_decl (tree name, tree asm_name, tree type, tree init,
and may be used for scalars in general but not for aggregates. */
tree var_decl
= build_decl (input_location,
- (constant_p && const_decl_allowed_p
- && !AGGREGATE_TYPE_P (type)) ? CONST_DECL : VAR_DECL,
+ (constant_p
+ && const_decl_allowed_p
+ && !AGGREGATE_TYPE_P (type) ? CONST_DECL : VAR_DECL),
name, type);
/* Detect constants created by the front-end to hold 'reference to function
@@ -2626,7 +2649,7 @@ create_field_decl (tree name, tree type, tree record_type, tree size, tree pos,
|| (!pos
&& AGGREGATE_TYPE_P (type)
&& aggregate_type_contains_array_p (type))))
- DECL_ALIGN (field_decl) = BITS_PER_UNIT;
+ SET_DECL_ALIGN (field_decl, BITS_PER_UNIT);
/* If a size is specified, use it. Otherwise, if the record type is packed
compute a size to use, which may differ from the object's natural size.
@@ -2673,9 +2696,9 @@ create_field_decl (tree name, tree type, tree record_type, tree size, tree pos,
{
if (TYPE_ALIGN (record_type) != 0
&& TYPE_ALIGN (record_type) < TYPE_ALIGN (type))
- DECL_ALIGN (field_decl) = TYPE_ALIGN (record_type);
+ SET_DECL_ALIGN (field_decl, TYPE_ALIGN (record_type));
else
- DECL_ALIGN (field_decl) = TYPE_ALIGN (type);
+ SET_DECL_ALIGN (field_decl, TYPE_ALIGN (type));
}
}
@@ -2691,10 +2714,10 @@ create_field_decl (tree name, tree type, tree record_type, tree size, tree pos,
: packed && TYPE_MODE (type) != BLKmode ? BITS_PER_UNIT : 0);
if (bit_align > DECL_ALIGN (field_decl))
- DECL_ALIGN (field_decl) = bit_align;
+ SET_DECL_ALIGN (field_decl, bit_align);
else if (!bit_align && TYPE_ALIGN (type) > DECL_ALIGN (field_decl))
{
- DECL_ALIGN (field_decl) = TYPE_ALIGN (type);
+ SET_DECL_ALIGN (field_decl, TYPE_ALIGN (type));
DECL_USER_ALIGN (field_decl) = TYPE_USER_ALIGN (type);
}
}
@@ -2741,12 +2764,10 @@ create_field_decl (tree name, tree type, tree record_type, tree size, tree pos,
return field_decl;
}
-/* Return a PARM_DECL node. NAME is the name of the parameter and TYPE is
- its type. READONLY is true if the parameter is readonly (either an In
- parameter or an address of a pass-by-ref parameter). */
+/* Return a PARM_DECL node with NAME and TYPE. */
tree
-create_param_decl (tree name, tree type, bool readonly)
+create_param_decl (tree name, tree type)
{
tree param_decl = build_decl (input_location, PARM_DECL, name, type);
@@ -2774,7 +2795,6 @@ create_param_decl (tree name, tree type, bool readonly)
}
DECL_ARG_TYPE (param_decl) = type;
- TREE_READONLY (param_decl) = readonly;
return param_decl;
}
@@ -3135,7 +3155,7 @@ create_label_decl (tree name, Node_Id gnat_node)
tree label_decl
= build_decl (input_location, LABEL_DECL, name, void_type_node);
- DECL_MODE (label_decl) = VOIDmode;
+ SET_DECL_MODE (label_decl, VOIDmode);
/* Add this decl to the current binding level. */
gnat_pushdecl (label_decl, gnat_node);
@@ -3150,8 +3170,10 @@ create_label_decl (tree name, Node_Id gnat_node)
INLINE_STATUS describes the inline flags to be set on the FUNCTION_DECL.
- CONST_FLAG, PUBLIC_FLAG, EXTERN_FLAG, VOLATILE_FLAG are used to set the
- appropriate flags on the FUNCTION_DECL.
+ PUBLIC_FLAG is true if this is for a reference to a public entity or for a
+ definition to be made visible outside of the current compilation unit.
+
+ EXTERN_FLAG is true when processing an external subprogram declaration.
ARTIFICIAL_P is true if the subprogram was generated by the compiler.
@@ -3163,18 +3185,19 @@ create_label_decl (tree name, Node_Id gnat_node)
tree
create_subprog_decl (tree name, tree asm_name, tree type, tree param_decl_list,
- enum inline_status_t inline_status, bool const_flag,
- bool public_flag, bool extern_flag, bool volatile_flag,
- bool artificial_p, bool debug_info_p,
+ enum inline_status_t inline_status, bool public_flag,
+ bool extern_flag, bool artificial_p, bool debug_info_p,
struct attrib *attr_list, Node_Id gnat_node)
{
tree subprog_decl = build_decl (input_location, FUNCTION_DECL, name, type);
- tree result_decl
- = build_decl (input_location, RESULT_DECL, NULL_TREE, TREE_TYPE (type));
DECL_ARGUMENTS (subprog_decl) = param_decl_list;
DECL_ARTIFICIAL (subprog_decl) = artificial_p;
DECL_EXTERNAL (subprog_decl) = extern_flag;
+ TREE_PUBLIC (subprog_decl) = public_flag;
+
+ if (!debug_info_p)
+ DECL_IGNORED_P (subprog_decl) = 1;
switch (inline_status)
{
@@ -3203,32 +3226,45 @@ create_subprog_decl (tree name, tree asm_name, tree type, tree param_decl_list,
gcc_unreachable ();
}
- if (!debug_info_p)
- DECL_IGNORED_P (subprog_decl) = 1;
+ process_attributes (&subprog_decl, &attr_list, true, gnat_node);
- TREE_READONLY (subprog_decl) = TYPE_READONLY (type) | const_flag;
- TREE_PUBLIC (subprog_decl) = public_flag;
- TREE_SIDE_EFFECTS (subprog_decl)
- = TREE_THIS_VOLATILE (subprog_decl)
- = TYPE_VOLATILE (type) | volatile_flag;
+ /* Once everything is processed, finish the subprogram declaration. */
+ finish_subprog_decl (subprog_decl, asm_name, type);
+
+ /* Add this decl to the current binding level. */
+ gnat_pushdecl (subprog_decl, gnat_node);
+
+ /* Output the assembler code and/or RTL for the declaration. */
+ rest_of_decl_compilation (subprog_decl, global_bindings_p (), 0);
+
+ return subprog_decl;
+}
+
+/* Given a subprogram declaration DECL, its assembler name and its type,
+ finish constructing the subprogram declaration from ASM_NAME and TYPE. */
+
+void
+finish_subprog_decl (tree decl, tree asm_name, tree type)
+{
+ tree result_decl
+ = build_decl (DECL_SOURCE_LOCATION (decl), RESULT_DECL, NULL_TREE,
+ TREE_TYPE (type));
DECL_ARTIFICIAL (result_decl) = 1;
DECL_IGNORED_P (result_decl) = 1;
DECL_BY_REFERENCE (result_decl) = TREE_ADDRESSABLE (type);
- DECL_RESULT (subprog_decl) = result_decl;
+ DECL_RESULT (decl) = result_decl;
- process_attributes (&subprog_decl, &attr_list, true, gnat_node);
-
- /* Add this decl to the current binding level. */
- gnat_pushdecl (subprog_decl, gnat_node);
+ TREE_READONLY (decl) = TYPE_READONLY (type);
+ TREE_SIDE_EFFECTS (decl) = TREE_THIS_VOLATILE (decl) = TYPE_VOLATILE (type);
if (asm_name)
{
/* Let the target mangle the name if this isn't a verbatim asm. */
if (*IDENTIFIER_POINTER (asm_name) != '*')
- asm_name = targetm.mangle_decl_assembler_name (subprog_decl, asm_name);
+ asm_name = targetm.mangle_decl_assembler_name (decl, asm_name);
- SET_DECL_ASSEMBLER_NAME (subprog_decl, asm_name);
+ SET_DECL_ASSEMBLER_NAME (decl, asm_name);
/* The expand_main_function circuitry expects "main_identifier_node" to
designate the DECL_NAME of the 'main' entry point, in turn expected
@@ -3237,13 +3273,8 @@ create_subprog_decl (tree name, tree asm_name, tree type, tree param_decl_list,
within the binder generated file, exported as 'main' to satisfy the
system expectations. Force main_identifier_node in this case. */
if (asm_name == main_identifier_node)
- DECL_NAME (subprog_decl) = main_identifier_node;
+ DECL_NAME (decl) = main_identifier_node;
}
-
- /* Output the assembler code and/or RTL for the declaration. */
- rest_of_decl_compilation (subprog_decl, global_bindings_p (), 0);
-
- return subprog_decl;
}
/* Set up the framework for generating code for SUBPROG_DECL, a subprogram
@@ -3436,14 +3467,14 @@ gnat_signed_or_unsigned_type_for (int unsignedp, tree type_node)
if (TREE_CODE (type_node) == INTEGER_TYPE && TYPE_MODULAR_P (type_node))
{
- type = copy_node (type);
+ type = copy_type (type);
TREE_TYPE (type) = type_node;
}
else if (TREE_TYPE (type_node)
&& TREE_CODE (TREE_TYPE (type_node)) == INTEGER_TYPE
&& TYPE_MODULAR_P (TREE_TYPE (type_node)))
{
- type = copy_node (type);
+ type = copy_type (type);
TREE_TYPE (type) = TREE_TYPE (type_node);
}
@@ -3528,6 +3559,7 @@ max_size (tree exp, bool max_p)
{
enum tree_code code = TREE_CODE (exp);
tree type = TREE_TYPE (exp);
+ tree op0, op1, op2;
switch (TREE_CODE_CLASS (code))
{
@@ -3561,21 +3593,27 @@ max_size (tree exp, bool max_p)
{
tree val_type = TREE_TYPE (TREE_OPERAND (exp, 1));
tree val = (max_p ? TYPE_MAX_VALUE (type) : TYPE_MIN_VALUE (type));
- return max_size (convert (get_base_type (val_type), val), true);
+ return
+ convert (type,
+ max_size (convert (get_base_type (val_type), val), true));
}
return exp;
case tcc_comparison:
- return max_p ? size_one_node : size_zero_node;
+ return build_int_cst (type, max_p ? 1 : 0);
case tcc_unary:
if (code == NON_LVALUE_EXPR)
return max_size (TREE_OPERAND (exp, 0), max_p);
- return fold_build1 (code, type,
- max_size (TREE_OPERAND (exp, 0),
- code == NEGATE_EXPR ? !max_p : max_p));
+ op0 = max_size (TREE_OPERAND (exp, 0),
+ code == NEGATE_EXPR ? !max_p : max_p);
+
+ if (op0 == TREE_OPERAND (exp, 0))
+ return exp;
+
+ return fold_build1 (code, type, op0);
case tcc_binary:
{
@@ -3615,6 +3653,9 @@ max_size (tree exp, bool max_p)
code = PLUS_EXPR;
}
+ if (lhs == TREE_OPERAND (exp, 0) && rhs == TREE_OPERAND (exp, 1))
+ return exp;
+
/* We need to detect overflows so we call size_binop here. */
return size_binop (code, lhs, rhs);
}
@@ -3626,22 +3667,40 @@ max_size (tree exp, bool max_p)
if (code == SAVE_EXPR)
return exp;
- return fold_build1 (code, type,
- max_size (TREE_OPERAND (exp, 0), max_p));
+ op0 = max_size (TREE_OPERAND (exp, 0),
+ code == TRUTH_NOT_EXPR ? !max_p : max_p);
+
+ if (op0 == TREE_OPERAND (exp, 0))
+ return exp;
+
+ return fold_build1 (code, type, op0);
case 2:
if (code == COMPOUND_EXPR)
return max_size (TREE_OPERAND (exp, 1), max_p);
- return fold_build2 (code, type,
- max_size (TREE_OPERAND (exp, 0), max_p),
- max_size (TREE_OPERAND (exp, 1), max_p));
+ op0 = max_size (TREE_OPERAND (exp, 0), max_p);
+ op1 = max_size (TREE_OPERAND (exp, 1), max_p);
+
+ if (op0 == TREE_OPERAND (exp, 0) && op1 == TREE_OPERAND (exp, 1))
+ return exp;
+
+ return fold_build2 (code, type, op0, op1);
case 3:
if (code == COND_EXPR)
- return fold_build2 (max_p ? MAX_EXPR : MIN_EXPR, type,
- max_size (TREE_OPERAND (exp, 1), max_p),
- max_size (TREE_OPERAND (exp, 2), max_p));
+ {
+ op1 = TREE_OPERAND (exp, 1);
+ op2 = TREE_OPERAND (exp, 2);
+
+ if (!op1 || !op2)
+ return exp;
+
+ return
+ fold_build2 (max_p ? MAX_EXPR : MIN_EXPR, type,
+ max_size (op1, max_p), max_size (op2, max_p));
+ }
+ break;
default:
break;
@@ -3991,6 +4050,7 @@ update_pointer_to (tree old_type, tree new_type)
TYPE_OBJECT_RECORD_TYPE (new_type));
TYPE_POINTER_TO (old_type) = NULL_TREE;
+ TYPE_REFERENCE_TO (old_type) = NULL_TREE;
}
}
@@ -4210,12 +4270,15 @@ convert (tree type, tree expr)
return convert (type, unpadded);
}
- /* If the input is a biased type, adjust first. */
+ /* If the input is a biased type, convert first to the base type and add
+ the bias. Note that the bias must go through a full conversion to the
+ base type, lest it is itself a biased value; this happens for subtypes
+ of biased types. */
if (ecode == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (etype))
return convert (type, fold_build2 (PLUS_EXPR, TREE_TYPE (etype),
fold_convert (TREE_TYPE (etype), expr),
- fold_convert (TREE_TYPE (etype),
- TYPE_MIN_VALUE (etype))));
+ convert (TREE_TYPE (etype),
+ TYPE_MIN_VALUE (etype))));
/* If the input is a justified modular type, we need to extract the actual
object before converting it to any other type with the exceptions of an
@@ -4287,6 +4350,7 @@ convert (tree type, tree expr)
TREE_TYPE (expr) = type;
return expr;
}
+ break;
case CONSTRUCTOR:
/* If we are converting a CONSTRUCTOR to a mere type variant, or to
@@ -4518,7 +4582,12 @@ convert (tree type, tree expr)
&& (ecode == ARRAY_TYPE || ecode == UNCONSTRAINED_ARRAY_TYPE
|| (ecode == RECORD_TYPE && TYPE_CONTAINS_TEMPLATE_P (etype))))
return unchecked_convert (type, expr, false);
- else if (TYPE_BIASED_REPRESENTATION_P (type))
+
+ /* If the output is a biased type, convert first to the base type and
+ subtract the bias. Note that the bias itself must go through a full
+ conversion to the base type, lest it is a biased value; this happens
+ for subtypes of biased types. */
+ if (TYPE_BIASED_REPRESENTATION_P (type))
return fold_convert (type,
fold_build2 (MINUS_EXPR, TREE_TYPE (type),
convert (TREE_TYPE (type), expr),
@@ -4921,7 +4990,12 @@ can_fold_for_view_convert_p (tree expr)
we expect the 8 bits at Vbits'Address to always contain Value, while
their original location depends on the endianness, at Value'Address
- on a little-endian architecture but not on a big-endian one. */
+ on a little-endian architecture but not on a big-endian one.
+
+ One pitfall is that we cannot use TYPE_UNSIGNED directly to decide how
+ the bits between the precision and the size are filled, because of the
+ trick used in the E_Signed_Integer_Subtype case of gnat_to_gnu_entity.
+ So we use the special predicate type_unsigned_for_rm above. */
tree
unchecked_convert (tree type, tree expr, bool notrunc_p)
@@ -4999,7 +5073,7 @@ unchecked_convert (tree type, tree expr, bool notrunc_p)
TYPE_REVERSE_STORAGE_ORDER (rec_type)
= TYPE_REVERSE_STORAGE_ORDER (etype);
- if (TYPE_UNSIGNED (type))
+ if (type_unsigned_for_rm (type))
field_type = make_unsigned_type (prec);
else
field_type = make_signed_type (prec);
@@ -5038,7 +5112,7 @@ unchecked_convert (tree type, tree expr, bool notrunc_p)
TYPE_REVERSE_STORAGE_ORDER (rec_type)
= TYPE_REVERSE_STORAGE_ORDER (type);
- if (TYPE_UNSIGNED (etype))
+ if (type_unsigned_for_rm (etype))
field_type = make_unsigned_type (prec);
else
field_type = make_signed_type (prec);
@@ -5139,26 +5213,26 @@ unchecked_convert (tree type, tree expr, bool notrunc_p)
expr = build1 (VIEW_CONVERT_EXPR, type, expr);
}
- /* If the result is an integral type whose precision is not equal to its
- size, sign- or zero-extend the result. We need not do this if the input
- is an integral type of the same precision and signedness or if the output
- is a biased type or if both the input and output are unsigned. */
+ /* If the result is a non-biased integral type whose precision is not equal
+ to its size, sign- or zero-extend the result. But we need not do this
+ if the input is also an integral type and both are unsigned or both are
+ signed and have the same precision. */
if (!notrunc_p
&& INTEGRAL_TYPE_P (type)
+ && !(code == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (type))
&& TYPE_RM_SIZE (type)
&& tree_int_cst_compare (TYPE_RM_SIZE (type), TYPE_SIZE (type)) < 0
&& !(INTEGRAL_TYPE_P (etype)
- && TYPE_UNSIGNED (type) == TYPE_UNSIGNED (etype)
- && tree_int_cst_compare (TYPE_RM_SIZE (type),
- TYPE_RM_SIZE (etype)
- ? TYPE_RM_SIZE (etype)
- : TYPE_SIZE (etype)) == 0)
- && !(code == INTEGER_TYPE && TYPE_BIASED_REPRESENTATION_P (type))
- && !(TYPE_UNSIGNED (type) && TYPE_UNSIGNED (etype)))
+ && type_unsigned_for_rm (type) == type_unsigned_for_rm (etype)
+ && (type_unsigned_for_rm (type)
+ || tree_int_cst_compare (TYPE_RM_SIZE (type),
+ TYPE_RM_SIZE (etype)
+ ? TYPE_RM_SIZE (etype)
+ : TYPE_SIZE (etype)) == 0)))
{
tree base_type
= gnat_type_for_size (TREE_INT_CST_LOW (TYPE_SIZE (type)),
- TYPE_UNSIGNED (type));
+ type_unsigned_for_rm (type));
tree shift_expr
= convert (base_type,
size_binop (MINUS_EXPR,
@@ -5328,6 +5402,58 @@ smaller_form_type_p (tree type, tree orig_type)
return tree_int_cst_lt (size, osize) != 0;
}
+/* Return whether EXPR, which is the renamed object in an object renaming
+ declaration, can be materialized as a reference (with a REFERENCE_TYPE).
+ This should be synchronized with Exp_Dbug.Debug_Renaming_Declaration. */
+
+bool
+can_materialize_object_renaming_p (Node_Id expr)
+{
+ while (true)
+ {
+ switch Nkind (expr)
+ {
+ case N_Identifier:
+ case N_Expanded_Name:
+ return true;
+
+ case N_Selected_Component:
+ {
+ if (Is_Packed (Underlying_Type (Etype (Prefix (expr)))))
+ return false;
+
+ const Uint bitpos
+ = Normalized_First_Bit (Entity (Selector_Name (expr)));
+ if (!UI_Is_In_Int_Range (bitpos)
+ || (bitpos != UI_No_Uint && bitpos != UI_From_Int (0)))
+ return false;
+
+ expr = Prefix (expr);
+ break;
+ }
+
+ case N_Indexed_Component:
+ case N_Slice:
+ {
+ const Entity_Id t = Underlying_Type (Etype (Prefix (expr)));
+
+ if (Is_Array_Type (t) && Present (Packed_Array_Impl_Type (t)))
+ return false;
+
+ expr = Prefix (expr);
+ break;
+ }
+
+ case N_Explicit_Dereference:
+ expr = Prefix (expr);
+ break;
+
+ default:
+ return true;
+ };
+ }
+}
+
/* Perform final processing on global declarations. */
static GTY (()) tree dummy_global;
@@ -5456,15 +5582,6 @@ static tree c_global_trees[CTI_MAX];
#define intmax_type_node void_type_node
#define uintmax_type_node void_type_node
-/* Build the void_list_node (void_type_node having been created). */
-
-static tree
-build_void_list_node (void)
-{
- tree t = build_tree_list (NULL_TREE, void_type_node);
- return t;
-}
-
/* Used to help initialize the builtin-types.def table. When a type of
the correct size doesn't exist, use error_mark_node instead of NULL.
The later results in segfaults even when a decl using the type doesn't
@@ -5485,7 +5602,6 @@ install_builtin_elementary_types (void)
{
signed_size_type_node = gnat_signed_type_for (size_type_node);
pid_type_node = integer_type_node;
- void_list_node = build_void_list_node ();
string_type_node = build_pointer_type (char_type_node);
const_string_type_node
@@ -5844,10 +5960,14 @@ handle_nonnull_attribute (tree *node, tree ARG_UNUSED (name),
/* If no arguments are specified, all pointer arguments should be
non-null. Verify a full prototype is given so that the arguments
- will have the correct types when we actually check them later. */
+ will have the correct types when we actually check them later.
+ Avoid diagnosing type-generic built-ins since those have no
+ prototype. */
if (!args)
{
- if (!prototype_p (type))
+ if (!prototype_p (type)
+ && (!TYPE_ATTRIBUTES (type)
+ || !lookup_attribute ("type generic", TYPE_ATTRIBUTES (type))))
{
error ("nonnull attribute without arguments on a non-prototype");
*no_add_attrs = true;
diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c
index 6f05ee29bc..fc6f1b86bd 100644
--- a/gcc/ada/gcc-interface/utils2.c
+++ b/gcc/ada/gcc-interface/utils2.c
@@ -26,6 +26,7 @@
#include "config.h"
#include "system.h"
#include "coretypes.h"
+#include "memmodel.h"
#include "tm.h"
#include "vec.h"
#include "alias.h"
@@ -171,6 +172,10 @@ known_alignment (tree exp)
case CALL_EXPR:
{
+ tree fndecl = get_callee_fndecl (exp);
+ if (fndecl == malloc_decl || fndecl == realloc_decl)
+ return get_target_system_allocator_alignment () * BITS_PER_UNIT;
+
tree t = maybe_inline_call_in_expr (exp);
if (t)
return known_alignment (t);
@@ -184,7 +189,8 @@ known_alignment (tree exp)
have a dummy type here (e.g. a Taft Amendment type), for which the
alignment is meaningless and should be ignored. */
if (POINTER_TYPE_P (TREE_TYPE (exp))
- && !TYPE_IS_DUMMY_P (TREE_TYPE (TREE_TYPE (exp))))
+ && !TYPE_IS_DUMMY_P (TREE_TYPE (TREE_TYPE (exp)))
+ && !VOID_TYPE_P (TREE_TYPE (TREE_TYPE (exp))))
this_alignment = TYPE_ALIGN (TREE_TYPE (TREE_TYPE (exp)));
else
this_alignment = 0;
@@ -210,27 +216,40 @@ find_common_type (tree t1, tree t2)
calling into build_binary_op), some others are really expected and we
have to be careful. */
+ const bool variable_record_on_lhs
+ = (TREE_CODE (t1) == RECORD_TYPE
+ && TREE_CODE (t2) == RECORD_TYPE
+ && get_variant_part (t1)
+ && !get_variant_part (t2));
+
+ const bool variable_array_on_lhs
+ = (TREE_CODE (t1) == ARRAY_TYPE
+ && TREE_CODE (t2) == ARRAY_TYPE
+ && !TREE_CONSTANT (TYPE_MIN_VALUE (TYPE_DOMAIN (t1)))
+ && TREE_CONSTANT (TYPE_MIN_VALUE (TYPE_DOMAIN (t2))));
+
/* We must avoid writing more than what the target can hold if this is for
an assignment and the case of tagged types is handled in build_binary_op
so we use the lhs type if it is known to be smaller or of constant size
and the rhs type is not, whatever the modes. We also force t1 in case of
constant size equality to minimize occurrences of view conversions on the
- lhs of an assignment, except for the case of record types with a variant
- part on the lhs but not on the rhs to make the conversion simpler. */
+ lhs of an assignment, except for the case of types with a variable part
+ on the lhs but not on the rhs to make the conversion simpler. */
if (TREE_CONSTANT (TYPE_SIZE (t1))
&& (!TREE_CONSTANT (TYPE_SIZE (t2))
|| tree_int_cst_lt (TYPE_SIZE (t1), TYPE_SIZE (t2))
|| (TYPE_SIZE (t1) == TYPE_SIZE (t2)
- && !(TREE_CODE (t1) == RECORD_TYPE
- && TREE_CODE (t2) == RECORD_TYPE
- && get_variant_part (t1)
- && !get_variant_part (t2)))))
+ && !variable_record_on_lhs
+ && !variable_array_on_lhs)))
return t1;
- /* Otherwise, if the lhs type is non-BLKmode, use it. Note that we know
- that we will not have any alignment problems since, if we did, the
- non-BLKmode type could not have been used. */
- if (TYPE_MODE (t1) != BLKmode)
+ /* Otherwise, if the lhs type is non-BLKmode, use it, except for the case of
+ a non-BLKmode rhs and array types with a variable part on the lhs but not
+ on the rhs to make sure the conversion is preserved during gimplification.
+ Note that we know that we will not have any alignment problems since, if
+ we did, the non-BLKmode type could not have been used. */
+ if (TYPE_MODE (t1) != BLKmode
+ && (TYPE_MODE (t2) == BLKmode || !variable_array_on_lhs))
return t1;
/* If the rhs type is of constant size, use it whatever the modes. At
@@ -560,8 +579,8 @@ nonbinary_modular_operation (enum tree_code op_code, tree type, tree lhs,
if (TYPE_PRECISION (op_type) < precision
|| TYPE_UNSIGNED (op_type) != unsignedp)
{
- /* Copy the node so we ensure it can be modified to make it modular. */
- op_type = copy_node (gnat_type_for_size (precision, unsignedp));
+ /* Copy the type so we ensure it can be modified to make it modular. */
+ op_type = copy_type (gnat_type_for_size (precision, unsignedp));
modulus = convert (op_type, modulus);
SET_TYPE_MODULUS (op_type, modulus);
TYPE_MODULAR_P (op_type) = 1;
@@ -577,7 +596,8 @@ nonbinary_modular_operation (enum tree_code op_code, tree type, tree lhs,
possible size. */
if (op_code == MULT_EXPR)
{
- tree div_type = copy_node (gnat_type_for_size (needed_precision, 1));
+ /* Copy the type so we ensure it can be modified to make it modular. */
+ tree div_type = copy_type (gnat_type_for_size (needed_precision, 1));
modulus = convert (div_type, modulus);
SET_TYPE_MODULUS (div_type, modulus);
TYPE_MODULAR_P (div_type) = 1;
@@ -815,6 +835,7 @@ build_load_modify_store (tree dest, tree src, Node_Id gnat_node)
in that type. For INIT_EXPR and MODIFY_EXPR, RESULT_TYPE must be
NULL_TREE. For ARRAY_REF, RESULT_TYPE may be NULL_TREE, in which
case the type to be used will be derived from the operands.
+ Don't fold the result if NO_FOLD is true.
This function is very much unlike the ones for C and C++ since we
have already done any type conversion and matching required. All we
@@ -822,7 +843,8 @@ build_load_modify_store (tree dest, tree src, Node_Id gnat_node)
tree
build_binary_op (enum tree_code op_code, tree result_type,
- tree left_operand, tree right_operand)
+ tree left_operand, tree right_operand,
+ bool no_fold)
{
tree left_type = TREE_TYPE (left_operand);
tree right_type = TREE_TYPE (right_operand);
@@ -1264,10 +1286,16 @@ build_binary_op (enum tree_code op_code, tree result_type,
else if (TREE_CODE (right_operand) == NULL_EXPR)
return build1 (NULL_EXPR, operation_type, TREE_OPERAND (right_operand, 0));
else if (op_code == ARRAY_REF || op_code == ARRAY_RANGE_REF)
- result = fold (build4 (op_code, operation_type, left_operand,
- right_operand, NULL_TREE, NULL_TREE));
+ {
+ result = build4 (op_code, operation_type, left_operand, right_operand,
+ NULL_TREE, NULL_TREE);
+ if (!no_fold)
+ result = fold (result);
+ }
else if (op_code == INIT_EXPR || op_code == MODIFY_EXPR)
result = build2 (op_code, void_type_node, left_operand, right_operand);
+ else if (no_fold)
+ result = build2 (op_code, operation_type, left_operand, right_operand);
else
result
= fold_build2 (op_code, operation_type, left_operand, right_operand);
@@ -1288,8 +1316,13 @@ build_binary_op (enum tree_code op_code, tree result_type,
/* If we are working with modular types, perform the MOD operation
if something above hasn't eliminated the need for it. */
if (modulus)
- result = fold_build2 (FLOOR_MOD_EXPR, operation_type, result,
- convert (operation_type, modulus));
+ {
+ modulus = convert (operation_type, modulus);
+ if (no_fold)
+ result = build2 (FLOOR_MOD_EXPR, operation_type, result, modulus);
+ else
+ result = fold_build2 (FLOOR_MOD_EXPR, operation_type, result, modulus);
+ }
if (result_type && result_type != operation_type)
result = convert (result_type, result);
@@ -1413,7 +1446,7 @@ build_unary_op (enum tree_code op_code, tree result_type, tree operand)
inner = get_inner_reference (operand, &bitsize, &bitpos, &offset,
&mode, &unsignedp, &reversep,
- &volatilep, false);
+ &volatilep);
/* If INNER is a padding type whose field has a self-referential
size, convert to that inner type. We know the offset is zero
@@ -1761,9 +1794,10 @@ build_goto_raise (tree label, int msg)
/* If Local_Raise is present, build Local_Raise (Exception'Identity). */
if (Present (local_raise))
{
- tree gnu_local_raise = gnat_to_gnu_entity (local_raise, NULL_TREE, 0);
+ tree gnu_local_raise
+ = gnat_to_gnu_entity (local_raise, NULL_TREE, false);
tree gnu_exception_entity
- = gnat_to_gnu_entity (Get_RT_Exception_Entity (msg), NULL_TREE, 0);
+ = gnat_to_gnu_entity (Get_RT_Exception_Entity (msg), NULL_TREE, false);
tree gnu_call
= build_call_n_expr (gnu_local_raise, 1,
build_unary_op (ADDR_EXPR, NULL_TREE,
@@ -2506,7 +2540,7 @@ gnat_save_expr (tree exp)
if (code == COMPONENT_REF
&& TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (exp, 0))))
return build3 (code, type, gnat_save_expr (TREE_OPERAND (exp, 0)),
- TREE_OPERAND (exp, 1), TREE_OPERAND (exp, 2));
+ TREE_OPERAND (exp, 1), NULL_TREE);
return save_expr (exp);
}
@@ -2552,13 +2586,19 @@ gnat_protect_expr (tree exp)
return t;
}
+ /* Likewise if we're indirectly referencing part of something. */
+ if (code == COMPONENT_REF
+ && TREE_CODE (TREE_OPERAND (exp, 0)) == INDIRECT_REF)
+ return build3 (code, type, gnat_protect_expr (TREE_OPERAND (exp, 0)),
+ TREE_OPERAND (exp, 1), NULL_TREE);
+
/* If this is a COMPONENT_REF of a fat pointer, save the entire fat pointer.
This may be more efficient, but will also allow us to more easily find
the match for the PLACEHOLDER_EXPR. */
if (code == COMPONENT_REF
&& TYPE_IS_FAT_POINTER_P (TREE_TYPE (TREE_OPERAND (exp, 0))))
return build3 (code, type, gnat_protect_expr (TREE_OPERAND (exp, 0)),
- TREE_OPERAND (exp, 1), TREE_OPERAND (exp, 2));
+ TREE_OPERAND (exp, 1), NULL_TREE);
/* If this is a fat pointer or a scalar, just make a SAVE_EXPR. Likewise
for a CALL_EXPR as large objects are returned via invisible reference
@@ -2571,9 +2611,7 @@ gnat_protect_expr (tree exp)
/* Otherwise reference, protect the address and dereference. */
return
build_unary_op (INDIRECT_REF, type,
- save_expr (build_unary_op (ADDR_EXPR,
- build_reference_type (type),
- exp)));
+ save_expr (build_unary_op (ADDR_EXPR, NULL_TREE, exp)));
}
/* This is equivalent to stabilize_reference_1 in tree.c but we take an extra
@@ -2606,7 +2644,7 @@ gnat_stabilize_reference_1 (tree e, void *data)
result
= build3 (code, type,
gnat_stabilize_reference_1 (TREE_OPERAND (e, 0), data),
- TREE_OPERAND (e, 1), TREE_OPERAND (e, 2));
+ TREE_OPERAND (e, 1), NULL_TREE);
/* If the expression has side-effects, then encase it in a SAVE_EXPR
so that it will only be evaluated once. */
/* The tcc_reference and tcc_comparison classes could be handled as
@@ -2714,7 +2752,7 @@ gnat_rewrite_reference (tree ref, rewrite_fn func, void *data, tree *init)
gnat_rewrite_reference (TREE_OPERAND (ref, 0), func, data,
init),
func (TREE_OPERAND (ref, 1), data),
- TREE_OPERAND (ref, 2), TREE_OPERAND (ref, 3));
+ TREE_OPERAND (ref, 2), NULL_TREE);
break;
case COMPOUND_EXPR:
@@ -2792,9 +2830,6 @@ get_inner_constant_reference (tree exp)
break;
case COMPONENT_REF:
- if (TREE_OPERAND (exp, 2))
- return NULL_TREE;
-
if (!TREE_CONSTANT (DECL_FIELD_OFFSET (TREE_OPERAND (exp, 1))))
return NULL_TREE;
break;
@@ -2802,7 +2837,7 @@ get_inner_constant_reference (tree exp)
case ARRAY_REF:
case ARRAY_RANGE_REF:
{
- if (TREE_OPERAND (exp, 2) || TREE_OPERAND (exp, 3))
+ if (TREE_OPERAND (exp, 2))
return NULL_TREE;
tree array_type = TREE_TYPE (TREE_OPERAND (exp, 0));
@@ -2930,16 +2965,12 @@ gnat_invariant_expr (tree expr)
switch (TREE_CODE (t))
{
case COMPONENT_REF:
- if (TREE_OPERAND (t, 2))
- return NULL_TREE;
invariant_p |= DECL_INVARIANT_P (TREE_OPERAND (t, 1));
break;
case ARRAY_REF:
case ARRAY_RANGE_REF:
- if (!TREE_CONSTANT (TREE_OPERAND (t, 1))
- || TREE_OPERAND (t, 2)
- || TREE_OPERAND (t, 3))
+ if (!TREE_CONSTANT (TREE_OPERAND (t, 1)) || TREE_OPERAND (t, 2))
return NULL_TREE;
break;
diff --git a/gcc/ada/get_scos.adb b/gcc/ada/get_scos.adb
index 48c9c46321..79e0a95488 100644
--- a/gcc/ada/get_scos.adb
+++ b/gcc/ada/get_scos.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -304,7 +304,6 @@ begin
when others =>
raise Program_Error;
-
end case;
-- Statement entry
diff --git a/gcc/ada/get_spark_xrefs.adb b/gcc/ada/get_spark_xrefs.adb
index e0b58ce35d..9b82d5bfdd 100644
--- a/gcc/ada/get_spark_xrefs.adb
+++ b/gcc/ada/get_spark_xrefs.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -114,13 +114,10 @@ procedure Get_SPARK_Xrefs is
-------------
function Get_Nat return Nat is
- Val : Nat;
- C : Character;
+ C : Character := Nextc;
+ Val : Nat := 0;
begin
- C := Nextc;
- Val := 0;
-
if C not in '0' .. '9' then
raise Data_Error;
end if;
@@ -152,10 +149,9 @@ procedure Get_SPARK_Xrefs is
--------------
procedure Get_Name is
- N : Integer;
+ N : Natural := 0;
begin
- N := 0;
while Nextc > ' ' loop
N := N + 1;
Name_Str (N) := Getc;
@@ -416,7 +412,6 @@ begin
-- Loop through cross-references for this entity
loop
-
declare
Line : Nat;
Col : Nat;
diff --git a/gcc/ada/ghost.adb b/gcc/ada/ghost.adb
index f2ac16b542..ec4c1d646c 100644
--- a/gcc/ada/ghost.adb
+++ b/gcc/ada/ghost.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2014-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -33,9 +33,9 @@ with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
-with Opt; use Opt;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
+with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
with Sem_Prag; use Sem_Prag;
with Sem_Res; use Sem_Res;
@@ -64,20 +64,30 @@ package body Ghost is
-----------------------
function Ghost_Entity (N : Node_Id) return Entity_Id;
- -- Subsidiary to Check_Ghost_Context and Set_Ghost_Mode. Find the entity of
- -- a reference to a Ghost entity. Return Empty if there is no such entity.
+ -- Find the entity of a reference to a Ghost entity. Return Empty if there
+ -- is no such entity.
+
+ procedure Install_Ghost_Mode (Mode : Name_Id);
+ -- Install a specific Ghost mode denoted by Mode by setting global variable
+ -- Ghost_Mode.
function Is_Subject_To_Ghost (N : Node_Id) return Boolean;
- -- Subsidiary to routines Is_OK_xxx and Set_Ghost_Mode. Determine whether
- -- declaration or body N is subject to aspect or pragma Ghost. Use this
- -- routine in cases where [source] pragma Ghost has not been analyzed yet,
- -- but the context needs to establish the "ghostness" of N.
+ -- Determine whether declaration or body N is subject to aspect or pragma
+ -- Ghost. This routine must be used in cases where pragma Ghost has not
+ -- been analyzed yet, but the context needs to establish the "ghostness"
+ -- of N.
+
+ procedure Mark_Ghost_Declaration_Or_Body
+ (N : Node_Id;
+ Mode : Name_Id);
+ -- Mark the defining entity of declaration or body N as Ghost depending on
+ -- mode Mode. Mark all formals parameters when N denotes a subprogram or a
+ -- body.
procedure Propagate_Ignored_Ghost_Code (N : Node_Id);
- -- Subsidiary to routines Mark_xxx_As_Ghost and Set_Ghost_Mode_From_xxx.
- -- Signal all enclosing scopes that they now contain ignored Ghost code.
- -- Add the compilation unit containing N to table Ignored_Ghost_Units for
- -- post processing.
+ -- Signal all enclosing scopes that they now contain at least one ignored
+ -- Ghost node denoted by N. Add the compilation unit containing N to table
+ -- Ignored_Ghost_Units for post processing.
----------------------------
-- Add_Ignored_Ghost_Unit --
@@ -111,34 +121,37 @@ package body Ghost is
----------------------------
procedure Check_Ghost_Completion
- (Partial_View : Entity_Id;
- Full_View : Entity_Id)
+ (Prev_Id : Entity_Id;
+ Compl_Id : Entity_Id)
is
Policy : constant Name_Id := Policy_In_Effect (Name_Ghost);
begin
+ -- Nothing to do if one of the views is missing
+
+ if No (Prev_Id) or else No (Compl_Id) then
+ null;
+
-- The Ghost policy in effect at the point of declaration and at the
-- point of completion must match (SPARK RM 6.9(14)).
- if Is_Checked_Ghost_Entity (Partial_View)
+ elsif Is_Checked_Ghost_Entity (Prev_Id)
and then Policy = Name_Ignore
then
- Error_Msg_Sloc := Sloc (Full_View);
+ Error_Msg_Sloc := Sloc (Compl_Id);
- Error_Msg_N ("incompatible ghost policies in effect", Partial_View);
- Error_Msg_N ("\& declared with ghost policy `Check`", Partial_View);
- Error_Msg_N ("\& completed # with ghost policy `Ignore`",
- Partial_View);
+ Error_Msg_N ("incompatible ghost policies in effect", Prev_Id);
+ Error_Msg_N ("\& declared with ghost policy `Check`", Prev_Id);
+ Error_Msg_N ("\& completed # with ghost policy `Ignore`", Prev_Id);
- elsif Is_Ignored_Ghost_Entity (Partial_View)
+ elsif Is_Ignored_Ghost_Entity (Prev_Id)
and then Policy = Name_Check
then
- Error_Msg_Sloc := Sloc (Full_View);
+ Error_Msg_Sloc := Sloc (Compl_Id);
- Error_Msg_N ("incompatible ghost policies in effect", Partial_View);
- Error_Msg_N ("\& declared with ghost policy `Ignore`", Partial_View);
- Error_Msg_N ("\& completed # with ghost policy `Check`",
- Partial_View);
+ Error_Msg_N ("incompatible ghost policies in effect", Prev_Id);
+ Error_Msg_N ("\& declared with ghost policy `Ignore`", Prev_Id);
+ Error_Msg_N ("\& completed # with ghost policy `Check`", Prev_Id);
end if;
end Check_Ghost_Completion;
@@ -147,14 +160,14 @@ package body Ghost is
-------------------------
procedure Check_Ghost_Context (Ghost_Id : Entity_Id; Ghost_Ref : Node_Id) is
- procedure Check_Ghost_Policy (Id : Entity_Id; Err_N : Node_Id);
+ procedure Check_Ghost_Policy (Id : Entity_Id; Ref : Node_Id);
-- Verify that the Ghost policy at the point of declaration of entity Id
- -- matches the policy at the point of reference. If this is not the case
- -- emit an error at Err_N.
+ -- matches the policy at the point of reference Ref. If this is not the
+ -- case emit an error at Ref.
function Is_OK_Ghost_Context (Context : Node_Id) return Boolean;
-- Determine whether node Context denotes a Ghost-friendly context where
- -- a Ghost entity can safely reside.
+ -- a Ghost entity can safely reside (SPARK RM 6.9(10)).
-------------------------
-- Is_OK_Ghost_Context --
@@ -164,49 +177,60 @@ package body Ghost is
function Is_OK_Declaration (Decl : Node_Id) return Boolean;
-- Determine whether node Decl is a suitable context for a reference
-- to a Ghost entity. To qualify as such, Decl must either
- -- 1) Be subject to pragma Ghost
- -- 2) Rename a Ghost entity
+ --
+ -- * Define a Ghost entity
+ --
+ -- * Be subject to pragma Ghost
function Is_OK_Pragma (Prag : Node_Id) return Boolean;
-- Determine whether node Prag is a suitable context for a reference
-- to a Ghost entity. To qualify as such, Prag must either
- -- 1) Be an assertion expression pragma
- -- 2) Denote pragma Global, Depends, Initializes, Refined_Global,
- -- Refined_Depends or Refined_State
- -- 3) Specify an aspect of a Ghost entity
- -- 4) Contain a reference to a Ghost entity
+ --
+ -- * Be an assertion expression pragma
+ --
+ -- * Denote pragma Global, Depends, Initializes, Refined_Global,
+ -- Refined_Depends or Refined_State.
+ --
+ -- * Specify an aspect of a Ghost entity
+ --
+ -- * Contain a reference to a Ghost entity
function Is_OK_Statement (Stmt : Node_Id) return Boolean;
-- Determine whether node Stmt is a suitable context for a reference
-- to a Ghost entity. To qualify as such, Stmt must either
- -- 1) Denote a call to a Ghost procedure
- -- 2) Denote an assignment statement whose target is Ghost
+ --
+ -- * Denote a procedure call to a Ghost procedure
+ --
+ -- * Denote an assignment statement whose target is Ghost
-----------------------
-- Is_OK_Declaration --
-----------------------
function Is_OK_Declaration (Decl : Node_Id) return Boolean is
- function Is_Ghost_Renaming (Ren_Decl : Node_Id) return Boolean;
- -- Determine whether node Ren_Decl denotes a renaming declaration
- -- with a Ghost name.
+ function In_Subprogram_Body_Profile (N : Node_Id) return Boolean;
+ -- Determine whether node N appears in the profile of a subprogram
+ -- body.
- -----------------------
- -- Is_Ghost_Renaming --
- -----------------------
+ --------------------------------
+ -- In_Subprogram_Body_Profile --
+ --------------------------------
- function Is_Ghost_Renaming (Ren_Decl : Node_Id) return Boolean is
- Nam_Id : Entity_Id;
+ function In_Subprogram_Body_Profile (N : Node_Id) return Boolean is
+ Spec : constant Node_Id := Parent (N);
begin
- if Is_Renaming_Declaration (Ren_Decl) then
- Nam_Id := Ghost_Entity (Name (Ren_Decl));
-
- return Present (Nam_Id) and then Is_Ghost_Entity (Nam_Id);
- end if;
-
- return False;
- end Is_Ghost_Renaming;
+ -- The node appears in a parameter specification in which case
+ -- it is either the parameter type or the default expression or
+ -- the node appears as the result definition of a function.
+
+ return
+ (Nkind (N) = N_Parameter_Specification
+ or else
+ (Nkind (Spec) = N_Function_Specification
+ and then N = Result_Definition (Spec)))
+ and then Nkind (Parent (Spec)) = N_Subprogram_Body;
+ end In_Subprogram_Body_Profile;
-- Local variables
@@ -216,32 +240,27 @@ package body Ghost is
-- Start of processing for Is_OK_Declaration
begin
- if Is_Declaration (Decl) then
-
- -- A renaming declaration is Ghost when it renames a Ghost
- -- entity.
+ if Is_Ghost_Declaration (Decl) then
+ return True;
- if Is_Ghost_Renaming (Decl) then
- return True;
+ -- Special cases
- -- The declaration may not have been analyzed yet, determine
- -- whether it is subject to pragma Ghost.
+ -- A reference to a Ghost entity may appear within the profile of
+ -- a subprogram body. This context is treated as suitable because
+ -- it duplicates the context of the corresponding spec. The real
+ -- check was already performed during the analysis of the spec.
- elsif Is_Subject_To_Ghost (Decl) then
- return True;
- end if;
-
- -- Special cases
+ elsif In_Subprogram_Body_Profile (Decl) then
+ return True;
- -- A reference to a Ghost entity may appear as the default
- -- expression of a formal parameter of a subprogram body. This
- -- context must be treated as suitable because the relation
- -- between the spec and the body has not been established and
- -- the body is not marked as Ghost yet. The real check was
- -- performed on the spec.
+ -- A reference to a Ghost entity may appear within an expression
+ -- function which is still being analyzed. This context is treated
+ -- as suitable because it is not yet known whether the expression
+ -- function is an initial declaration or a completion. The real
+ -- check is performed when the expression function is expanded.
- elsif Nkind (Decl) = N_Parameter_Specification
- and then Nkind (Parent (Parent (Decl))) = N_Subprogram_Body
+ elsif Nkind (Decl) = N_Expression_Function
+ and then not Analyzed (Decl)
then
return True;
@@ -253,15 +272,26 @@ package body Ghost is
then
Subp_Id := Corresponding_Spec (Decl);
- -- The original context is an expression function that has
- -- been split into a spec and a body. The context is OK as
- -- long as the initial declaration is Ghost.
-
if Present (Subp_Id) then
- Subp_Decl := Original_Node (Unit_Declaration_Node (Subp_Id));
- if Nkind (Subp_Decl) = N_Expression_Function then
- return Is_Subject_To_Ghost (Subp_Decl);
+ -- The context is the internally built _Postconditions
+ -- procedure, which is OK because the real check was done
+ -- before expansion activities.
+
+ if Chars (Subp_Id) = Name_uPostconditions then
+ return True;
+
+ else
+ Subp_Decl :=
+ Original_Node (Unit_Declaration_Node (Subp_Id));
+
+ -- The original context is an expression function that
+ -- has been split into a spec and a body. The context is
+ -- OK as long as the initial declaration is Ghost.
+
+ if Nkind (Subp_Decl) = N_Expression_Function then
+ return Is_Ghost_Declaration (Subp_Decl);
+ end if;
end if;
-- Otherwise this is either an internal body or an internal
@@ -315,8 +345,6 @@ package body Ghost is
-- Local variables
- Arg : Node_Id;
- Arg_Id : Entity_Id;
Prag_Id : Pragma_Id;
Prag_Nam : Name_Id;
@@ -334,30 +362,19 @@ package body Ghost is
return True;
-- An assertion expression pragma is Ghost when it contains a
- -- reference to a Ghost entity (SPARK RM 6.9(11)).
+ -- reference to a Ghost entity (SPARK RM 6.9(10)).
elsif Assertion_Expression_Pragma (Prag_Id) then
- -- Predicates are excluded from this category when they do
- -- not apply to a Ghost subtype (SPARK RM 6.9(11)).
+ -- Ensure that the assertion policy and the Ghost policy are
+ -- compatible (SPARK RM 6.9(18)).
- if Nam_In (Prag_Nam, Name_Dynamic_Predicate,
- Name_Predicate,
- Name_Static_Predicate)
- then
- return False;
-
- -- Otherwise ensure that the assertion policy and the Ghost
- -- policy are compatible (SPARK RM 6.9(18)).
-
- else
- Check_Policies (Prag_Nam);
- return True;
- end if;
+ Check_Policies (Prag_Nam);
+ return True;
-- Several pragmas that may apply to a non-Ghost entity are
-- treated as Ghost when they contain a reference to a Ghost
- -- entity (SPARK RM 6.9(12)).
+ -- entity (SPARK RM 6.9(11)).
elsif Nam_In (Prag_Nam, Name_Global,
Name_Depends,
@@ -367,21 +384,6 @@ package body Ghost is
Name_Refined_State)
then
return True;
-
- -- Otherwise a normal pragma is Ghost when it encloses a Ghost
- -- name (SPARK RM 6.9(3)).
-
- else
- Arg := First (Pragma_Argument_Associations (Prag));
- while Present (Arg) loop
- Arg_Id := Ghost_Entity (Get_Pragma_Arg (Arg));
-
- if Present (Arg_Id) and then Is_Ghost_Entity (Arg_Id) then
- return True;
- end if;
-
- Next (Arg);
- end loop;
end if;
end if;
@@ -393,18 +395,17 @@ package body Ghost is
---------------------
function Is_OK_Statement (Stmt : Node_Id) return Boolean is
- Nam_Id : Entity_Id;
-
begin
- -- An assignment statement or a procedure call is Ghost when the
- -- name denotes a Ghost entity.
+ -- An assignment statement is Ghost when the target is a Ghost
+ -- entity.
- if Nkind_In (Stmt, N_Assignment_Statement,
- N_Procedure_Call_Statement)
- then
- Nam_Id := Ghost_Entity (Name (Stmt));
+ if Nkind (Stmt) = N_Assignment_Statement then
+ return Is_Ghost_Assignment (Stmt);
+
+ -- A procedure call is Ghost when it calls a Ghost procedure
- return Present (Nam_Id) and then Is_Ghost_Entity (Nam_Id);
+ elsif Nkind (Stmt) = N_Procedure_Call_Statement then
+ return Is_Ghost_Procedure_Call (Stmt);
-- Special cases
@@ -437,6 +438,14 @@ package body Ghost is
if Ghost_Mode > None then
return True;
+ -- A Ghost type may be referenced in a use_type clause
+ -- (SPARK RM 6.9.10).
+
+ elsif Present (Parent (Context))
+ and then Nkind (Parent (Context)) = N_Use_Type_Clause
+ then
+ return True;
+
-- Routine Expand_Record_Extension creates a parent subtype without
-- inserting it into the tree. There is no good way of recognizing
-- this special case as there is no parent. Try to approximate the
@@ -455,7 +464,7 @@ package body Ghost is
return True;
-- A reference to a Ghost entity can appear within an aspect
- -- specification (SPARK RM 6.9(11)).
+ -- specification (SPARK RM 6.9(10)).
elsif Nkind (Par) = N_Aspect_Specification then
return True;
@@ -499,26 +508,29 @@ package body Ghost is
-- Check_Ghost_Policy --
------------------------
- procedure Check_Ghost_Policy (Id : Entity_Id; Err_N : Node_Id) is
+ procedure Check_Ghost_Policy (Id : Entity_Id; Ref : Node_Id) is
Policy : constant Name_Id := Policy_In_Effect (Name_Ghost);
begin
-- The Ghost policy in effect a the point of declaration and at the
- -- point of use must match (SPARK RM 6.9(14)).
+ -- point of use must match (SPARK RM 6.9(13)).
- if Is_Checked_Ghost_Entity (Id) and then Policy = Name_Ignore then
- Error_Msg_Sloc := Sloc (Err_N);
+ if Is_Checked_Ghost_Entity (Id)
+ and then Policy = Name_Ignore
+ and then May_Be_Lvalue (Ref)
+ then
+ Error_Msg_Sloc := Sloc (Ref);
- Error_Msg_N ("incompatible ghost policies in effect", Err_N);
- Error_Msg_NE ("\& declared with ghost policy `Check`", Err_N, Id);
- Error_Msg_NE ("\& used # with ghost policy `Ignore`", Err_N, Id);
+ Error_Msg_N ("incompatible ghost policies in effect", Ref);
+ Error_Msg_NE ("\& declared with ghost policy `Check`", Ref, Id);
+ Error_Msg_NE ("\& used # with ghost policy `Ignore`", Ref, Id);
elsif Is_Ignored_Ghost_Entity (Id) and then Policy = Name_Check then
- Error_Msg_Sloc := Sloc (Err_N);
+ Error_Msg_Sloc := Sloc (Ref);
- Error_Msg_N ("incompatible ghost policies in effect", Err_N);
- Error_Msg_NE ("\& declared with ghost policy `Ignore`", Err_N, Id);
- Error_Msg_NE ("\& used # with ghost policy `Check`", Err_N, Id);
+ Error_Msg_N ("incompatible ghost policies in effect", Ref);
+ Error_Msg_NE ("\& declared with ghost policy `Ignore`", Ref, Id);
+ Error_Msg_NE ("\& used # with ghost policy `Check`", Ref, Id);
end if;
end Check_Ghost_Policy;
@@ -533,7 +545,7 @@ package body Ghost is
Check_Ghost_Policy (Ghost_Id, Ghost_Ref);
-- Otherwise the Ghost entity appears in a non-Ghost context and affects
- -- its behavior or value (SPARK RM 6.9(11,12)).
+ -- its behavior or value (SPARK RM 6.9(10,11)).
else
Error_Msg_N ("ghost entity cannot appear in this context", Ghost_Ref);
@@ -541,48 +553,6 @@ package body Ghost is
end Check_Ghost_Context;
----------------------------
- -- Check_Ghost_Derivation --
- ----------------------------
-
- procedure Check_Ghost_Derivation (Typ : Entity_Id) is
- Parent_Typ : constant Entity_Id := Etype (Typ);
- Iface : Entity_Id;
- Iface_Elmt : Elmt_Id;
-
- begin
- -- Allow untagged derivations from predefined types such as Integer as
- -- those are not Ghost by definition.
-
- if Is_Scalar_Type (Typ) and then Parent_Typ = Base_Type (Typ) then
- null;
-
- -- The parent type of a Ghost type extension must be Ghost
-
- elsif not Is_Ghost_Entity (Parent_Typ) then
- Error_Msg_N ("type extension & cannot be ghost", Typ);
- Error_Msg_NE ("\parent type & is not ghost", Typ, Parent_Typ);
- return;
- end if;
-
- -- All progenitors (if any) must be Ghost as well
-
- if Is_Tagged_Type (Typ) and then Present (Interfaces (Typ)) then
- Iface_Elmt := First_Elmt (Interfaces (Typ));
- while Present (Iface_Elmt) loop
- Iface := Node (Iface_Elmt);
-
- if not Is_Ghost_Entity (Iface) then
- Error_Msg_N ("type extension & cannot be ghost", Typ);
- Error_Msg_NE ("\interface type & is not ghost", Typ, Iface);
- return;
- end if;
-
- Next_Elmt (Iface_Elmt);
- end loop;
- end if;
- end Check_Ghost_Derivation;
-
- ----------------------------
-- Check_Ghost_Overriding --
----------------------------
@@ -590,40 +560,236 @@ package body Ghost is
(Subp : Entity_Id;
Overridden_Subp : Entity_Id)
is
+ Deriv_Typ : Entity_Id;
Over_Subp : Entity_Id;
begin
if Present (Subp) and then Present (Overridden_Subp) then
Over_Subp := Ultimate_Alias (Overridden_Subp);
+ Deriv_Typ := Find_Dispatching_Type (Subp);
- -- The Ghost policy in effect at the point of declaration of a parent
- -- and an overriding subprogram must match (SPARK RM 6.9(17)).
+ -- A Ghost primitive of a non-Ghost type extension cannot override an
+ -- inherited non-Ghost primitive (SPARK RM 6.9(8)).
- if Is_Checked_Ghost_Entity (Over_Subp)
- and then Is_Ignored_Ghost_Entity (Subp)
+ if Is_Ghost_Entity (Subp)
+ and then Present (Deriv_Typ)
+ and then not Is_Ghost_Entity (Deriv_Typ)
+ and then not Is_Ghost_Entity (Over_Subp)
+ and then not Is_Abstract_Subprogram (Over_Subp)
then
- Error_Msg_N ("incompatible ghost policies in effect", Subp);
+ Error_Msg_N ("incompatible overriding in effect", Subp);
Error_Msg_Sloc := Sloc (Over_Subp);
- Error_Msg_N ("\& declared # with ghost policy `Check`", Subp);
+ Error_Msg_N ("\& declared # as non-ghost subprogram", Subp);
Error_Msg_Sloc := Sloc (Subp);
- Error_Msg_N ("\overridden # with ghost policy `Ignore`", Subp);
+ Error_Msg_N ("\overridden # with ghost subprogram", Subp);
+ end if;
- elsif Is_Ignored_Ghost_Entity (Over_Subp)
- and then Is_Checked_Ghost_Entity (Subp)
+ -- A non-Ghost primitive of a type extension cannot override an
+ -- inherited Ghost primitive (SPARK RM 6.9(8)).
+
+ if Is_Ghost_Entity (Over_Subp)
+ and then not Is_Ghost_Entity (Subp)
+ and then not Is_Abstract_Subprogram (Subp)
then
- Error_Msg_N ("incompatible ghost policies in effect", Subp);
+ Error_Msg_N ("incompatible overriding in effect", Subp);
Error_Msg_Sloc := Sloc (Over_Subp);
- Error_Msg_N ("\& declared # with ghost policy `Ignore`", Subp);
+ Error_Msg_N ("\& declared # as ghost subprogram", Subp);
Error_Msg_Sloc := Sloc (Subp);
- Error_Msg_N ("\overridden # with ghost policy `Check`", Subp);
+ Error_Msg_N ("\overridden # with non-ghost subprogram", Subp);
+ end if;
+
+ if Present (Deriv_Typ)
+ and then not Is_Ignored_Ghost_Entity (Deriv_Typ)
+ then
+ -- When a tagged type is either non-Ghost or checked Ghost and
+ -- one of its primitives overrides an inherited operation, the
+ -- overridden operation of the ancestor type must be ignored Ghost
+ -- if the primitive is ignored Ghost (SPARK RM 6.9(17)).
+
+ if Is_Ignored_Ghost_Entity (Subp) then
+
+ -- Both the parent subprogram and overriding subprogram are
+ -- ignored Ghost.
+
+ if Is_Ignored_Ghost_Entity (Over_Subp) then
+ null;
+
+ -- The parent subprogram carries policy Check
+
+ elsif Is_Checked_Ghost_Entity (Over_Subp) then
+ Error_Msg_N
+ ("incompatible ghost policies in effect", Subp);
+
+ Error_Msg_Sloc := Sloc (Over_Subp);
+ Error_Msg_N
+ ("\& declared # with ghost policy `Check`", Subp);
+
+ Error_Msg_Sloc := Sloc (Subp);
+ Error_Msg_N
+ ("\overridden # with ghost policy `Ignore`", Subp);
+
+ -- The parent subprogram is non-Ghost
+
+ else
+ Error_Msg_N
+ ("incompatible ghost policies in effect", Subp);
+
+ Error_Msg_Sloc := Sloc (Over_Subp);
+ Error_Msg_N ("\& declared # as non-ghost subprogram", Subp);
+
+ Error_Msg_Sloc := Sloc (Subp);
+ Error_Msg_N
+ ("\overridden # with ghost policy `Ignore`", Subp);
+ end if;
+
+ -- When a tagged type is either non-Ghost or checked Ghost and
+ -- one of its primitives overrides an inherited operation, the
+ -- the primitive of the tagged type must be ignored Ghost if the
+ -- overridden operation is ignored Ghost (SPARK RM 6.9(17)).
+
+ elsif Is_Ignored_Ghost_Entity (Over_Subp) then
+
+ -- Both the parent subprogram and the overriding subprogram are
+ -- ignored Ghost.
+
+ if Is_Ignored_Ghost_Entity (Subp) then
+ null;
+
+ -- The overriding subprogram carries policy Check
+
+ elsif Is_Checked_Ghost_Entity (Subp) then
+ Error_Msg_N
+ ("incompatible ghost policies in effect", Subp);
+
+ Error_Msg_Sloc := Sloc (Over_Subp);
+ Error_Msg_N
+ ("\& declared # with ghost policy `Ignore`", Subp);
+
+ Error_Msg_Sloc := Sloc (Subp);
+ Error_Msg_N
+ ("\overridden # with Ghost policy `Check`", Subp);
+
+ -- The overriding subprogram is non-Ghost
+
+ else
+ Error_Msg_N
+ ("incompatible ghost policies in effect", Subp);
+
+ Error_Msg_Sloc := Sloc (Over_Subp);
+ Error_Msg_N
+ ("\& declared # with ghost policy `Ignore`", Subp);
+
+ Error_Msg_Sloc := Sloc (Subp);
+ Error_Msg_N
+ ("\overridden # with non-ghost subprogram", Subp);
+ end if;
+ end if;
end if;
end if;
end Check_Ghost_Overriding;
+ ---------------------------
+ -- Check_Ghost_Primitive --
+ ---------------------------
+
+ procedure Check_Ghost_Primitive (Prim : Entity_Id; Typ : Entity_Id) is
+ begin
+ -- The Ghost policy in effect at the point of declaration of a primitive
+ -- operation and a tagged type must match (SPARK RM 6.9(16)).
+
+ if Is_Tagged_Type (Typ) then
+ if Is_Checked_Ghost_Entity (Prim)
+ and then Is_Ignored_Ghost_Entity (Typ)
+ then
+ Error_Msg_N ("incompatible ghost policies in effect", Prim);
+
+ Error_Msg_Sloc := Sloc (Typ);
+ Error_Msg_NE
+ ("\tagged type & declared # with ghost policy `Ignore`",
+ Prim, Typ);
+
+ Error_Msg_Sloc := Sloc (Prim);
+ Error_Msg_N
+ ("\primitive subprogram & declared # with ghost policy `Check`",
+ Prim);
+
+ elsif Is_Ignored_Ghost_Entity (Prim)
+ and then Is_Checked_Ghost_Entity (Typ)
+ then
+ Error_Msg_N ("incompatible ghost policies in effect", Prim);
+
+ Error_Msg_Sloc := Sloc (Typ);
+ Error_Msg_NE
+ ("\tagged type & declared # with ghost policy `Check`",
+ Prim, Typ);
+
+ Error_Msg_Sloc := Sloc (Prim);
+ Error_Msg_N
+ ("\primitive subprogram & declared # with ghost policy `Ignore`",
+ Prim);
+ end if;
+ end if;
+ end Check_Ghost_Primitive;
+
+ ----------------------------
+ -- Check_Ghost_Refinement --
+ ----------------------------
+
+ procedure Check_Ghost_Refinement
+ (State : Node_Id;
+ State_Id : Entity_Id;
+ Constit : Node_Id;
+ Constit_Id : Entity_Id)
+ is
+ begin
+ if Is_Ghost_Entity (State_Id) then
+ if Is_Ghost_Entity (Constit_Id) then
+
+ -- The Ghost policy in effect at the point of abstract state
+ -- declaration and constituent must match (SPARK RM 6.9(15)).
+
+ if Is_Checked_Ghost_Entity (State_Id)
+ and then Is_Ignored_Ghost_Entity (Constit_Id)
+ then
+ Error_Msg_Sloc := Sloc (Constit);
+ SPARK_Msg_N ("incompatible ghost policies in effect", State);
+
+ SPARK_Msg_NE
+ ("\abstract state & declared with ghost policy `Check`",
+ State, State_Id);
+ SPARK_Msg_NE
+ ("\constituent & declared # with ghost policy `Ignore`",
+ State, Constit_Id);
+
+ elsif Is_Ignored_Ghost_Entity (State_Id)
+ and then Is_Checked_Ghost_Entity (Constit_Id)
+ then
+ Error_Msg_Sloc := Sloc (Constit);
+ SPARK_Msg_N ("incompatible ghost policies in effect", State);
+
+ SPARK_Msg_NE
+ ("\abstract state & declared with ghost policy `Ignore`",
+ State, State_Id);
+ SPARK_Msg_NE
+ ("\constituent & declared # with ghost policy `Check`",
+ State, Constit_Id);
+ end if;
+
+ -- A constituent of a Ghost abstract state must be a Ghost entity
+ -- (SPARK RM 7.2.2(12)).
+
+ else
+ SPARK_Msg_NE
+ ("constituent of ghost state & must be ghost",
+ Constit, State_Id);
+ end if;
+ end if;
+ end Check_Ghost_Refinement;
+
------------------
-- Ghost_Entity --
------------------
@@ -632,7 +798,7 @@ package body Ghost is
Ref : Node_Id;
begin
- -- When the reference extracts a subcomponent, recover the related
+ -- When the reference denotes a subcomponent, recover the related
-- object (SPARK RM 6.9(1)).
Ref := N;
@@ -684,6 +850,111 @@ package body Ghost is
Ignored_Ghost_Units.Init;
end Initialize;
+ ------------------------
+ -- Install_Ghost_Mode --
+ ------------------------
+
+ procedure Install_Ghost_Mode (Mode : Ghost_Mode_Type) is
+ begin
+ Ghost_Mode := Mode;
+ end Install_Ghost_Mode;
+
+ procedure Install_Ghost_Mode (Mode : Name_Id) is
+ begin
+ if Mode = Name_Check then
+ Ghost_Mode := Check;
+
+ elsif Mode = Name_Ignore then
+ Ghost_Mode := Ignore;
+
+ elsif Mode = Name_None then
+ Ghost_Mode := None;
+ end if;
+ end Install_Ghost_Mode;
+
+ -------------------------
+ -- Is_Ghost_Assignment --
+ -------------------------
+
+ function Is_Ghost_Assignment (N : Node_Id) return Boolean is
+ Id : Entity_Id;
+
+ begin
+ -- An assignment statement is Ghost when its target denotes a Ghost
+ -- entity.
+
+ if Nkind (N) = N_Assignment_Statement then
+ Id := Ghost_Entity (Name (N));
+
+ return Present (Id) and then Is_Ghost_Entity (Id);
+ end if;
+
+ return False;
+ end Is_Ghost_Assignment;
+
+ --------------------------
+ -- Is_Ghost_Declaration --
+ --------------------------
+
+ function Is_Ghost_Declaration (N : Node_Id) return Boolean is
+ Id : Entity_Id;
+
+ begin
+ -- A declaration is Ghost when it elaborates a Ghost entity or is
+ -- subject to pragma Ghost.
+
+ if Is_Declaration (N) then
+ Id := Defining_Entity (N);
+
+ return Is_Ghost_Entity (Id) or else Is_Subject_To_Ghost (N);
+ end if;
+
+ return False;
+ end Is_Ghost_Declaration;
+
+ ---------------------
+ -- Is_Ghost_Pragma --
+ ---------------------
+
+ function Is_Ghost_Pragma (N : Node_Id) return Boolean is
+ begin
+ return Is_Checked_Ghost_Pragma (N) or else Is_Ignored_Ghost_Pragma (N);
+ end Is_Ghost_Pragma;
+
+ -----------------------------
+ -- Is_Ghost_Procedure_Call --
+ -----------------------------
+
+ function Is_Ghost_Procedure_Call (N : Node_Id) return Boolean is
+ Id : Entity_Id;
+
+ begin
+ -- A procedure call is Ghost when it invokes a Ghost procedure
+
+ if Nkind (N) = N_Procedure_Call_Statement then
+ Id := Ghost_Entity (Name (N));
+
+ return Present (Id) and then Is_Ghost_Entity (Id);
+ end if;
+
+ return False;
+ end Is_Ghost_Procedure_Call;
+
+ ---------------------------
+ -- Is_Ignored_Ghost_Unit --
+ ---------------------------
+
+ function Is_Ignored_Ghost_Unit (N : Node_Id) return Boolean is
+ begin
+ -- Inspect the original node of the unit in case removal of ignored
+ -- Ghost code has already taken place.
+
+ return
+ Nkind (N) = N_Compilation_Unit
+ and then Is_Ignored_Ghost_Entity
+ (Defining_Entity (Original_Node (Unit (N))));
+ end Is_Ignored_Ghost_Unit;
+
-------------------------
-- Is_Subject_To_Ghost --
-------------------------
@@ -824,66 +1095,427 @@ package body Ghost is
Ignored_Ghost_Units.Release;
end Lock;
+ -----------------------------------
+ -- Mark_And_Set_Ghost_Assignment --
+ -----------------------------------
+
+ procedure Mark_And_Set_Ghost_Assignment
+ (N : Node_Id;
+ Mode : out Ghost_Mode_Type)
+ is
+ Id : Entity_Id;
+
+ begin
+ -- Save the previous Ghost mode in effect
+
+ Mode := Ghost_Mode;
+
+ -- An assignment statement becomes Ghost when its target denotes a Ghost
+ -- object. Install the Ghost mode of the target.
+
+ Id := Ghost_Entity (Name (N));
+
+ if Present (Id) then
+ if Is_Checked_Ghost_Entity (Id) then
+ Install_Ghost_Mode (Check);
+
+ elsif Is_Ignored_Ghost_Entity (Id) then
+ Install_Ghost_Mode (Ignore);
+
+ Set_Is_Ignored_Ghost_Node (N);
+ Propagate_Ignored_Ghost_Code (N);
+ end if;
+ end if;
+ end Mark_And_Set_Ghost_Assignment;
+
-----------------------------
- -- Mark_Full_View_As_Ghost --
+ -- Mark_And_Set_Ghost_Body --
-----------------------------
- procedure Mark_Full_View_As_Ghost
- (Priv_Typ : Entity_Id;
- Full_Typ : Entity_Id)
+ procedure Mark_And_Set_Ghost_Body
+ (N : Node_Id;
+ Spec_Id : Entity_Id;
+ Mode : out Ghost_Mode_Type)
is
- Full_Decl : constant Node_Id := Declaration_Node (Full_Typ);
+ Body_Id : constant Entity_Id := Defining_Entity (N);
+ Policy : Name_Id := No_Name;
begin
- if Is_Checked_Ghost_Entity (Priv_Typ) then
- Set_Is_Checked_Ghost_Entity (Full_Typ);
+ -- Save the previous Ghost mode in effect
+
+ Mode := Ghost_Mode;
+
+ -- A body becomes Ghost when it is subject to aspect or pragma Ghost
+
+ if Is_Subject_To_Ghost (N) then
+ Policy := Policy_In_Effect (Name_Ghost);
+
+ -- A body declared within a Ghost region is automatically Ghost
+ -- (SPARK RM 6.9(2)).
- elsif Is_Ignored_Ghost_Entity (Priv_Typ) then
- Set_Is_Ignored_Ghost_Entity (Full_Typ);
- Set_Is_Ignored_Ghost_Node (Full_Decl);
- Propagate_Ignored_Ghost_Code (Full_Decl);
+ elsif Ghost_Mode = Check then
+ Policy := Name_Check;
+
+ elsif Ghost_Mode = Ignore then
+ Policy := Name_Ignore;
+
+ -- Inherit the "ghostness" of the previous declaration when the body
+ -- acts as a completion.
+
+ elsif Present (Spec_Id) then
+ if Is_Checked_Ghost_Entity (Spec_Id) then
+ Policy := Name_Check;
+
+ elsif Is_Ignored_Ghost_Entity (Spec_Id) then
+ Policy := Name_Ignore;
+ end if;
end if;
- end Mark_Full_View_As_Ghost;
- --------------------------
- -- Mark_Pragma_As_Ghost --
- --------------------------
+ -- The Ghost policy in effect at the point of declaration and at the
+ -- point of completion must match (SPARK RM 6.9(14)).
+
+ Check_Ghost_Completion
+ (Prev_Id => Spec_Id,
+ Compl_Id => Body_Id);
+
+ -- Mark the body as its formals as Ghost
+
+ Mark_Ghost_Declaration_Or_Body (N, Policy);
- procedure Mark_Pragma_As_Ghost
- (Prag : Node_Id;
- Context_Id : Entity_Id)
+ -- Install the appropriate Ghost mode
+
+ Install_Ghost_Mode (Policy);
+ end Mark_And_Set_Ghost_Body;
+
+ -----------------------------------
+ -- Mark_And_Set_Ghost_Completion --
+ -----------------------------------
+
+ procedure Mark_And_Set_Ghost_Completion
+ (N : Node_Id;
+ Prev_Id : Entity_Id;
+ Mode : out Ghost_Mode_Type)
is
+ Compl_Id : constant Entity_Id := Defining_Entity (N);
+ Policy : Name_Id := No_Name;
+
begin
- if Is_Checked_Ghost_Entity (Context_Id) then
- Set_Is_Ghost_Pragma (Prag);
+ -- Save the previous Ghost mode in effect
+
+ Mode := Ghost_Mode;
+
+ -- A completion elaborated in a Ghost region is automatically Ghost
+ -- (SPARK RM 6.9(2)).
- elsif Is_Ignored_Ghost_Entity (Context_Id) then
- Set_Is_Ghost_Pragma (Prag);
- Set_Is_Ignored_Ghost_Node (Prag);
- Propagate_Ignored_Ghost_Code (Prag);
+ if Ghost_Mode = Check then
+ Policy := Name_Check;
+
+ elsif Ghost_Mode = Ignore then
+ Policy := Name_Ignore;
+
+ -- The completion becomes Ghost when its initial declaration is also
+ -- Ghost.
+
+ elsif Is_Checked_Ghost_Entity (Prev_Id) then
+ Policy := Name_Check;
+
+ elsif Is_Ignored_Ghost_Entity (Prev_Id) then
+ Policy := Name_Ignore;
end if;
- end Mark_Pragma_As_Ghost;
- ----------------------------
- -- Mark_Renaming_As_Ghost --
- ----------------------------
+ -- The Ghost policy in effect at the point of declaration and at the
+ -- point of completion must match (SPARK RM 6.9(14)).
+
+ Check_Ghost_Completion
+ (Prev_Id => Prev_Id,
+ Compl_Id => Compl_Id);
+
+ -- Mark the completion as Ghost
+
+ Mark_Ghost_Declaration_Or_Body (N, Policy);
+
+ -- Install the appropriate Ghost mode
+
+ Install_Ghost_Mode (Policy);
+ end Mark_And_Set_Ghost_Completion;
+
+ ------------------------------------
+ -- Mark_And_Set_Ghost_Declaration --
+ ------------------------------------
+
+ procedure Mark_And_Set_Ghost_Declaration
+ (N : Node_Id;
+ Mode : out Ghost_Mode_Type)
+ is
+ Par_Id : Entity_Id;
+ Policy : Name_Id := No_Name;
+
+ begin
+ -- Save the previous Ghost mode in effect
- procedure Mark_Renaming_As_Ghost
- (Ren_Decl : Node_Id;
- Nam_Id : Entity_Id)
+ Mode := Ghost_Mode;
+
+ -- A declaration becomes Ghost when it is subject to aspect or pragma
+ -- Ghost.
+
+ if Is_Subject_To_Ghost (N) then
+ Policy := Policy_In_Effect (Name_Ghost);
+
+ -- A declaration elaborated in a Ghost region is automatically Ghost
+ -- (SPARK RM 6.9(2)).
+
+ elsif Ghost_Mode = Check then
+ Policy := Name_Check;
+
+ elsif Ghost_Mode = Ignore then
+ Policy := Name_Ignore;
+
+ -- A child package or subprogram declaration becomes Ghost when its
+ -- parent is Ghost (SPARK RM 6.9(2)).
+
+ elsif Nkind_In (N, N_Generic_Function_Renaming_Declaration,
+ N_Generic_Package_Declaration,
+ N_Generic_Package_Renaming_Declaration,
+ N_Generic_Procedure_Renaming_Declaration,
+ N_Generic_Subprogram_Declaration,
+ N_Package_Declaration,
+ N_Package_Renaming_Declaration,
+ N_Subprogram_Declaration,
+ N_Subprogram_Renaming_Declaration)
+ and then Present (Parent_Spec (N))
+ then
+ Par_Id := Defining_Entity (Unit (Parent_Spec (N)));
+
+ if Is_Checked_Ghost_Entity (Par_Id) then
+ Policy := Name_Check;
+
+ elsif Is_Ignored_Ghost_Entity (Par_Id) then
+ Policy := Name_Ignore;
+ end if;
+ end if;
+
+ -- Mark the declaration and its formals as Ghost
+
+ Mark_Ghost_Declaration_Or_Body (N, Policy);
+
+ -- Install the appropriate Ghost mode
+
+ Install_Ghost_Mode (Policy);
+ end Mark_And_Set_Ghost_Declaration;
+
+ --------------------------------------
+ -- Mark_And_Set_Ghost_Instantiation --
+ --------------------------------------
+
+ procedure Mark_And_Set_Ghost_Instantiation
+ (N : Node_Id;
+ Gen_Id : Entity_Id;
+ Mode : out Ghost_Mode_Type)
+ is
+ Policy : Name_Id := No_Name;
+
+ begin
+ -- Save the previous Ghost mode in effect
+
+ Mode := Ghost_Mode;
+
+ -- An instantiation becomes Ghost when it is subject to pragma Ghost
+
+ if Is_Subject_To_Ghost (N) then
+ Policy := Policy_In_Effect (Name_Ghost);
+
+ -- An instantiation declaration within a Ghost region is automatically
+ -- Ghost (SPARK RM 6.9(2)).
+
+ elsif Ghost_Mode = Check then
+ Policy := Name_Check;
+
+ elsif Ghost_Mode = Ignore then
+ Policy := Name_Ignore;
+
+ -- Inherit the "ghostness" of the generic unit
+
+ elsif Is_Checked_Ghost_Entity (Gen_Id) then
+ Policy := Name_Check;
+
+ elsif Is_Ignored_Ghost_Entity (Gen_Id) then
+ Policy := Name_Ignore;
+ end if;
+
+ -- Mark the instantiation as Ghost
+
+ Mark_Ghost_Declaration_Or_Body (N, Policy);
+
+ -- Install the appropriate Ghost mode
+
+ Install_Ghost_Mode (Policy);
+ end Mark_And_Set_Ghost_Instantiation;
+
+ ---------------------------------------
+ -- Mark_And_Set_Ghost_Procedure_Call --
+ ---------------------------------------
+
+ procedure Mark_And_Set_Ghost_Procedure_Call
+ (N : Node_Id;
+ Mode : out Ghost_Mode_Type)
is
- Ren_Id : constant Entity_Id := Defining_Entity (Ren_Decl);
+ Id : Entity_Id;
begin
- if Is_Checked_Ghost_Entity (Nam_Id) then
- Set_Is_Checked_Ghost_Entity (Ren_Id);
+ -- Save the previous Ghost mode in effect
+
+ Mode := Ghost_Mode;
- elsif Is_Ignored_Ghost_Entity (Nam_Id) then
- Set_Is_Ignored_Ghost_Entity (Ren_Id);
- Set_Is_Ignored_Ghost_Node (Ren_Decl);
- Propagate_Ignored_Ghost_Code (Ren_Decl);
+ -- A procedure call becomes Ghost when the procedure being invoked is
+ -- Ghost. Install the Ghost mode of the procedure.
+
+ Id := Ghost_Entity (Name (N));
+
+ if Present (Id) then
+ if Is_Checked_Ghost_Entity (Id) then
+ Install_Ghost_Mode (Check);
+
+ elsif Is_Ignored_Ghost_Entity (Id) then
+ Install_Ghost_Mode (Ignore);
+
+ Set_Is_Ignored_Ghost_Node (N);
+ Propagate_Ignored_Ghost_Code (N);
+ end if;
end if;
- end Mark_Renaming_As_Ghost;
+ end Mark_And_Set_Ghost_Procedure_Call;
+
+ ------------------------------------
+ -- Mark_Ghost_Declaration_Or_Body --
+ ------------------------------------
+
+ procedure Mark_Ghost_Declaration_Or_Body
+ (N : Node_Id;
+ Mode : Name_Id)
+ is
+ Id : constant Entity_Id := Defining_Entity (N);
+
+ Mark_Formals : Boolean := False;
+ Param : Node_Id;
+ Param_Id : Entity_Id;
+
+ begin
+ -- Mark the related node and its entity
+
+ if Mode = Name_Check then
+ Mark_Formals := True;
+ Set_Is_Checked_Ghost_Entity (Id);
+
+ elsif Mode = Name_Ignore then
+ Mark_Formals := True;
+ Set_Is_Ignored_Ghost_Entity (Id);
+ Set_Is_Ignored_Ghost_Node (N);
+ Propagate_Ignored_Ghost_Code (N);
+ end if;
+
+ -- Mark all formal parameters when the related node denotes a subprogram
+ -- or a body. The traversal is performed via the specification because
+ -- the related subprogram or body may be unanalyzed.
+
+ -- ??? could extra formal parameters cause a Ghost leak?
+
+ if Mark_Formals
+ and then Nkind_In (N, N_Abstract_Subprogram_Declaration,
+ N_Formal_Abstract_Subprogram_Declaration,
+ N_Formal_Concrete_Subprogram_Declaration,
+ N_Generic_Subprogram_Declaration,
+ N_Subprogram_Body,
+ N_Subprogram_Body_Stub,
+ N_Subprogram_Declaration,
+ N_Subprogram_Renaming_Declaration)
+ then
+ Param := First (Parameter_Specifications (Specification (N)));
+ while Present (Param) loop
+ Param_Id := Defining_Entity (Param);
+
+ if Mode = Name_Check then
+ Set_Is_Checked_Ghost_Entity (Param_Id);
+
+ elsif Mode = Name_Ignore then
+ Set_Is_Ignored_Ghost_Entity (Param_Id);
+ end if;
+
+ Next (Param);
+ end loop;
+ end if;
+ end Mark_Ghost_Declaration_Or_Body;
+
+ -----------------------
+ -- Mark_Ghost_Clause --
+ -----------------------
+
+ procedure Mark_Ghost_Clause (N : Node_Id) is
+ Nam : Node_Id := Empty;
+
+ begin
+ if Nkind (N) = N_Use_Package_Clause then
+ Nam := First (Names (N));
+
+ elsif Nkind (N) = N_Use_Type_Clause then
+ Nam := First (Subtype_Marks (N));
+
+ elsif Nkind (N) = N_With_Clause then
+ Nam := Name (N);
+ end if;
+
+ if Present (Nam)
+ and then Is_Entity_Name (Nam)
+ and then Present (Entity (Nam))
+ and then Is_Ignored_Ghost_Entity (Entity (Nam))
+ then
+ Set_Is_Ignored_Ghost_Node (N);
+ Propagate_Ignored_Ghost_Code (N);
+ end if;
+ end Mark_Ghost_Clause;
+
+ -----------------------
+ -- Mark_Ghost_Pragma --
+ -----------------------
+
+ procedure Mark_Ghost_Pragma
+ (N : Node_Id;
+ Id : Entity_Id)
+ is
+ begin
+ -- A pragma becomes Ghost when it encloses a Ghost entity or relates to
+ -- a Ghost entity.
+
+ if Is_Checked_Ghost_Entity (Id) then
+ Set_Is_Checked_Ghost_Pragma (N);
+
+ elsif Is_Ignored_Ghost_Entity (Id) then
+ Set_Is_Ignored_Ghost_Pragma (N);
+ Set_Is_Ignored_Ghost_Node (N);
+ Propagate_Ignored_Ghost_Code (N);
+ end if;
+ end Mark_Ghost_Pragma;
+
+ -------------------------
+ -- Mark_Ghost_Renaming --
+ -------------------------
+
+ procedure Mark_Ghost_Renaming
+ (N : Node_Id;
+ Id : Entity_Id)
+ is
+ Policy : Name_Id := No_Name;
+
+ begin
+ -- A renaming becomes Ghost when it renames a Ghost entity
+
+ if Is_Checked_Ghost_Entity (Id) then
+ Policy := Name_Check;
+
+ elsif Is_Ignored_Ghost_Entity (Id) then
+ Policy := Name_Ignore;
+ end if;
+
+ Mark_Ghost_Declaration_Or_Body (N, Policy);
+ end Mark_Ghost_Renaming;
----------------------------------
-- Propagate_Ignored_Ghost_Code --
@@ -894,14 +1526,16 @@ package body Ghost is
Scop : Entity_Id;
begin
- -- Traverse the parent chain looking for blocks, packages and
+ -- Traverse the parent chain looking for blocks, packages, and
-- subprograms or their respective bodies.
Nod := Parent (N);
while Present (Nod) loop
Scop := Empty;
- if Nkind (Nod) = N_Block_Statement then
+ if Nkind (Nod) = N_Block_Statement
+ and then Present (Identifier (Nod))
+ then
Scop := Entity (Identifier (Nod));
elsif Nkind_In (Nod, N_Package_Body,
@@ -983,10 +1617,17 @@ package body Ghost is
Id : Entity_Id;
begin
+ -- Do not prune compilation unit nodes because many mechanisms
+ -- depend on their presence. Note that context items are still
+ -- being processed.
+
+ if Nkind (N) = N_Compilation_Unit then
+ return OK;
+
-- The node is either declared as ignored Ghost or is a byproduct
-- of expansion. Destroy it and stop the traversal on this branch.
- if Is_Ignored_Ghost_Node (N) then
+ elsif Is_Ignored_Ghost_Node (N) then
Prune (N);
return Skip;
@@ -1037,138 +1678,106 @@ package body Ghost is
begin
for Index in Ignored_Ghost_Units.First .. Ignored_Ghost_Units.Last loop
- Prune_Tree (Unit (Ignored_Ghost_Units.Table (Index)));
+ Prune_Tree (Ignored_Ghost_Units.Table (Index));
end loop;
end Remove_Ignored_Ghost_Code;
+ ------------------------
+ -- Restore_Ghost_Mode --
+ ------------------------
+
+ procedure Restore_Ghost_Mode (Mode : Ghost_Mode_Type) is
+ begin
+ Ghost_Mode := Mode;
+ end Restore_Ghost_Mode;
+
--------------------
-- Set_Ghost_Mode --
--------------------
- procedure Set_Ghost_Mode (N : Node_Id; Id : Entity_Id := Empty) is
- procedure Set_From_Entity (Ent_Id : Entity_Id);
- -- Set the value of global variable Ghost_Mode depending on the mode of
- -- entity Ent_Id.
-
- procedure Set_From_Policy;
- -- Set the value of global variable Ghost_Mode depending on the current
- -- Ghost policy in effect.
-
- ---------------------
- -- Set_From_Entity --
- ---------------------
-
- procedure Set_From_Entity (Ent_Id : Entity_Id) is
- begin
- Set_Ghost_Mode_From_Entity (Ent_Id);
-
- if Is_Ignored_Ghost_Entity (Ent_Id) then
- Set_Is_Ignored_Ghost_Node (N);
- Propagate_Ignored_Ghost_Code (N);
- end if;
- end Set_From_Entity;
-
- ---------------------
- -- Set_From_Policy --
- ---------------------
+ procedure Set_Ghost_Mode
+ (N : Node_Or_Entity_Id;
+ Mode : out Ghost_Mode_Type)
+ is
+ procedure Set_Ghost_Mode_From_Entity (Id : Entity_Id);
+ -- Install the Ghost mode of entity Id
- procedure Set_From_Policy is
- Policy : constant Name_Id := Policy_In_Effect (Name_Ghost);
+ --------------------------------
+ -- Set_Ghost_Mode_From_Entity --
+ --------------------------------
+ procedure Set_Ghost_Mode_From_Entity (Id : Entity_Id) is
begin
- if Policy = Name_Check then
- Ghost_Mode := Check;
-
- elsif Policy = Name_Ignore then
- Ghost_Mode := Ignore;
-
- Set_Is_Ignored_Ghost_Node (N);
- Propagate_Ignored_Ghost_Code (N);
+ if Is_Checked_Ghost_Entity (Id) then
+ Install_Ghost_Mode (Check);
+ elsif Is_Ignored_Ghost_Entity (Id) then
+ Install_Ghost_Mode (Ignore);
+ else
+ Install_Ghost_Mode (None);
end if;
- end Set_From_Policy;
+ end Set_Ghost_Mode_From_Entity;
-- Local variables
- Nam_Id : Entity_Id;
+ Id : Entity_Id;
-- Start of processing for Set_Ghost_Mode
begin
- -- The input node denotes one of the many declaration kinds that may be
- -- subject to pragma Ghost.
-
- if Is_Declaration (N) then
- if Is_Subject_To_Ghost (N) then
- Set_From_Policy;
+ -- Save the previous Ghost mode in effect
- -- The declaration denotes the completion of a deferred constant,
- -- pragma Ghost appears on the partial declaration.
+ Mode := Ghost_Mode;
- elsif Nkind (N) = N_Object_Declaration
- and then Constant_Present (N)
- and then Present (Id)
- then
- Set_From_Entity (Id);
+ -- The Ghost mode of an assignment statement depends on the Ghost mode
+ -- of the target.
- -- The declaration denotes the full view of a private type, pragma
- -- Ghost appears on the partial declaration.
+ if Nkind (N) = N_Assignment_Statement then
+ Id := Ghost_Entity (Name (N));
- elsif Nkind (N) = N_Full_Type_Declaration
- and then Is_Private_Type (Defining_Entity (N))
- and then Present (Id)
- then
- Set_From_Entity (Id);
+ if Present (Id) then
+ Set_Ghost_Mode_From_Entity (Id);
end if;
- -- The input denotes an assignment or a procedure call. In this case
- -- the Ghost mode is dictated by the name of the construct.
+ -- The Ghost mode of a body or a declaration depends on the Ghost mode
+ -- of its defining entity.
- elsif Nkind_In (N, N_Assignment_Statement,
- N_Procedure_Call_Statement)
- then
- Nam_Id := Ghost_Entity (Name (N));
+ elsif Is_Body (N) or else Is_Declaration (N) then
+ Set_Ghost_Mode_From_Entity (Defining_Entity (N));
- if Present (Nam_Id) then
- Set_From_Entity (Nam_Id);
- end if;
+ -- The Ghost mode of an entity depends on the entity itself
- -- The input denotes a package or subprogram body
+ elsif Nkind (N) in N_Entity then
+ Set_Ghost_Mode_From_Entity (N);
- elsif Nkind_In (N, N_Package_Body, N_Subprogram_Body) then
- if (Present (Id) and then Is_Ghost_Entity (Id))
- or else Is_Subject_To_Ghost (N)
- then
- Set_From_Policy;
- end if;
+ -- The Ghost mode of a [generic] freeze node depends on the Ghost mode
+ -- of the entity being frozen.
+
+ elsif Nkind_In (N, N_Freeze_Entity, N_Freeze_Generic_Entity) then
+ Set_Ghost_Mode_From_Entity (Entity (N));
- -- The input denotes a pragma
+ -- The Ghost mode of a pragma depends on the associated entity. The
+ -- property is encoded in the pragma itself.
- elsif Nkind (N) = N_Pragma and then Is_Ghost_Pragma (N) then
- if Is_Ignored_Ghost_Node (N) then
- Ghost_Mode := Ignore;
+ elsif Nkind (N) = N_Pragma then
+ if Is_Checked_Ghost_Pragma (N) then
+ Install_Ghost_Mode (Check);
+ elsif Is_Ignored_Ghost_Pragma (N) then
+ Install_Ghost_Mode (Ignore);
else
- Ghost_Mode := Check;
+ Install_Ghost_Mode (None);
end if;
- -- The input denotes a freeze node
+ -- The Ghost mode of a procedure call depends on the Ghost mode of the
+ -- procedure being invoked.
- elsif Nkind (N) = N_Freeze_Entity and then Present (Id) then
- Set_From_Entity (Id);
- end if;
- end Set_Ghost_Mode;
-
- --------------------------------
- -- Set_Ghost_Mode_From_Entity --
- --------------------------------
+ elsif Nkind (N) = N_Procedure_Call_Statement then
+ Id := Ghost_Entity (Name (N));
- procedure Set_Ghost_Mode_From_Entity (Id : Entity_Id) is
- begin
- if Is_Checked_Ghost_Entity (Id) then
- Ghost_Mode := Check;
- elsif Is_Ignored_Ghost_Entity (Id) then
- Ghost_Mode := Ignore;
+ if Present (Id) then
+ Set_Ghost_Mode_From_Entity (Id);
+ end if;
end if;
- end Set_Ghost_Mode_From_Entity;
+ end Set_Ghost_Mode;
-------------------------
-- Set_Is_Ghost_Entity --
diff --git a/gcc/ada/ghost.ads b/gcc/ada/ghost.ads
index 3dbe5026ae..e0211c02f1 100644
--- a/gcc/ada/ghost.ads
+++ b/gcc/ada/ghost.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2014-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,6 +26,7 @@
-- This package contains routines that deal with the static and runtime
-- semantics of Ghost entities.
+with Opt; use Opt;
with Types; use Types;
package Ghost is
@@ -35,26 +36,37 @@ package Ghost is
-- post processing.
procedure Check_Ghost_Completion
- (Partial_View : Entity_Id;
- Full_View : Entity_Id);
- -- Verify that the Ghost policy of a full view or a completion is the same
- -- as the Ghost policy of the partial view. Emit an error if this is not
- -- the case.
+ (Prev_Id : Entity_Id;
+ Compl_Id : Entity_Id);
+ -- Verify that the Ghost policy of initial entity Prev_Id is compatible
+ -- with the Ghost policy of completing entity Compl_Id. Emit an error if
+ -- this is not the case.
- procedure Check_Ghost_Context (Ghost_Id : Entity_Id; Ghost_Ref : Node_Id);
+ procedure Check_Ghost_Context
+ (Ghost_Id : Entity_Id;
+ Ghost_Ref : Node_Id);
-- Determine whether node Ghost_Ref appears within a Ghost-friendly context
-- where Ghost entity Ghost_Id can safely reside.
- procedure Check_Ghost_Derivation (Typ : Entity_Id);
- -- Verify that the parent type and all progenitors of derived type or type
- -- extension Typ are Ghost. If this is not the case, issue an error.
-
procedure Check_Ghost_Overriding
(Subp : Entity_Id;
Overridden_Subp : Entity_Id);
- -- Verify that the Ghost policy of parent subprogram Overridden_Subp is the
- -- same as the Ghost policy of overriding subprogram Subp. Emit an error if
- -- this is not the case.
+ -- Verify that the Ghost policy of parent subprogram Overridden_Subp is
+ -- compatible with the Ghost policy of overriding subprogram Subp. Emit
+ -- an error if this is not the case.
+
+ procedure Check_Ghost_Primitive (Prim : Entity_Id; Typ : Entity_Id);
+ -- Verify that the Ghost policy of primitive operation Prim is the same as
+ -- the Ghost policy of tagged type Typ. Emit an error if this is not the
+ -- case.
+
+ procedure Check_Ghost_Refinement
+ (State : Node_Id;
+ State_Id : Entity_Id;
+ Constit : Node_Id;
+ Constit_Id : Entity_Id);
+ -- Verify that the Ghost policy of constituent Constit_Id is compatible
+ -- with the Ghost policy of abstract state State_I.
function Implements_Ghost_Interface (Typ : Entity_Id) return Boolean;
-- Determine whether type Typ implements at least one Ghost interface
@@ -62,70 +74,158 @@ package Ghost is
procedure Initialize;
-- Initialize internal tables
- procedure Lock;
- -- Lock internal tables before calling backend
+ procedure Install_Ghost_Mode (Mode : Ghost_Mode_Type);
+ -- Set the value of global variable Ghost_Mode depending on the Ghost
+ -- policy denoted by Mode.
- procedure Mark_Full_View_As_Ghost
- (Priv_Typ : Entity_Id;
- Full_Typ : Entity_Id);
- -- Set all Ghost-related attributes of type Full_Typ depending on the Ghost
- -- mode of incomplete or private type Priv_Typ.
+ function Is_Ghost_Assignment (N : Node_Id) return Boolean;
+ -- Determine whether arbitrary node N denotes an assignment statement whose
+ -- target is a Ghost entity.
- procedure Mark_Pragma_As_Ghost
- (Prag : Node_Id;
- Context_Id : Entity_Id);
- -- Set all Ghost-related attributes of pragma Prag if its context denoted
- -- by Id is a Ghost entity.
+ function Is_Ghost_Declaration (N : Node_Id) return Boolean;
+ -- Determine whether arbitrary node N denotes a declaration which defines
+ -- a Ghost entity.
- procedure Mark_Renaming_As_Ghost
- (Ren_Decl : Node_Id;
- Nam_Id : Entity_Id);
- -- Set all Ghost-related attributes of renaming declaration Ren_Decl if its
- -- renamed name denoted by Nam_Id is a Ghost entity.
+ function Is_Ghost_Pragma (N : Node_Id) return Boolean;
+ -- Determine whether arbitrary node N denotes a pragma which encloses a
+ -- Ghost entity or is associated with a Ghost entity.
- procedure Remove_Ignored_Ghost_Code;
- -- Remove all code marked as ignored Ghost from the trees of all qualifying
- -- units.
- --
- -- WARNING: this is a separate front end pass, care should be taken to keep
- -- it optimized.
+ function Is_Ghost_Procedure_Call (N : Node_Id) return Boolean;
+ -- Determine whether arbitrary node N denotes a procedure call invoking a
+ -- Ghost procedure.
- procedure Set_Ghost_Mode (N : Node_Id; Id : Entity_Id := Empty);
- -- Set the value of global variable Ghost_Mode depending on the following
- -- scenarios:
+ function Is_Ignored_Ghost_Unit (N : Node_Id) return Boolean;
+ -- Determine whether compilation unit N is subject to pragma Ghost with
+ -- policy Ignore.
+
+ procedure Lock;
+ -- Lock internal tables before calling backend
+
+ procedure Mark_And_Set_Ghost_Assignment
+ (N : Node_Id;
+ Mode : out Ghost_Mode_Type);
+ -- Mark assignment statement N as Ghost when:
+ --
+ -- * The left hand side denotes a Ghost entity
+ --
+ -- Install the Ghost mode of the assignment statement. Mode is the Ghost
+ -- mode in effect prior to processing the assignment. This routine starts
+ -- a Ghost region and must be used in conjunction with Restore_Ghost_Mode.
+
+ procedure Mark_And_Set_Ghost_Body
+ (N : Node_Id;
+ Spec_Id : Entity_Id;
+ Mode : out Ghost_Mode_Type);
+ -- Mark package or subprogram body N as Ghost when:
+ --
+ -- * The body is subject to pragma Ghost
+ --
+ -- * The body completes a previous declaration whose spec denoted by
+ -- Spec_Id is a Ghost entity.
+ --
+ -- * The body appears within a Ghost region
--
- -- If N is a declaration, determine whether N is subject to pragma Ghost.
- -- If this is the case, the Ghost_Mode is set based on the current Ghost
- -- policy in effect. Special cases:
+ -- Install the Ghost mode of the body. Mode is the Ghost mode prior to
+ -- processing the body. This routine starts a Ghost region and must be
+ -- used in conjunction with Restore_Ghost_Mode.
+
+ procedure Mark_And_Set_Ghost_Completion
+ (N : Node_Id;
+ Prev_Id : Entity_Id;
+ Mode : out Ghost_Mode_Type);
+ -- Mark completion N of a deferred constant or private type [extension]
+ -- Ghost when:
--
- -- N is the completion of a deferred constant, the Ghost_Mode is set
- -- based on the mode of partial declaration entity denoted by Id.
+ -- * The entity of the previous declaration denoted by Prev_Id is Ghost
--
- -- N is the full view of a private type, the Ghost_Mode is set based
- -- on the mode of the partial declaration entity denoted by Id.
+ -- * The completion appears within a Ghost region
--
- -- If N is an assignment statement or a procedure call, the Ghost_Mode is
- -- set based on the mode of the name.
+ -- Install the Ghost mode of the completion. Mode is the Ghost mode prior
+ -- to processing the completion. This routine starts a Ghost region and
+ -- must be used in conjunction with Restore_Ghost_Mode.
+
+ procedure Mark_And_Set_Ghost_Declaration
+ (N : Node_Id;
+ Mode : out Ghost_Mode_Type);
+ -- Mark declaration N as Ghost when:
--
- -- If N denotes a package or a subprogram body, the Ghost_Mode is set to
- -- the current Ghost policy in effect if the body is subject to Ghost or
- -- the corresponding spec denoted by Id is a Ghost entity.
+ -- * The declaration is subject to pragma Ghost
--
- -- If N is a pragma, the Ghost_Mode is set based on the mode of the
- -- pragma.
+ -- * The declaration denotes a child package or subprogram and the parent
+ -- is a Ghost unit.
--
- -- If N is a freeze node, the Global_Mode is set based on the mode of
- -- entity Id.
+ -- * The declaration appears within a Ghost region
--
- -- WARNING: the caller must save and restore the value of Ghost_Mode in a
- -- a stack-like fasion as this routine may override the existing value.
+ -- Install the Ghost mode of the declaration. Mode is the Ghost mode prior
+ -- to processing the declaration. This routine starts a Ghost region and
+ -- must be used in conjunction with Restore_Ghost_Mode.
+
+ procedure Mark_And_Set_Ghost_Instantiation
+ (N : Node_Id;
+ Gen_Id : Entity_Id;
+ Mode : out Ghost_Mode_Type);
+ -- Mark instantiation N as Ghost when:
+ --
+ -- * The instantiation is subject to pragma Ghost
+ --
+ -- * The generic template denoted by Gen_Id is Ghost
+ --
+ -- * The instantiation appears within a Ghost region
+ --
+ -- Install the Ghost mode of the instantiation. Mode is the Ghost mode
+ -- prior to processing the instantiation. This routine starts a Ghost
+ -- region and must be used in conjunction with Restore_Ghost_Mode.
+
+ procedure Mark_And_Set_Ghost_Procedure_Call
+ (N : Node_Id;
+ Mode : out Ghost_Mode_Type);
+ -- Mark procedure call N as Ghost when:
+ --
+ -- * The procedure being invoked is a Ghost entity
+ --
+ -- Install the Ghost mode of the procedure call. Mode is the Ghost mode
+ -- prior to processing the procedure call. This routine starts a Ghost
+ -- region and must be used in conjunction with Restore_Ghost_Mode.
+
+ procedure Mark_Ghost_Clause (N : Node_Id);
+ -- Mark use package, use type, or with clause N as Ghost when:
+ --
+ -- * The clause mentions a Ghost entity
+
+ procedure Mark_Ghost_Pragma
+ (N : Node_Id;
+ Id : Entity_Id);
+ -- Mark pragma N as Ghost when:
+ --
+ -- * The pragma encloses Ghost entity Id
+ --
+ -- * The pragma is associated with Ghost entity Id
- procedure Set_Ghost_Mode_From_Entity (Id : Entity_Id);
- -- Set the valye of global variable Ghost_Mode depending on the mode of
- -- entity Id.
+ procedure Mark_Ghost_Renaming
+ (N : Node_Id;
+ Id : Entity_Id);
+ -- Mark renaming declaration N as Ghost when:
--
- -- WARNING: the caller must save and restore the value of Ghost_Mode in a
- -- a stack-like fasion as this routine may override the existing value.
+ -- * Renamed entity Id denotes a Ghost entity
+
+ procedure Remove_Ignored_Ghost_Code;
+ -- Remove all code marked as ignored Ghost from the trees of all qualifying
+ -- units (SPARK RM 6.9(4)).
+ --
+ -- WARNING: this is a separate front end pass, care should be taken to keep
+ -- it optimized.
+
+ procedure Restore_Ghost_Mode (Mode : Ghost_Mode_Type);
+ -- Terminate a Ghost region by restoring the Ghost mode prior to the
+ -- region denoted by Mode. This routine must be used in conjunction
+ -- with Mark_And_Set_xxx routines as well as Set_Ghost_Mode.
+
+ procedure Set_Ghost_Mode
+ (N : Node_Or_Entity_Id;
+ Mode : out Ghost_Mode_Type);
+ -- Install the Ghost mode of arbitrary node N. Mode is the Ghost mode prior
+ -- to processing the node. This routine starts a Ghost region and must be
+ -- used in conjunction with Restore_Ghost_Mode.
procedure Set_Is_Ghost_Entity (Id : Entity_Id);
-- Set the relevant Ghost attributes of entity Id depending on the current
diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb
index b8ea58595e..30ccd61043 100644
--- a/gcc/ada/gnat1drv.adb
+++ b/gcc/ada/gnat1drv.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -36,7 +36,7 @@ with Fmap;
with Fname; use Fname;
with Fname.UF; use Fname.UF;
with Frontend;
-with Ghost;
+with Ghost; use Ghost;
with Gnatvsn; use Gnatvsn;
with Inline;
with Lib; use Lib;
@@ -46,6 +46,7 @@ with Namet; use Namet;
with Nlists;
with Opt; use Opt;
with Osint; use Osint;
+with Osint.C; use Osint.C;
with Output; use Output;
with Par_SCO;
with Prepcomp;
@@ -88,24 +89,16 @@ with System.OS_Lib;
--------------
procedure Gnat1drv is
- Main_Unit_Node : Node_Id;
- -- Compilation unit node for main unit
-
- Main_Kind : Node_Kind;
- -- Kind of main compilation unit node
-
- Back_End_Mode : Back_End.Back_End_Mode_Type;
- -- Record back end mode
-
procedure Adjust_Global_Switches;
- -- There are various interactions between front end switch settings,
+ -- There are various interactions between front-end switch settings,
-- including debug switch settings and target dependent parameters.
-- This procedure takes care of properly handling these interactions.
-- We do it after scanning out all the switches, so that we are not
-- depending on the order in which switches appear.
- procedure Check_Bad_Body;
- -- Called to check if the unit we are compiling has a bad body
+ procedure Check_Bad_Body (Unit_Node : Node_Id; Unit_Kind : Node_Kind);
+ -- Called to check whether a unit described by its compilation unit node
+ -- and kind has a bad body.
procedure Check_Rep_Info;
-- Called when we are not generating code, to check if -gnatR was requested
@@ -147,6 +140,7 @@ procedure Gnat1drv is
if Generate_C_Code then
Modify_Tree_For_C := True;
Unnest_Subprogram_Mode := True;
+ Minimize_Expression_With_Actions := True;
-- Set operating mode to Generate_Code to benefit from full front-end
-- expansion (e.g. generics).
@@ -178,6 +172,12 @@ procedure Gnat1drv is
if Operating_Mode = Check_Semantics and then Tree_Output then
ASIS_Mode := True;
+ -- Set ASIS GNSA mode if -gnatd.H is set
+
+ if Debug_Flag_Dot_HH then
+ ASIS_GNSA_Mode := True;
+ end if;
+
-- Turn off inlining in ASIS mode, since ASIS cannot handle the extra
-- information in the trees caused by inlining being active.
@@ -259,8 +259,7 @@ procedure Gnat1drv is
-- Enable all other language checks
Suppress_Options.Suppress :=
- (Access_Check => True,
- Alignment_Check => True,
+ (Alignment_Check => True,
Division_Check => True,
Elaboration_Check => True,
others => False);
@@ -287,9 +286,13 @@ procedure Gnat1drv is
Debug_Generated_Code := False;
+ -- Disable Exception_Extra_Info (-gnateE) which generates more
+ -- complex trees with no added value, and may confuse CodePeer.
+
+ Exception_Extra_Info := False;
+
-- Turn cross-referencing on in case it was disabled (e.g. by -gnatD)
- -- Do we really need to spend time generating xref in CodePeer
- -- mode??? Consider setting Xref_Active to False.
+ -- to support source navigation.
Xref_Active := True;
@@ -310,24 +313,15 @@ procedure Gnat1drv is
Assertions_Enabled := True;
- -- Disable all simple value propagation. This is an optimization
- -- which is valuable for code optimization, and also for generation
- -- of compiler warnings, but these are being turned off by default,
- -- and CodePeer generates better messages (referencing original
- -- variables) this way.
-
- Debug_Flag_MM := True;
-
- -- Set normal RM validity checking, and checking of IN OUT parameters
- -- (this might give CodePeer more useful checks to analyze, to be
- -- confirmed???). All other validity checking is turned off, since
- -- this can generate very complex trees that only confuse CodePeer
- -- and do not bring enough useful info.
+ -- Set normal RM validity checking and checking of copies (to catch
+ -- e.g. wrong values used in unchecked conversions).
+ -- All other validity checking is turned off, since this can generate
+ -- very complex trees that only confuse CodePeer and do not bring
+ -- enough useful info.
Reset_Validity_Check_Options;
Validity_Check_Default := True;
- Validity_Check_In_Out_Params := True;
- Validity_Check_In_Params := True;
+ Validity_Check_Copies := True;
-- Turn off style check options and ignore any style check pragmas
-- since we are not interested in any front-end warnings when we are
@@ -342,12 +336,24 @@ procedure Gnat1drv is
Force_ALI_Tree_File := True;
Try_Semantics := True;
- -- Make the Ada front-end more liberal so that the compiler will
+ -- Make the Ada front end more liberal so that the compiler will
-- allow illegal code that is allowed by other compilers. CodePeer
-- is in the business of finding problems, not enforcing rules.
-- This is useful when using CodePeer mode with other compilers.
Relaxed_RM_Semantics := True;
+
+ -- Disable all simple value propagation. This is an optimization
+ -- which is valuable for code optimization, and also for generation
+ -- of compiler warnings, but these are being turned off by default,
+ -- and CodePeer generates better messages (referencing original
+ -- variables) this way.
+ -- Do this only if -gnatws is set (the default with -gnatcC), so that
+ -- if warnings are enabled, we'll get better messages from GNAT.
+
+ if Warning_Mode = Suppress then
+ Debug_Flag_MM := True;
+ end if;
end if;
-- Enable some individual switches that are implied by relaxed RM
@@ -406,11 +412,6 @@ procedure Gnat1drv is
Suppress_Options.Suppress := (others => False);
- -- Turn off dynamic elaboration checks. SPARK mode depends on the
- -- use of the static elaboration mode.
-
- Dynamic_Elaboration_Checks := False;
-
-- Detect overflow on unconstrained floating-point types, such as
-- the predefined types Float, Long_Float and Long_Long_Float from
-- package Standard. Not necessary if float overflows are checked
@@ -519,34 +520,43 @@ procedure Gnat1drv is
Ttypes.Bytes_Big_Endian := not Ttypes.Bytes_Big_Endian;
end if;
- -- Activate front end layout if debug flag -gnatdF is set
+ -- Activate front-end layout if debug flag -gnatdF is set
if Debug_Flag_FF then
Targparm.Frontend_Layout_On_Target := True;
end if;
- -- Set and check exception mechanism
-
- case Targparm.Frontend_Exceptions_On_Target is
- when True =>
- case Targparm.ZCX_By_Default_On_Target is
- when True =>
- Write_Line
- ("Run-time library configured incorrectly");
- Write_Line
- ("(requesting support for Frontend ZCX exceptions)");
- raise Unrecoverable_Error;
- when False =>
- Exception_Mechanism := Front_End_SJLJ;
- end case;
- when False =>
- case Targparm.ZCX_By_Default_On_Target is
- when True =>
- Exception_Mechanism := Back_End_ZCX;
- when False =>
- Exception_Mechanism := Back_End_SJLJ;
- end case;
- end case;
+ -- Set and check exception mechanism. This is only meaningful when
+ -- compiling, and in particular not meaningful for special modes used
+ -- for program analysis rather than compilation: ASIS mode, CodePeer
+ -- mode and GNATprove mode.
+
+ if Operating_Mode = Generate_Code
+ and then not (ASIS_Mode or CodePeer_Mode or GNATprove_Mode)
+ then
+ case Targparm.Frontend_Exceptions_On_Target is
+ when True =>
+ case Targparm.ZCX_By_Default_On_Target is
+ when True =>
+ Write_Line
+ ("Run-time library configured incorrectly");
+ Write_Line
+ ("(requesting support for Frontend ZCX exceptions)");
+ raise Unrecoverable_Error;
+
+ when False =>
+ Exception_Mechanism := Front_End_SJLJ;
+ end case;
+
+ when False =>
+ case Targparm.ZCX_By_Default_On_Target is
+ when True =>
+ Exception_Mechanism := Back_End_ZCX;
+ when False =>
+ Exception_Mechanism := Back_End_SJLJ;
+ end case;
+ end case;
+ end if;
-- Set proper status for overflow check mechanism
@@ -624,11 +634,9 @@ procedure Gnat1drv is
if Debug_Flag_Dot_LL then
Back_End_Handles_Limited_Types := True;
- -- If no debug flag, usage off for AAMP, SCIL cases
+ -- If no debug flag, usage off for SCIL cases
- elsif AAMP_On_Target
- or else Generate_SCIL
- then
+ elsif Generate_SCIL then
Back_End_Handles_Limited_Types := False;
-- Otherwise normal gcc back end, for now still turn flag off by
@@ -657,34 +665,30 @@ procedure Gnat1drv is
-- back end some day, it would not be true for this test, but it
-- would be non-GCC, so this is a bit troublesome ???
- Front_End_Inlining := AAMP_On_Target or Generate_C_Code;
+ Front_End_Inlining := Generate_C_Code;
end if;
- -- Set back end inlining indication
+ -- Set back-end inlining indication
Back_End_Inlining :=
- -- No back end inlining available on AAMP
-
- not AAMP_On_Target
+ -- No back-end inlining available on C generation
- -- No back end inlining available on C generation
+ not Generate_C_Code
- and then not Generate_C_Code
-
- -- No back end inlining in GNATprove mode, since it just confuses
+ -- No back-end inlining in GNATprove mode, since it just confuses
-- the formal verification process.
and then not GNATprove_Mode
- -- No back end inlining if front end inlining explicitly enabled.
+ -- No back-end inlining if front-end inlining explicitly enabled.
-- Done to minimize the output differences to customers still using
-- this deprecated switch; in addition, this behavior reduces the
-- output differences in old tests.
and then not Front_End_Inlining
- -- Back end inlining is disabled if debug flag .z is set
+ -- Back-end inlining is disabled if debug flag .z is set
and then not Debug_Flag_Dot_Z;
@@ -714,10 +718,8 @@ procedure Gnat1drv is
-- Check_Bad_Body --
--------------------
- procedure Check_Bad_Body is
- Sname : Unit_Name_Type;
- Src_Ind : Source_File_Index;
- Fname : File_Name_Type;
+ procedure Check_Bad_Body (Unit_Node : Node_Id; Unit_Kind : Node_Kind) is
+ Fname : File_Name_Type;
procedure Bad_Body_Error (Msg : String);
-- Issue message for bad body found
@@ -728,11 +730,16 @@ procedure Gnat1drv is
procedure Bad_Body_Error (Msg : String) is
begin
- Error_Msg_N (Msg, Main_Unit_Node);
+ Error_Msg_N (Msg, Unit_Node);
Error_Msg_File_1 := Fname;
- Error_Msg_N ("remove incorrect body in file{!", Main_Unit_Node);
+ Error_Msg_N ("remove incorrect body in file{!", Unit_Node);
end Bad_Body_Error;
+ -- Local variables
+
+ Sname : Unit_Name_Type;
+ Src_Ind : Source_File_Index;
+
-- Start of processing for Check_Bad_Body
begin
@@ -745,13 +752,13 @@ procedure Gnat1drv is
-- Check for body not allowed
- if (Main_Kind = N_Package_Declaration
- and then not Body_Required (Main_Unit_Node))
- or else (Main_Kind = N_Generic_Package_Declaration
- and then not Body_Required (Main_Unit_Node))
- or else Main_Kind = N_Package_Renaming_Declaration
- or else Main_Kind = N_Subprogram_Renaming_Declaration
- or else Nkind (Original_Node (Unit (Main_Unit_Node)))
+ if (Unit_Kind = N_Package_Declaration
+ and then not Body_Required (Unit_Node))
+ or else (Unit_Kind = N_Generic_Package_Declaration
+ and then not Body_Required (Unit_Node))
+ or else Unit_Kind = N_Package_Renaming_Declaration
+ or else Unit_Kind = N_Subprogram_Renaming_Declaration
+ or else Nkind (Original_Node (Unit (Unit_Node)))
in N_Generic_Instantiation
then
Sname := Unit_Name (Main_Unit);
@@ -795,16 +802,16 @@ procedure Gnat1drv is
-- be incorrect (we may have misinterpreted a junk spec as not
-- needing a body when it really does).
- if Main_Kind = N_Package_Declaration
+ if Unit_Kind = N_Package_Declaration
and then Ada_Version = Ada_83
and then Operating_Mode = Generate_Code
and then Distribution_Stub_Mode /= Generate_Caller_Stub_Body
and then not Compilation_Errors
then
Error_Msg_N
- ("package $$ does not require a body??", Main_Unit_Node);
+ ("package $$ does not require a body??", Unit_Node);
Error_Msg_File_1 := Fname;
- Error_Msg_N ("body in file{ will be ignored??", Main_Unit_Node);
+ Error_Msg_N ("body in file{ will be ignored??", Unit_Node);
-- Ada 95 cases of a body file present when no body is
-- permitted. This we consider to be an error.
@@ -812,15 +819,15 @@ procedure Gnat1drv is
else
-- For generic instantiations, we never allow a body
- if Nkind (Original_Node (Unit (Main_Unit_Node))) in
+ if Nkind (Original_Node (Unit (Unit_Node))) in
N_Generic_Instantiation
then
Bad_Body_Error
("generic instantiation for $$ does not allow a body");
- -- A library unit that is a renaming never allows a body
+ -- A library unit that is a renaming never allows a body
- elsif Main_Kind in N_Renaming_Declaration then
+ elsif Unit_Kind in N_Renaming_Declaration then
Bad_Body_Error
("renaming declaration for $$ does not allow a body!");
@@ -831,11 +838,11 @@ procedure Gnat1drv is
-- body when in fact it does.
elsif not Compilation_Errors then
- if Main_Kind = N_Package_Declaration then
+ if Unit_Kind = N_Package_Declaration then
Bad_Body_Error
("package $$ does not allow a body!");
- elsif Main_Kind = N_Generic_Package_Declaration then
+ elsif Unit_Kind = N_Generic_Package_Declaration then
Bad_Body_Error
("generic package $$ does not allow a body!");
end if;
@@ -878,6 +885,18 @@ procedure Gnat1drv is
Checks.Validate_Alignment_Check_Warnings;
+ -- Validate compile time warnings and errors (using the values for size
+ -- and alignment annotated by the backend where possible). We need to
+ -- unlock temporarily these tables to reanalyze their expression.
+
+ Atree.Unlock;
+ Nlists.Unlock;
+ Sem.Unlock;
+ Sem_Ch13.Validate_Compile_Time_Warning_Errors;
+ Sem.Lock;
+ Nlists.Lock;
+ Atree.Lock;
+
-- Validate unchecked conversions (using the values for size and
-- alignment annotated by the backend where possible).
@@ -895,9 +914,19 @@ procedure Gnat1drv is
if AAMP_On_Target then
Sem_Ch13.Validate_Independence;
end if;
-
end Post_Compilation_Validation_Checks;
+ -- Local variables
+
+ Back_End_Mode : Back_End.Back_End_Mode_Type;
+ Ecode : Exit_Code_Type;
+
+ Main_Unit_Kind : Node_Kind;
+ -- Kind of main compilation unit node
+
+ Main_Unit_Node : Node_Id;
+ -- Compilation unit node for main unit
+
-- Start of processing for Gnat1drv
begin
@@ -1054,8 +1083,9 @@ begin
end if;
Main_Unit_Node := Cunit (Main_Unit);
- Main_Kind := Nkind (Unit (Main_Unit_Node));
- Check_Bad_Body;
+ Main_Unit_Kind := Nkind (Unit (Main_Unit_Node));
+
+ Check_Bad_Body (Main_Unit_Node, Main_Unit_Kind);
-- In CodePeer mode we always delete old SCIL files before regenerating
-- new ones, in case of e.g. errors, and also to remove obsolete scilx
@@ -1065,6 +1095,13 @@ begin
Comperr.Delete_SCIL_Files;
end if;
+ -- Ditto for old C files before regenerating new ones
+
+ if Generate_C_Code then
+ Delete_C_File;
+ Delete_H_File;
+ end if;
+
-- Exit if compilation errors detected
Errout.Finalize (Last_Call => False);
@@ -1141,34 +1178,34 @@ begin
-- subunits. Note that we always generate code for all generic units (a
-- change from some previous versions of GNAT).
- elsif Main_Kind = N_Subprogram_Body and then not Subunits_Missing then
+ elsif Main_Unit_Kind = N_Subprogram_Body
+ and then not Subunits_Missing
+ then
Back_End_Mode := Generate_Object;
-- We can generate code for a package body unless there are subunits
-- missing (note that we always generate code for generic units, which
-- is a change from some earlier versions of GNAT).
- elsif Main_Kind = N_Package_Body and then not Subunits_Missing then
+ elsif Main_Unit_Kind = N_Package_Body and then not Subunits_Missing then
Back_End_Mode := Generate_Object;
-- We can generate code for a package declaration or a subprogram
-- declaration only if it does not required a body.
- elsif Nkind_In (Main_Kind,
- N_Package_Declaration,
- N_Subprogram_Declaration)
+ elsif Nkind_In (Main_Unit_Kind, N_Package_Declaration,
+ N_Subprogram_Declaration)
and then
(not Body_Required (Main_Unit_Node)
- or else
- Distribution_Stub_Mode = Generate_Caller_Stub_Body)
+ or else Distribution_Stub_Mode = Generate_Caller_Stub_Body)
then
Back_End_Mode := Generate_Object;
-- We can generate code for a generic package declaration of a generic
-- subprogram declaration only if does not require a body.
- elsif Nkind_In (Main_Kind, N_Generic_Package_Declaration,
- N_Generic_Subprogram_Declaration)
+ elsif Nkind_In (Main_Unit_Kind, N_Generic_Package_Declaration,
+ N_Generic_Subprogram_Declaration)
and then not Body_Required (Main_Unit_Node)
then
Back_End_Mode := Generate_Object;
@@ -1176,15 +1213,15 @@ begin
-- Compilation units that are renamings do not require bodies, so we can
-- generate code for them.
- elsif Nkind_In (Main_Kind, N_Package_Renaming_Declaration,
- N_Subprogram_Renaming_Declaration)
+ elsif Nkind_In (Main_Unit_Kind, N_Package_Renaming_Declaration,
+ N_Subprogram_Renaming_Declaration)
then
Back_End_Mode := Generate_Object;
-- Compilation units that are generic renamings do not require bodies
-- so we can generate code for them.
- elsif Main_Kind in N_Generic_Renaming_Declaration then
+ elsif Main_Unit_Kind in N_Generic_Renaming_Declaration then
Back_End_Mode := Generate_Object;
-- It is not an error to analyze in CodePeer mode a spec which requires
@@ -1224,46 +1261,66 @@ begin
-- generate code).
if Back_End_Mode = Skip then
- Set_Standard_Error;
- Write_Str ("cannot generate code for ");
- Write_Str ("file ");
- Write_Name (Unit_File_Name (Main_Unit));
- if Subunits_Missing then
- Write_Str (" (missing subunits)");
- Write_Eol;
+ -- An ignored Ghost unit is rewritten into a null statement because
+ -- it must not produce an ALI or object file. Do not emit any errors
+ -- related to code generation because the unit does not exist.
+
+ if Is_Ignored_Ghost_Unit (Main_Unit_Node) then
- -- Force generation of ALI file, for backward compatibility
+ -- Exit the gnat driver with success, otherwise external builders
+ -- such as gnatmake and gprbuild will treat the compilation of an
+ -- ignored Ghost unit as a failure. Note that this will produce
+ -- an empty object file for the unit.
- Opt.Force_ALI_Tree_File := True;
+ Ecode := E_Success;
- elsif Main_Kind = N_Subunit then
- Write_Str (" (subunit)");
- Write_Eol;
+ -- Otherwise the unit is missing a crucial piece that prevents code
+ -- generation.
- -- Force generation of ALI file, for backward compatibility
+ else
+ Ecode := E_No_Code;
- Opt.Force_ALI_Tree_File := True;
+ Set_Standard_Error;
+ Write_Str ("cannot generate code for file ");
+ Write_Name (Unit_File_Name (Main_Unit));
- elsif Main_Kind = N_Subprogram_Declaration then
- Write_Str (" (subprogram spec)");
- Write_Eol;
+ if Subunits_Missing then
+ Write_Str (" (missing subunits)");
+ Write_Eol;
- -- Generic package body in GNAT implementation mode
+ -- Force generation of ALI file, for backward compatibility
- elsif Main_Kind = N_Package_Body and then GNAT_Mode then
- Write_Str (" (predefined generic)");
- Write_Eol;
+ Opt.Force_ALI_Tree_File := True;
- -- Force generation of ALI file, for backward compatibility
+ elsif Main_Unit_Kind = N_Subunit then
+ Write_Str (" (subunit)");
+ Write_Eol;
- Opt.Force_ALI_Tree_File := True;
+ -- Force generation of ALI file, for backward compatibility
- -- Only other case is a package spec
+ Opt.Force_ALI_Tree_File := True;
- else
- Write_Str (" (package spec)");
- Write_Eol;
+ elsif Main_Unit_Kind = N_Subprogram_Declaration then
+ Write_Str (" (subprogram spec)");
+ Write_Eol;
+
+ -- Generic package body in GNAT implementation mode
+
+ elsif Main_Unit_Kind = N_Package_Body and then GNAT_Mode then
+ Write_Str (" (predefined generic)");
+ Write_Eol;
+
+ -- Force generation of ALI file, for backward compatibility
+
+ Opt.Force_ALI_Tree_File := True;
+
+ -- Only other case is a package spec
+
+ else
+ Write_Str (" (package spec)");
+ Write_Eol;
+ end if;
end if;
Set_Standard_Output;
@@ -1284,25 +1341,32 @@ begin
Namet.Finalize;
Check_Rep_Info;
- -- Exit program with error indication, to kill object file
+ -- Exit the driver with an appropriate status indicator. This will
+ -- generate an empty object file for ignored Ghost units, otherwise
+ -- no object file will be generated.
- Exit_Program (E_No_Code);
+ Exit_Program (Ecode);
end if;
-- In -gnatc mode, we only do annotation if -gnatt or -gnatR is also set
-- as indicated by Back_Annotate_Rep_Info being set to True.
-- We don't call for annotations on a subunit, because to process those
- -- the back-end requires that the parent(s) be properly compiled.
+ -- the back end requires that the parent(s) be properly compiled.
-- Annotation is suppressed for targets where front-end layout is
-- enabled, because the front end determines representations.
+ -- The back end is not invoked in ASIS mode with GNSA because all type
+ -- representation information will be provided by the GNSA back end, not
+ -- gigi.
+
if Back_End_Mode = Declarations_Only
and then
(not (Back_Annotate_Rep_Info or Generate_SCIL or GNATprove_Mode)
- or else Main_Kind = N_Subunit
- or else Frontend_Layout_On_Target)
+ or else Main_Unit_Kind = N_Subunit
+ or else Frontend_Layout_On_Target
+ or else ASIS_GNSA_Mode)
then
Post_Compilation_Validation_Checks;
Errout.Finalize (Last_Call => True);
@@ -1383,7 +1447,7 @@ begin
-- are delayed till now, since it is perfectly possible for gigi to
-- generate errors, modify the tree (in particular by setting flags
-- indicating that elaboration is required, and also to back annotate
- -- representation information for List_Rep_Info.
+ -- representation information for List_Rep_Info).
Errout.Finalize (Last_Call => True);
Errout.Output_Messages;
@@ -1445,11 +1509,10 @@ begin
when Program_Error =>
Comperr.Compiler_Abort ("Program_Error");
- when Storage_Error =>
-
- -- Assume this is a bug. If it is real, the message will in any case
- -- say Storage_Error, giving a strong hint.
+ -- Assume this is a bug. If it is real, the message will in any case
+ -- say Storage_Error, giving a strong hint.
+ when Storage_Error =>
Comperr.Compiler_Abort ("Storage_Error");
when Unrecoverable_Error =>
@@ -1462,7 +1525,7 @@ begin
<<End_Of_Program>>
null;
- -- The outer exception handles an unrecoverable error
+-- The outer exception handler handles an unrecoverable error
exception
when Unrecoverable_Error =>
diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi
index 405aa5a26f..c51ff384c9 100644
--- a/gcc/ada/gnat_rm.texi
+++ b/gcc/ada/gnat_rm.texi
@@ -21,11 +21,11 @@
@copying
@quotation
-GNAT Reference Manual , November 18, 2015
+GNAT Reference Manual , January 13, 2017
AdaCore
-Copyright @copyright{} 2008-2016, Free Software Foundation
+Copyright @copyright{} 2008-2017, Free Software Foundation
@end quotation
@end copying
@@ -200,6 +200,7 @@ Implementation Defined Pragmas
* Pragma Machine_Attribute::
* Pragma Main::
* Pragma Main_Storage::
+* Pragma Max_Queue_Length::
* Pragma No_Body::
* Pragma No_Elaboration_Code_All::
* Pragma No_Inline::
@@ -221,6 +222,7 @@ Implementation Defined Pragmas
* Pragma Post::
* Pragma Postcondition::
* Pragma Post_Class::
+* Pragma Rename_Pragma::
* Pragma Pre::
* Pragma Precondition::
* Pragma Predicate::
@@ -246,6 +248,7 @@ Implementation Defined Pragmas
* Pragma Restricted_Run_Time::
* Pragma Restriction_Warnings::
* Pragma Reviewable::
+* Pragma Secondary_Stack_Size::
* Pragma Share_Generic::
* Pragma Shared::
* Pragma Short_Circuit_And_Or::
@@ -283,6 +286,7 @@ Implementation Defined Pragmas
* Pragma Unreserve_All_Interrupts::
* Pragma Unsuppress::
* Pragma Use_VADS_Size::
+* Pragma Unused::
* Pragma Validity_Checks::
* Pragma Volatile::
* Pragma Volatile_Full_Access::
@@ -319,6 +323,7 @@ Implementation Defined Aspects
* Aspect Iterable::
* Aspect Linker_Section::
* Aspect Lock_Free::
+* Aspect Max_Queue_Length::
* Aspect No_Elaboration_Code_All::
* Aspect No_Tagged_Streams::
* Aspect Object_Size::
@@ -332,6 +337,7 @@ Implementation Defined Aspects
* Aspect Refined_Post::
* Aspect Refined_State::
* Aspect Remote_Access_Type::
+* Aspect Secondary_Stack_Size::
* Aspect Scalar_Storage_Order::
* Aspect Shared::
* Aspect Simple_Storage_Pool::
@@ -377,6 +383,7 @@ Implementation Defined Attributes
* Attribute Enum_Val::
* Attribute Epsilon::
* Attribute Fast_Math::
+* Attribute Finalization_Size::
* Attribute Fixed_Value::
* Attribute From_Any::
* Attribute Has_Access_Values::
@@ -469,7 +476,6 @@ Partition-Wide Restrictions
* No_Implicit_Conditionals::
* No_Implicit_Dynamic_Code::
* No_Implicit_Heap_Allocations::
-* No_Implicit_Loops::
* No_Implicit_Protected_Object_Allocations::
* No_Implicit_Task_Allocations::
* No_Initialize_Scalars::
@@ -522,6 +528,7 @@ Program Unit Level Restrictions
* No_Implementation_Restrictions::
* No_Implementation_Units::
* No_Implicit_Aliasing::
+* No_Implicit_Loops::
* No_Obsolescent_Features::
* No_Wide_Characters::
* SPARK_05::
@@ -783,6 +790,7 @@ The GNAT Library
* GNAT.Spitbol.Table_VString (g-sptavs.ads): GNAT Spitbol Table_VString g-sptavs ads.
* GNAT.SSE (g-sse.ads): GNAT SSE g-sse ads.
* GNAT.SSE.Vector_Types (g-ssvety.ads): GNAT SSE Vector_Types g-ssvety ads.
+* GNAT.String_Hash (g-strhas.ads): GNAT String_Hash g-strhas ads.
* GNAT.Strings (g-string.ads): GNAT Strings g-string ads.
* GNAT.String_Split (g-strspl.ads): GNAT String_Split g-strspl ads.
* GNAT.Table (g-table.ads): GNAT Table g-table ads.
@@ -801,6 +809,7 @@ The GNAT Library
* Interfaces.C.Streams (i-cstrea.ads): Interfaces C Streams i-cstrea ads.
* Interfaces.Packed_Decimal (i-pacdec.ads): Interfaces Packed_Decimal i-pacdec ads.
* Interfaces.VxWorks (i-vxwork.ads): Interfaces VxWorks i-vxwork ads.
+* Interfaces.VxWorks.Int_Connection (i-vxinco.ads): Interfaces VxWorks Int_Connection i-vxinco ads.
* Interfaces.VxWorks.IO (i-vxwoio.ads): Interfaces VxWorks IO i-vxwoio ads.
* System.Address_Image (s-addima.ads): System Address_Image s-addima ads.
* System.Assertions (s-assert.ads): System Assertions s-assert ads.
@@ -1251,6 +1260,7 @@ consideration, the use of these pragmas should be minimized.
* Pragma Machine_Attribute::
* Pragma Main::
* Pragma Main_Storage::
+* Pragma Max_Queue_Length::
* Pragma No_Body::
* Pragma No_Elaboration_Code_All::
* Pragma No_Inline::
@@ -1272,6 +1282,7 @@ consideration, the use of these pragmas should be minimized.
* Pragma Post::
* Pragma Postcondition::
* Pragma Post_Class::
+* Pragma Rename_Pragma::
* Pragma Pre::
* Pragma Precondition::
* Pragma Predicate::
@@ -1297,6 +1308,7 @@ consideration, the use of these pragmas should be minimized.
* Pragma Restricted_Run_Time::
* Pragma Restriction_Warnings::
* Pragma Reviewable::
+* Pragma Secondary_Stack_Size::
* Pragma Share_Generic::
* Pragma Shared::
* Pragma Short_Circuit_And_Or::
@@ -1334,6 +1346,7 @@ consideration, the use of these pragmas should be minimized.
* Pragma Unreserve_All_Interrupts::
* Pragma Unsuppress::
* Pragma Use_VADS_Size::
+* Pragma Unused::
* Pragma Validity_Checks::
* Pragma Volatile::
* Pragma Volatile_Full_Access::
@@ -1365,7 +1378,7 @@ for the declarations or handlers, if any, associated with this statement
sequence).
@node Pragma Abstract_State,Pragma Ada_83,Pragma Abort_Defer,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-abstract-state}@anchor{1c}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-abstract-state}@anchor{1c}@anchor{gnat_rm/implementation_defined_pragmas id2}@anchor{1d}
@section Pragma Abstract_State
@@ -1415,7 +1428,7 @@ For the semantics of this pragma, see the entry for aspect @cite{Abstract_State}
the SPARK 2014 Reference Manual, section 7.1.4.
@node Pragma Ada_83,Pragma Ada_95,Pragma Abstract_State,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-83}@anchor{1d}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-83}@anchor{1e}
@section Pragma Ada_83
@@ -1444,7 +1457,7 @@ by GNAT in Ada 83 mode will in fact compile and execute with an Ada
required by Ada 83.
@node Pragma Ada_95,Pragma Ada_05,Pragma Ada_83,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-95}@anchor{1e}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-95}@anchor{1f}
@section Pragma Ada_95
@@ -1463,7 +1476,7 @@ itself uses Ada 95 features, but which is intended to be usable from
either Ada 83 or Ada 95 programs.
@node Pragma Ada_05,Pragma Ada_2005,Pragma Ada_95,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-05}@anchor{1f}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-05}@anchor{20}
@section Pragma Ada_05
@@ -1492,7 +1505,7 @@ otherwise legal pre-Ada_2005 programs. The one argument form is
intended for exclusive use in the GNAT run-time library.
@node Pragma Ada_2005,Pragma Ada_12,Pragma Ada_05,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-2005}@anchor{20}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-2005}@anchor{21}
@section Pragma Ada_2005
@@ -1506,7 +1519,7 @@ This configuration pragma is a synonym for pragma Ada_05 and has the
same syntax and effect.
@node Pragma Ada_12,Pragma Ada_2012,Pragma Ada_2005,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-12}@anchor{21}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-12}@anchor{22}
@section Pragma Ada_12
@@ -1528,7 +1541,7 @@ Ada 83, Ada 95, or Ada 2005 programs.
The one argument form, which is not a configuration pragma,
is used for managing the transition from Ada
2005 to Ada 2012 in the run-time library. If an entity is marked
-as Ada_201 only, then referencing the entity in any pre-Ada_2012
+as Ada_2012 only, then referencing the entity in any pre-Ada_2012
mode will generate a warning. In addition, in any pre-Ada_2012
mode, a preference rule is established which does not choose
such an entity unless it is unambiguously specified. This avoids
@@ -1537,7 +1550,7 @@ otherwise legal pre-Ada_2012 programs. The one argument form is
intended for exclusive use in the GNAT run-time library.
@node Pragma Ada_2012,Pragma Allow_Integer_Address,Pragma Ada_12,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-2012}@anchor{22}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-ada-2012}@anchor{23}
@section Pragma Ada_2012
@@ -1551,7 +1564,7 @@ This configuration pragma is a synonym for pragma Ada_12 and has the
same syntax and effect.
@node Pragma Allow_Integer_Address,Pragma Annotate,Pragma Ada_2012,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-allow-integer-address}@anchor{23}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-allow-integer-address}@anchor{24}
@section Pragma Allow_Integer_Address
@@ -1601,7 +1614,7 @@ rather than rejected to allow common sets of sources to be used
in the two situations.
@node Pragma Annotate,Pragma Assert,Pragma Allow_Integer_Address,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-annotate}@anchor{24}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-annotate}@anchor{25}@anchor{gnat_rm/implementation_defined_pragmas id3}@anchor{26}
@section Pragma Annotate
@@ -1635,7 +1648,7 @@ affect the compilation process in any way. This pragma may be used as
a configuration pragma.
@node Pragma Assert,Pragma Assert_And_Cut,Pragma Annotate,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-assert}@anchor{25}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-assert}@anchor{27}
@section Pragma Assert
@@ -1701,7 +1714,7 @@ of Ada, and the DISABLE policy is an implementation-defined
addition.
@node Pragma Assert_And_Cut,Pragma Assertion_Policy,Pragma Assert,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-assert-and-cut}@anchor{26}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-assert-and-cut}@anchor{28}
@section Pragma Assert_And_Cut
@@ -1728,7 +1741,7 @@ formal verification. The pragma also serves as useful
documentation.
@node Pragma Assertion_Policy,Pragma Assume,Pragma Assert_And_Cut,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-assertion-policy}@anchor{27}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-assertion-policy}@anchor{29}
@section Pragma Assertion_Policy
@@ -1768,7 +1781,7 @@ ID_ASSERTION_KIND ::= Assertions |
Refined_Post |
Statement_Assertions
-POLICY_IDENTIFIER ::= Check | Disable | Ignore
+POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
@end example
This is a standard Ada 2012 pragma that is available as an
@@ -1791,6 +1804,8 @@ If the policy is @cite{IGNORE}, then assertions are ignored, i.e.
the corresponding pragma or aspect is deactivated.
This pragma overrides the effect of the @emph{-gnata} switch on the
command line.
+If the policy is @cite{SUPPRESSIBLE}, then assertions are enabled by default,
+however, if the @emph{-gnatp} switch is specified all assertions are ignored.
The implementation defined policy @cite{DISABLE} is like
@cite{IGNORE} except that it completely disables semantic
@@ -1809,7 +1824,7 @@ applies to @cite{Assert}, @cite{Assert_And_Cut},
@cite{Assume}, @cite{Loop_Invariant}, and @cite{Loop_Variant}.
@node Pragma Assume,Pragma Assume_No_Invalid_Values,Pragma Assertion_Policy,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-assume}@anchor{28}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-assume}@anchor{2a}
@section Pragma Assume
@@ -1843,7 +1858,7 @@ is met, and documents the need to ensure that it is met by
reference to information outside the program.
@node Pragma Assume_No_Invalid_Values,Pragma Async_Readers,Pragma Assume,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-assume-no-invalid-values}@anchor{29}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-assume-no-invalid-values}@anchor{2b}
@section Pragma Assume_No_Invalid_Values
@@ -1896,7 +1911,7 @@ is erroneous so there are no guarantees that this will always be the
case, and it is recommended that these two options not be used together.
@node Pragma Async_Readers,Pragma Async_Writers,Pragma Assume_No_Invalid_Values,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-async-readers}@anchor{2a}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-async-readers}@anchor{2c}@anchor{gnat_rm/implementation_defined_pragmas id4}@anchor{2d}
@section Pragma Async_Readers
@@ -1910,7 +1925,7 @@ For the semantics of this pragma, see the entry for aspect @cite{Async_Readers}
the SPARK 2014 Reference Manual, section 7.1.2.
@node Pragma Async_Writers,Pragma Attribute_Definition,Pragma Async_Readers,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-async-writers}@anchor{2b}
+@anchor{gnat_rm/implementation_defined_pragmas id5}@anchor{2e}@anchor{gnat_rm/implementation_defined_pragmas pragma-async-writers}@anchor{2f}
@section Pragma Async_Writers
@@ -1924,7 +1939,7 @@ For the semantics of this pragma, see the entry for aspect @cite{Async_Writers}
the SPARK 2014 Reference Manual, section 7.1.2.
@node Pragma Attribute_Definition,Pragma C_Pass_By_Copy,Pragma Async_Writers,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-attribute-definition}@anchor{2c}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-attribute-definition}@anchor{30}
@section Pragma Attribute_Definition
@@ -1950,7 +1965,7 @@ code to be written that takes advantage of some new attribute, while remaining
compilable with earlier compilers.
@node Pragma C_Pass_By_Copy,Pragma Check,Pragma Attribute_Definition,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-c-pass-by-copy}@anchor{2d}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-c-pass-by-copy}@anchor{31}
@section Pragma C_Pass_By_Copy
@@ -1994,7 +2009,7 @@ You can also pass records by copy by specifying the convention
passing mechanisms on a parameter by parameter basis.
@node Pragma Check,Pragma Check_Float_Overflow,Pragma C_Pass_By_Copy,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-check}@anchor{2e}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-check}@anchor{32}
@section Pragma Check
@@ -2033,7 +2048,7 @@ of these identifiers in @cite{Assertion_Policy} and @cite{Check_Policy}
pragmas, where they are used to refer to sets of assertions.
@node Pragma Check_Float_Overflow,Pragma Check_Name,Pragma Check,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-check-float-overflow}@anchor{2f}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-check-float-overflow}@anchor{33}
@section Pragma Check_Float_Overflow
@@ -2089,7 +2104,7 @@ This mode can also be set by use of the compiler
switch @emph{-gnateF}.
@node Pragma Check_Name,Pragma Check_Policy,Pragma Check_Float_Overflow,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-check-name}@anchor{30}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-check-name}@anchor{34}
@section Pragma Check_Name
@@ -2125,7 +2140,7 @@ Check names introduced by this pragma are subject to control by compiler
switches (in particular -gnatp) in the usual manner.
@node Pragma Check_Policy,Pragma Comment,Pragma Check_Name,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-check-policy}@anchor{31}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-check-policy}@anchor{35}
@section Pragma Check_Policy
@@ -2205,7 +2220,7 @@ policy setting @cite{DISABLE} causes the second argument of a corresponding
@cite{Check} pragma to be completely ignored and not analyzed.
@node Pragma Comment,Pragma Common_Object,Pragma Check_Policy,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-comment}@anchor{32}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-comment}@anchor{36}
@section Pragma Comment
@@ -2224,7 +2239,7 @@ anywhere in the main source unit), and if more than one pragma
is used, all comments are retained.
@node Pragma Common_Object,Pragma Compile_Time_Error,Pragma Comment,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-common-object}@anchor{33}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-common-object}@anchor{37}
@section Pragma Common_Object
@@ -2256,7 +2271,7 @@ indicating that the necessary attribute for implementation of this
pragma is not available.
@node Pragma Compile_Time_Error,Pragma Compile_Time_Warning,Pragma Common_Object,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-compile-time-error}@anchor{34}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-compile-time-error}@anchor{38}
@section Pragma Compile_Time_Error
@@ -2283,7 +2298,7 @@ the value given as the second argument. This string value may contain
embedded ASCII.LF characters to break the message into multiple lines.
@node Pragma Compile_Time_Warning,Pragma Compiler_Unit,Pragma Compile_Time_Error,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-compile-time-warning}@anchor{35}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-compile-time-warning}@anchor{39}
@section Pragma Compile_Time_Warning
@@ -2306,7 +2321,7 @@ with a first parameter of True is to warn a client about use of a package,
for example that it is not fully implemented.
@node Pragma Compiler_Unit,Pragma Compiler_Unit_Warning,Pragma Compile_Time_Warning,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-compiler-unit}@anchor{36}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-compiler-unit}@anchor{3a}
@section Pragma Compiler_Unit
@@ -2321,7 +2336,7 @@ retained so that old versions of the GNAT run-time that use this pragma can
be compiled with newer versions of the compiler.
@node Pragma Compiler_Unit_Warning,Pragma Complete_Representation,Pragma Compiler_Unit,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-compiler-unit-warning}@anchor{37}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-compiler-unit-warning}@anchor{3b}
@section Pragma Compiler_Unit_Warning
@@ -2339,7 +2354,7 @@ version of GNAT. For the exact list of restrictions, see the compiler sources
and references to Check_Compiler_Unit.
@node Pragma Complete_Representation,Pragma Complex_Representation,Pragma Compiler_Unit_Warning,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-complete-representation}@anchor{38}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-complete-representation}@anchor{3c}
@section Pragma Complete_Representation
@@ -2358,7 +2373,7 @@ complete, and that this invariant is maintained if fields are
added to the record in the future.
@node Pragma Complex_Representation,Pragma Component_Alignment,Pragma Complete_Representation,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-complex-representation}@anchor{39}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-complex-representation}@anchor{3d}
@section Pragma Complex_Representation
@@ -2380,7 +2395,7 @@ records by pointer, and the use of this pragma may result in passing
this type in floating-point registers.
@node Pragma Component_Alignment,Pragma Constant_After_Elaboration,Pragma Complex_Representation,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-component-alignment}@anchor{3a}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-component-alignment}@anchor{3e}
@section Pragma Component_Alignment
@@ -2471,7 +2486,7 @@ pragma @cite{Pack}, pragma @cite{Component_Alignment}, or a record rep
clause), the GNAT uses the default alignment as described previously.
@node Pragma Constant_After_Elaboration,Pragma Contract_Cases,Pragma Component_Alignment,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-constant-after-elaboration}@anchor{3b}
+@anchor{gnat_rm/implementation_defined_pragmas id6}@anchor{3f}@anchor{gnat_rm/implementation_defined_pragmas pragma-constant-after-elaboration}@anchor{40}
@section Pragma Constant_After_Elaboration
@@ -2485,7 +2500,7 @@ For the semantics of this pragma, see the entry for aspect
@cite{Constant_After_Elaboration} in the SPARK 2014 Reference Manual, section 3.3.1.
@node Pragma Contract_Cases,Pragma Convention_Identifier,Pragma Constant_After_Elaboration,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-contract-cases}@anchor{3c}
+@anchor{gnat_rm/implementation_defined_pragmas id7}@anchor{41}@anchor{gnat_rm/implementation_defined_pragmas pragma-contract-cases}@anchor{42}
@section Pragma Contract_Cases
@@ -2570,7 +2585,7 @@ and that the consequence for this case should hold when the subprogram
returns.
@node Pragma Convention_Identifier,Pragma CPP_Class,Pragma Contract_Cases,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-convention-identifier}@anchor{3d}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-convention-identifier}@anchor{43}
@section Pragma Convention_Identifier
@@ -2606,7 +2621,7 @@ define a convention identifier @cite{Library} and use a single
would be used system-wide.
@node Pragma CPP_Class,Pragma CPP_Constructor,Pragma Convention_Identifier,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-cpp-class}@anchor{3e}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-cpp-class}@anchor{44}
@section Pragma CPP_Class
@@ -2631,14 +2646,14 @@ functions (see pragma @cite{CPP_Constructor}). Such types are implicitly
limited if not explicitly declared as limited or derived from a limited
type, and an error is issued in that case.
-See @ref{3f,,Interfacing to C++} for related information.
+See @ref{45,,Interfacing to C++} for related information.
Note: Pragma @cite{CPP_Class} is currently obsolete. It is supported
for backward compatibility but its functionality is available
using pragma @cite{Import} with @cite{Convention} = @cite{CPP}.
@node Pragma CPP_Constructor,Pragma CPP_Virtual,Pragma CPP_Class,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-cpp-constructor}@anchor{40}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-cpp-constructor}@anchor{46}
@section Pragma CPP_Constructor
@@ -2689,7 +2704,7 @@ on the Ada side and the type is implicitly declared abstract.
Pragma @cite{CPP_Constructor} is intended primarily for automatic generation
using an automatic binding generator tool (such as the @cite{-fdump-ada-spec}
GCC switch).
-See @ref{3f,,Interfacing to C++} for more related information.
+See @ref{45,,Interfacing to C++} for more related information.
Note: The use of functions returning class-wide types for constructors is
currently obsolete. They are supported for backward compatibility. The
@@ -2698,7 +2713,7 @@ because the imported C++ constructors always return an object of type T;
that is, they never return an object whose type is a descendant of type T.
@node Pragma CPP_Virtual,Pragma CPP_Vtable,Pragma CPP_Constructor,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-cpp-virtual}@anchor{41}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-cpp-virtual}@anchor{47}
@section Pragma CPP_Virtual
@@ -2711,10 +2726,10 @@ purposes. It used to be required to ensure compoatibility with C++, but
is no longer required for that purpose because GNAT generates
the same object layout as the G++ compiler by default.
-See @ref{3f,,Interfacing to C++} for related information.
+See @ref{45,,Interfacing to C++} for related information.
@node Pragma CPP_Vtable,Pragma CPU,Pragma CPP_Virtual,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-cpp-vtable}@anchor{42}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-cpp-vtable}@anchor{48}
@section Pragma CPP_Vtable
@@ -2726,10 +2741,10 @@ It used to be required to ensure compatibility with C++, but
is no longer required for that purpose because GNAT generates
the same object layout as the G++ compiler by default.
-See @ref{3f,,Interfacing to C++} for related information.
+See @ref{45,,Interfacing to C++} for related information.
@node Pragma CPU,Pragma Default_Initial_Condition,Pragma CPP_Vtable,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-cpu}@anchor{43}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-cpu}@anchor{49}
@section Pragma CPU
@@ -2744,7 +2759,7 @@ versions of Ada as an implementation-defined pragma.
See Ada 2012 Reference Manual for details.
@node Pragma Default_Initial_Condition,Pragma Debug,Pragma CPU,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-default-initial-condition}@anchor{44}
+@anchor{gnat_rm/implementation_defined_pragmas id8}@anchor{4a}@anchor{gnat_rm/implementation_defined_pragmas pragma-default-initial-condition}@anchor{4b}
@section Pragma Default_Initial_Condition
@@ -2758,7 +2773,7 @@ For the semantics of this pragma, see the entry for aspect
@cite{Default_Initial_Condition} in the SPARK 2014 Reference Manual, section 7.3.3.
@node Pragma Debug,Pragma Debug_Policy,Pragma Default_Initial_Condition,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-debug}@anchor{45}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-debug}@anchor{4c}
@section Pragma Debug
@@ -2786,7 +2801,7 @@ or by use of the pragma @cite{Check_Policy} with a first argument of
@cite{Debug}.
@node Pragma Debug_Policy,Pragma Default_Scalar_Storage_Order,Pragma Debug,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-debug-policy}@anchor{46}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-debug-policy}@anchor{4d}
@section Pragma Debug_Policy
@@ -2801,7 +2816,7 @@ with a first argument of @cite{Debug}. It is retained for historical
compatibility reasons.
@node Pragma Default_Scalar_Storage_Order,Pragma Default_Storage_Pool,Pragma Debug_Policy,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-default-scalar-storage-order}@anchor{47}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-default-scalar-storage-order}@anchor{4e}
@section Pragma Default_Scalar_Storage_Order
@@ -2874,7 +2889,7 @@ it may significantly degrade the run-time performance of the software, instead
the default scalar storage order ought to be changed only on a local basis.
@node Pragma Default_Storage_Pool,Pragma Depends,Pragma Default_Scalar_Storage_Order,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-default-storage-pool}@anchor{48}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-default-storage-pool}@anchor{4f}
@section Pragma Default_Storage_Pool
@@ -2891,7 +2906,7 @@ versions of Ada as an implementation-defined pragma.
See Ada 2012 Reference Manual for details.
@node Pragma Depends,Pragma Detect_Blocking,Pragma Default_Storage_Pool,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-depends}@anchor{49}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-depends}@anchor{50}@anchor{gnat_rm/implementation_defined_pragmas id9}@anchor{51}
@section Pragma Depends
@@ -2924,7 +2939,7 @@ For the semantics of this pragma, see the entry for aspect @cite{Depends} in the
SPARK 2014 Reference Manual, section 6.1.5.
@node Pragma Detect_Blocking,Pragma Disable_Atomic_Synchronization,Pragma Depends,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-detect-blocking}@anchor{4a}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-detect-blocking}@anchor{52}
@section Pragma Detect_Blocking
@@ -2942,7 +2957,7 @@ blocking operations within a protected operation, and to raise Program_Error
if that happens.
@node Pragma Disable_Atomic_Synchronization,Pragma Dispatching_Domain,Pragma Detect_Blocking,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-disable-atomic-synchronization}@anchor{4b}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-disable-atomic-synchronization}@anchor{53}
@section Pragma Disable_Atomic_Synchronization
@@ -2968,7 +2983,7 @@ till the end of the scope. If an @cite{Entity} argument is present,
the action applies only to that entity.
@node Pragma Dispatching_Domain,Pragma Effective_Reads,Pragma Disable_Atomic_Synchronization,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-dispatching-domain}@anchor{4c}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-dispatching-domain}@anchor{54}
@section Pragma Dispatching_Domain
@@ -2983,7 +2998,7 @@ versions of Ada as an implementation-defined pragma.
See Ada 2012 Reference Manual for details.
@node Pragma Effective_Reads,Pragma Effective_Writes,Pragma Dispatching_Domain,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-effective-reads}@anchor{4d}
+@anchor{gnat_rm/implementation_defined_pragmas id10}@anchor{55}@anchor{gnat_rm/implementation_defined_pragmas pragma-effective-reads}@anchor{56}
@section Pragma Effective_Reads
@@ -2997,7 +3012,7 @@ For the semantics of this pragma, see the entry for aspect @cite{Effective_Reads
the SPARK 2014 Reference Manual, section 7.1.2.
@node Pragma Effective_Writes,Pragma Elaboration_Checks,Pragma Effective_Reads,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-effective-writes}@anchor{4e}
+@anchor{gnat_rm/implementation_defined_pragmas id11}@anchor{57}@anchor{gnat_rm/implementation_defined_pragmas pragma-effective-writes}@anchor{58}
@section Pragma Effective_Writes
@@ -3011,7 +3026,7 @@ For the semantics of this pragma, see the entry for aspect @cite{Effective_Write
in the SPARK 2014 Reference Manual, section 7.1.2.
@node Pragma Elaboration_Checks,Pragma Eliminate,Pragma Effective_Writes,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-elaboration-checks}@anchor{4f}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-elaboration-checks}@anchor{59}
@section Pragma Elaboration_Checks
@@ -3036,7 +3051,7 @@ used by the GNAT compiler, see the chapter on elaboration order handling
in the @emph{GNAT User's Guide}.
@node Pragma Eliminate,Pragma Enable_Atomic_Synchronization,Pragma Elaboration_Checks,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-eliminate}@anchor{50}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-eliminate}@anchor{5a}
@section Pragma Eliminate
@@ -3114,7 +3129,7 @@ dispatch are considered to be unused (are never called as a result of a direct
or a dispatching call).
@node Pragma Enable_Atomic_Synchronization,Pragma Export_Function,Pragma Eliminate,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-enable-atomic-synchronization}@anchor{51}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-enable-atomic-synchronization}@anchor{5b}
@section Pragma Enable_Atomic_Synchronization
@@ -3142,7 +3157,7 @@ till the end of the scope. If an @cite{Entity} argument is present,
the action applies only to that entity.
@node Pragma Export_Function,Pragma Export_Object,Pragma Enable_Atomic_Synchronization,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-export-function}@anchor{52}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-export-function}@anchor{5c}
@section Pragma Export_Function
@@ -3211,7 +3226,7 @@ string. In this case, no external name is generated. This form
still allows the specification of parameter mechanisms.
@node Pragma Export_Object,Pragma Export_Procedure,Pragma Export_Function,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-export-object}@anchor{53}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-export-object}@anchor{5d}
@section Pragma Export_Object
@@ -3236,7 +3251,7 @@ of portability), but it is not required. @cite{Size} is syntax checked,
but otherwise ignored by GNAT.
@node Pragma Export_Procedure,Pragma Export_Value,Pragma Export_Object,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-export-procedure}@anchor{54}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-export-procedure}@anchor{5e}
@section Pragma Export_Procedure
@@ -3289,7 +3304,7 @@ string. In this case, no external name is generated. This form
still allows the specification of parameter mechanisms.
@node Pragma Export_Value,Pragma Export_Valued_Procedure,Pragma Export_Procedure,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-export-value}@anchor{55}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-export-value}@anchor{5f}
@section Pragma Export_Value
@@ -3310,7 +3325,7 @@ the application. This pragma is currently supported only for the
AAMP target and is ignored for other targets.
@node Pragma Export_Valued_Procedure,Pragma Extend_System,Pragma Export_Value,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-export-valued-procedure}@anchor{56}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-export-valued-procedure}@anchor{60}
@section Pragma Export_Valued_Procedure
@@ -3368,7 +3383,7 @@ string. In this case, no external name is generated. This form
still allows the specification of parameter mechanisms.
@node Pragma Extend_System,Pragma Extensions_Allowed,Pragma Export_Valued_Procedure,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-extend-system}@anchor{57}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-extend-system}@anchor{61}
@section Pragma Extend_System
@@ -3419,7 +3434,7 @@ for compiling System units, as explained in the
GNAT User's Guide.
@node Pragma Extensions_Allowed,Pragma Extensions_Visible,Pragma Extend_System,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-extensions-allowed}@anchor{58}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-extensions-allowed}@anchor{62}
@section Pragma Extensions_Allowed
@@ -3452,7 +3467,7 @@ is constrained.
@end table
@node Pragma Extensions_Visible,Pragma External,Pragma Extensions_Allowed,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-extensions-visible}@anchor{59}
+@anchor{gnat_rm/implementation_defined_pragmas id12}@anchor{63}@anchor{gnat_rm/implementation_defined_pragmas pragma-extensions-visible}@anchor{64}
@section Pragma Extensions_Visible
@@ -3466,7 +3481,7 @@ For the semantics of this pragma, see the entry for aspect @cite{Extensions_Visi
in the SPARK 2014 Reference Manual, section 6.1.7.
@node Pragma External,Pragma External_Name_Casing,Pragma Extensions_Visible,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-external}@anchor{5a}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-external}@anchor{65}
@section Pragma External
@@ -3487,7 +3502,7 @@ used this pragma for exactly the same purposes as pragma
@cite{Export} before the latter was standardized.
@node Pragma External_Name_Casing,Pragma Fast_Math,Pragma External,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-external-name-casing}@anchor{5b}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-external-name-casing}@anchor{66}
@section Pragma External_Name_Casing
@@ -3576,7 +3591,7 @@ pragma External_Name_Casing (Uppercase, Uppercase);
to enforce the upper casing of all external symbols.
@node Pragma Fast_Math,Pragma Favor_Top_Level,Pragma External_Name_Casing,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-fast-math}@anchor{5c}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-fast-math}@anchor{67}
@section Pragma Fast_Math
@@ -3605,7 +3620,7 @@ under control of the pragma, rather than use the preinstantiated versions.
@end table
@node Pragma Favor_Top_Level,Pragma Finalize_Storage_Only,Pragma Fast_Math,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-favor-top-level}@anchor{5d}
+@anchor{gnat_rm/implementation_defined_pragmas id13}@anchor{68}@anchor{gnat_rm/implementation_defined_pragmas pragma-favor-top-level}@anchor{69}
@section Pragma Favor_Top_Level
@@ -3625,7 +3640,7 @@ trampolines may be used on some targets for nested subprograms.
See also the No_Implicit_Dynamic_Code restriction.
@node Pragma Finalize_Storage_Only,Pragma Float_Representation,Pragma Favor_Top_Level,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-finalize-storage-only}@anchor{5e}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-finalize-storage-only}@anchor{6a}
@section Pragma Finalize_Storage_Only
@@ -3642,7 +3657,7 @@ environments it is not necessary to reclaim memory just before terminating
execution, hence the name.
@node Pragma Float_Representation,Pragma Ghost,Pragma Finalize_Storage_Only,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-float-representation}@anchor{5f}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-float-representation}@anchor{6b}
@section Pragma Float_Representation
@@ -3677,7 +3692,7 @@ No other value of digits is permitted.
@end itemize
@node Pragma Ghost,Pragma Global,Pragma Float_Representation,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-ghost}@anchor{60}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-ghost}@anchor{6c}@anchor{gnat_rm/implementation_defined_pragmas id14}@anchor{6d}
@section Pragma Ghost
@@ -3691,7 +3706,7 @@ For the semantics of this pragma, see the entry for aspect @cite{Ghost} in the S
2014 Reference Manual, section 6.9.
@node Pragma Global,Pragma Ident,Pragma Ghost,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-global}@anchor{61}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-global}@anchor{6e}@anchor{gnat_rm/implementation_defined_pragmas id15}@anchor{6f}
@section Pragma Global
@@ -3716,7 +3731,7 @@ For the semantics of this pragma, see the entry for aspect @cite{Global} in the
SPARK 2014 Reference Manual, section 6.1.4.
@node Pragma Ident,Pragma Ignore_Pragma,Pragma Global,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-ident}@anchor{62}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-ident}@anchor{70}
@section Pragma Ident
@@ -3730,7 +3745,7 @@ This pragma is identical in effect to pragma @cite{Comment}. It is provided
for compatibility with other Ada compilers providing this pragma.
@node Pragma Ignore_Pragma,Pragma Implementation_Defined,Pragma Ident,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-ignore-pragma}@anchor{63}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-ignore-pragma}@anchor{71}
@section Pragma Ignore_Pragma
@@ -3750,7 +3765,7 @@ pragma allows such pragmas to be ignored, which may be useful in @cite{CodePeer}
mode, or during porting of legacy code.
@node Pragma Implementation_Defined,Pragma Implemented,Pragma Ignore_Pragma,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-implementation-defined}@anchor{64}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-implementation-defined}@anchor{72}
@section Pragma Implementation_Defined
@@ -3760,7 +3775,7 @@ Syntax:
pragma Implementation_Defined (local_NAME);
@end example
-This pragma marks a previously declared entioty as implementation-defined.
+This pragma marks a previously declared entity as implementation-defined.
For an overloaded entity, applies to the most recent homonym.
@example
@@ -3777,7 +3792,7 @@ for the purpose of implementing the No_Implementation_Identifiers
restriction.
@node Pragma Implemented,Pragma Implicit_Packing,Pragma Implementation_Defined,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-implemented}@anchor{65}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-implemented}@anchor{73}
@section Pragma Implemented
@@ -3823,7 +3838,7 @@ By_Any shares the behavior of By_Entry and By_Protected_Procedure depending on
the target's overriding subprogram kind.
@node Pragma Implicit_Packing,Pragma Import_Function,Pragma Implemented,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-implicit-packing}@anchor{66}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-implicit-packing}@anchor{74}
@section Pragma Implicit_Packing
@@ -3877,7 +3892,7 @@ sufficient. The use of pragma Implicit_Packing allows this record
declaration to compile without an explicit pragma Pack.
@node Pragma Import_Function,Pragma Import_Object,Pragma Implicit_Packing,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-import-function}@anchor{67}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-import-function}@anchor{75}
@section Pragma Import_Function
@@ -3942,7 +3957,7 @@ notation. If the mechanism is not specified, the default mechanism
is used.
@node Pragma Import_Object,Pragma Import_Procedure,Pragma Import_Function,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-import-object}@anchor{68}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-import-object}@anchor{76}
@section Pragma Import_Object
@@ -3968,7 +3983,7 @@ point of view). @cite{size} is syntax checked, but otherwise ignored by
GNAT.
@node Pragma Import_Procedure,Pragma Import_Valued_Procedure,Pragma Import_Object,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-import-procedure}@anchor{69}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-import-procedure}@anchor{77}
@section Pragma Import_Procedure
@@ -4008,7 +4023,7 @@ applies to a procedure rather than a function and the parameters
@cite{Result_Type} and @cite{Result_Mechanism} are not permitted.
@node Pragma Import_Valued_Procedure,Pragma Independent,Pragma Import_Procedure,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-import-valued-procedure}@anchor{6a}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-import-valued-procedure}@anchor{78}
@section Pragma Import_Valued_Procedure
@@ -4061,7 +4076,7 @@ pragma Import that specifies the desired convention, since otherwise the
default convention is Ada, which is almost certainly not what is required.
@node Pragma Independent,Pragma Independent_Components,Pragma Import_Valued_Procedure,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-independent}@anchor{6b}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-independent}@anchor{79}
@section Pragma Independent
@@ -4083,7 +4098,7 @@ constraints on the representation of the object (for instance prohibiting
tight packing).
@node Pragma Independent_Components,Pragma Initial_Condition,Pragma Independent,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-independent-components}@anchor{6c}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-independent-components}@anchor{7a}
@section Pragma Independent_Components
@@ -4104,7 +4119,7 @@ constraints on the representation of the object (for instance prohibiting
tight packing).
@node Pragma Initial_Condition,Pragma Initialize_Scalars,Pragma Independent_Components,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-initial-condition}@anchor{6d}
+@anchor{gnat_rm/implementation_defined_pragmas id16}@anchor{7b}@anchor{gnat_rm/implementation_defined_pragmas pragma-initial-condition}@anchor{7c}
@section Pragma Initial_Condition
@@ -4118,7 +4133,7 @@ For the semantics of this pragma, see the entry for aspect @cite{Initial_Conditi
in the SPARK 2014 Reference Manual, section 7.1.6.
@node Pragma Initialize_Scalars,Pragma Initializes,Pragma Initial_Condition,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-initialize-scalars}@anchor{6e}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-initialize-scalars}@anchor{7d}
@section Pragma Initialize_Scalars
@@ -4181,7 +4196,7 @@ checking (see description of stack checking in the GNAT
User's Guide) when using this pragma.
@node Pragma Initializes,Pragma Inline_Always,Pragma Initialize_Scalars,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-initializes}@anchor{6f}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-initializes}@anchor{7e}@anchor{gnat_rm/implementation_defined_pragmas id17}@anchor{7f}
@section Pragma Initializes
@@ -4208,7 +4223,7 @@ For the semantics of this pragma, see the entry for aspect @cite{Initializes} in
SPARK 2014 Reference Manual, section 7.1.5.
@node Pragma Inline_Always,Pragma Inline_Generic,Pragma Initializes,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-inline-always}@anchor{70}
+@anchor{gnat_rm/implementation_defined_pragmas id18}@anchor{80}@anchor{gnat_rm/implementation_defined_pragmas pragma-inline-always}@anchor{81}
@section Pragma Inline_Always
@@ -4223,7 +4238,7 @@ the use of option @emph{-gnatn} or @emph{-gnatN} and the inlining
happens regardless of whether these options are used.
@node Pragma Inline_Generic,Pragma Interface,Pragma Inline_Always,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-inline-generic}@anchor{71}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-inline-generic}@anchor{82}
@section Pragma Inline_Generic
@@ -4241,7 +4256,7 @@ than to check that the given names are all names of generic units or
generic instances.
@node Pragma Interface,Pragma Interface_Name,Pragma Inline_Generic,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-interface}@anchor{72}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-interface}@anchor{83}
@section Pragma Interface
@@ -4268,7 +4283,7 @@ maintaining Ada 83/Ada 95 compatibility and is compatible with other
Ada 83 compilers.
@node Pragma Interface_Name,Pragma Interrupt_Handler,Pragma Interface,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-interface-name}@anchor{73}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-interface-name}@anchor{84}
@section Pragma Interface_Name
@@ -4287,7 +4302,7 @@ for an interfaced subprogram, and is provided for compatibility with Ada
least one of @cite{External_Name} or @cite{Link_Name}.
@node Pragma Interrupt_Handler,Pragma Interrupt_State,Pragma Interface_Name,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-interrupt-handler}@anchor{74}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-interrupt-handler}@anchor{85}
@section Pragma Interrupt_Handler
@@ -4307,7 +4322,7 @@ when this pragma is applied to a nonprotected procedure, the instruction
maskable interrupts, in place of the normal return instruction.
@node Pragma Interrupt_State,Pragma Invariant,Pragma Interrupt_Handler,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-interrupt-state}@anchor{75}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-interrupt-state}@anchor{86}
@section Pragma Interrupt_State
@@ -4390,7 +4405,7 @@ with an application's runtime behavior in the cases of the synchronous signals,
and in the case of the signal used to implement the @cite{abort} statement.
@node Pragma Invariant,Pragma Keep_Names,Pragma Interrupt_State,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-invariant}@anchor{76}
+@anchor{gnat_rm/implementation_defined_pragmas id19}@anchor{87}@anchor{gnat_rm/implementation_defined_pragmas pragma-invariant}@anchor{88}
@section Pragma Invariant
@@ -4429,7 +4444,7 @@ For further details on the use of this pragma, see the Ada 2012 documentation
of the Type_Invariant aspect.
@node Pragma Keep_Names,Pragma License,Pragma Invariant,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-keep-names}@anchor{77}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-keep-names}@anchor{89}
@section Pragma Keep_Names
@@ -4449,7 +4464,7 @@ use a @cite{Discard_Names} pragma in the @code{gnat.adc} file, but you
want to retain the names for specific enumeration types.
@node Pragma License,Pragma Link_With,Pragma Keep_Names,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-license}@anchor{78}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-license}@anchor{8a}
@section Pragma License
@@ -4544,7 +4559,7 @@ GPL, but no warning for @cite{GNAT.Sockets} which is part of the GNAT
run time, and is therefore licensed under the modified GPL.
@node Pragma Link_With,Pragma Linker_Alias,Pragma License,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-link-with}@anchor{79}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-link-with}@anchor{8b}
@section Pragma Link_With
@@ -4568,7 +4583,7 @@ separate arguments to the linker. In addition pragma Link_With allows
multiple arguments, with the same effect as successive pragmas.
@node Pragma Linker_Alias,Pragma Linker_Constructor,Pragma Link_With,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-alias}@anchor{7a}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-alias}@anchor{8c}
@section Pragma Linker_Alias
@@ -4609,7 +4624,7 @@ end p;
@end example
@node Pragma Linker_Constructor,Pragma Linker_Destructor,Pragma Linker_Alias,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-constructor}@anchor{7b}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-constructor}@anchor{8d}
@section Pragma Linker_Constructor
@@ -4639,7 +4654,7 @@ listed above. Where possible, the use of Stand Alone Libraries is preferable
to the use of this pragma.
@node Pragma Linker_Destructor,Pragma Linker_Section,Pragma Linker_Constructor,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-destructor}@anchor{7c}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-destructor}@anchor{8e}
@section Pragma Linker_Destructor
@@ -4662,7 +4677,7 @@ See @cite{pragma Linker_Constructor} for the set of restrictions that apply
because of these specific contexts.
@node Pragma Linker_Section,Pragma Lock_Free,Pragma Linker_Destructor,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-section}@anchor{7d}
+@anchor{gnat_rm/implementation_defined_pragmas id20}@anchor{8f}@anchor{gnat_rm/implementation_defined_pragmas pragma-linker-section}@anchor{90}
@section Pragma Linker_Section
@@ -4736,7 +4751,7 @@ end IO_Card;
@end example
@node Pragma Lock_Free,Pragma Loop_Invariant,Pragma Linker_Section,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-lock-free}@anchor{7e}
+@anchor{gnat_rm/implementation_defined_pragmas id21}@anchor{91}@anchor{gnat_rm/implementation_defined_pragmas pragma-lock-free}@anchor{92}
@section Pragma Lock_Free
@@ -4747,7 +4762,7 @@ Compilation fails if the compiler cannot generate lock-free code for the
operations.
@node Pragma Loop_Invariant,Pragma Loop_Optimize,Pragma Lock_Free,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-invariant}@anchor{7f}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-invariant}@anchor{93}
@section Pragma Loop_Invariant
@@ -4780,7 +4795,7 @@ attribute can only be used within the expression of a @cite{Loop_Invariant}
pragma. For full details, see documentation of attribute @cite{Loop_Entry}.
@node Pragma Loop_Optimize,Pragma Loop_Variant,Pragma Loop_Invariant,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-optimize}@anchor{80}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-optimize}@anchor{94}
@section Pragma Loop_Optimize
@@ -4842,7 +4857,7 @@ compiler in order to enable the relevant optimizations, that is to say
vectorization.
@node Pragma Loop_Variant,Pragma Machine_Attribute,Pragma Loop_Optimize,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-variant}@anchor{81}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-loop-variant}@anchor{95}
@section Pragma Loop_Variant
@@ -4889,7 +4904,7 @@ The @cite{Loop_Entry} attribute may be used within the expressions of the
@cite{Loop_Variant} pragma to refer to values on entry to the loop.
@node Pragma Machine_Attribute,Pragma Main,Pragma Loop_Variant,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-machine-attribute}@anchor{82}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-machine-attribute}@anchor{96}
@section Pragma Machine_Attribute
@@ -4914,7 +4929,7 @@ for some attributes.
For further information see @cite{GNU Compiler Collection (GCC) Internals}.
@node Pragma Main,Pragma Main_Storage,Pragma Machine_Attribute,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-main}@anchor{83}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-main}@anchor{97}
@section Pragma Main
@@ -4933,8 +4948,8 @@ MAIN_OPTION ::=
This pragma is provided for compatibility with OpenVMS VAX Systems. It has
no effect in GNAT, other than being syntax checked.
-@node Pragma Main_Storage,Pragma No_Body,Pragma Main,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-main-storage}@anchor{84}
+@node Pragma Main_Storage,Pragma Max_Queue_Length,Pragma Main,Implementation Defined Pragmas
+@anchor{gnat_rm/implementation_defined_pragmas pragma-main-storage}@anchor{98}
@section Pragma Main_Storage
@@ -4952,8 +4967,24 @@ MAIN_STORAGE_OPTION ::=
This pragma is provided for compatibility with OpenVMS VAX Systems. It has
no effect in GNAT, other than being syntax checked.
-@node Pragma No_Body,Pragma No_Elaboration_Code_All,Pragma Main_Storage,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-no-body}@anchor{85}
+@node Pragma Max_Queue_Length,Pragma No_Body,Pragma Main_Storage,Implementation Defined Pragmas
+@anchor{gnat_rm/implementation_defined_pragmas pragma-max-queue-length}@anchor{99}
+@section Pragma Max_Queue_Length
+
+
+Syntax:
+
+@example
+pragma Max_Entry_Queue (static_integer_EXPRESSION);
+@end example
+
+This pragma is used to specify the maximum callers per entry queue for
+individual protected entries and entry families. It accepts a single
+positive integer as a parameter and must appear after the declaration
+of an entry.
+
+@node Pragma No_Body,Pragma No_Elaboration_Code_All,Pragma Max_Queue_Length,Implementation Defined Pragmas
+@anchor{gnat_rm/implementation_defined_pragmas pragma-no-body}@anchor{9a}
@section Pragma No_Body
@@ -4976,7 +5007,7 @@ dummy body with a No_Body pragma ensures that there is no interference from
earlier versions of the package body.
@node Pragma No_Elaboration_Code_All,Pragma No_Inline,Pragma No_Body,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-no-elaboration-code-all}@anchor{86}
+@anchor{gnat_rm/implementation_defined_pragmas id22}@anchor{9b}@anchor{gnat_rm/implementation_defined_pragmas pragma-no-elaboration-code-all}@anchor{9c}
@section Pragma No_Elaboration_Code_All
@@ -4995,7 +5026,7 @@ current unit, it must also have the No_Elaboration_Code_All aspect set.
It may be applied to package or subprogram specs or their generic versions.
@node Pragma No_Inline,Pragma No_Return,Pragma No_Elaboration_Code_All,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-no-inline}@anchor{87}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-no-inline}@anchor{9d}
@section Pragma No_Inline
@@ -5013,7 +5044,7 @@ in particular it is not subject to the use of option @emph{-gnatn} or
pragma @cite{Inline_Always} for the same @cite{NAME}.
@node Pragma No_Return,Pragma No_Run_Time,Pragma No_Inline,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-no-return}@anchor{88}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-no-return}@anchor{9e}
@section Pragma No_Return
@@ -5040,7 +5071,7 @@ available in all earlier versions of Ada as an implementation-defined
pragma.
@node Pragma No_Run_Time,Pragma No_Strict_Aliasing,Pragma No_Return,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-no-run-time}@anchor{89}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-no-run-time}@anchor{9f}
@section Pragma No_Run_Time
@@ -5056,7 +5087,7 @@ internal testing. The pragma has been superseded by the reconfigurable
runtime capability of @cite{GNAT}.
@node Pragma No_Strict_Aliasing,Pragma No_Tagged_Streams,Pragma No_Run_Time,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-no-strict-aliasing}@anchor{8a}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-no-strict-aliasing}@anchor{a0}
@section Pragma No_Strict_Aliasing
@@ -5078,7 +5109,7 @@ in the @cite{GNAT User's Guide}.
This pragma currently has no effects on access to unconstrained array types.
@node Pragma No_Tagged_Streams,Pragma Normalize_Scalars,Pragma No_Strict_Aliasing,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-no-tagged-streams}@anchor{8b}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-no-tagged-streams}@anchor{a1}@anchor{gnat_rm/implementation_defined_pragmas id23}@anchor{a2}
@section Pragma No_Tagged_Streams
@@ -5113,7 +5144,7 @@ applies to a complete hierarchy (this is necessary to deal with the class-wide
dispatching versions of the stream routines).
@node Pragma Normalize_Scalars,Pragma Obsolescent,Pragma No_Tagged_Streams,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-normalize-scalars}@anchor{8c}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-normalize-scalars}@anchor{a3}
@section Pragma Normalize_Scalars
@@ -5195,7 +5226,7 @@ will always generate an invalid value if one exists.
@end table
@node Pragma Obsolescent,Pragma Optimize_Alignment,Pragma Normalize_Scalars,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-obsolescent}@anchor{8d}@anchor{gnat_rm/implementation_defined_pragmas id2}@anchor{8e}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-obsolescent}@anchor{a4}@anchor{gnat_rm/implementation_defined_pragmas id24}@anchor{a5}
@section Pragma Obsolescent
@@ -5291,7 +5322,7 @@ So if you specify "Entity =>" for the Entity argument, and a Message
argument is present, it must be preceded by "Message =>".
@node Pragma Optimize_Alignment,Pragma Ordered,Pragma Obsolescent,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-optimize-alignment}@anchor{8f}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-optimize-alignment}@anchor{a6}
@section Pragma Optimize_Alignment
@@ -5374,7 +5405,7 @@ latter are compiled by default in pragma Optimize_Alignment (Off) mode if no
pragma appears at the start of the file.
@node Pragma Ordered,Pragma Overflow_Mode,Pragma Optimize_Alignment,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-ordered}@anchor{90}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-ordered}@anchor{a7}
@section Pragma Ordered
@@ -5466,7 +5497,7 @@ For additional information please refer to the description of the
@emph{-gnatw.u} switch in the GNAT User's Guide.
@node Pragma Overflow_Mode,Pragma Overriding_Renamings,Pragma Ordered,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-overflow-mode}@anchor{91}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-overflow-mode}@anchor{a8}
@section Pragma Overflow_Mode
@@ -5505,7 +5536,7 @@ The pragma @cite{Unsuppress (Overflow_Check)} unsuppresses (enables)
overflow checking, but does not affect the overflow mode.
@node Pragma Overriding_Renamings,Pragma Partition_Elaboration_Policy,Pragma Overflow_Mode,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-overriding-renamings}@anchor{92}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-overriding-renamings}@anchor{a9}
@section Pragma Overriding_Renamings
@@ -5540,7 +5571,7 @@ RM 8.3 (15) stipulates that an overridden operation is not visible within the
declaration of the overriding operation.
@node Pragma Partition_Elaboration_Policy,Pragma Part_Of,Pragma Overriding_Renamings,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-partition-elaboration-policy}@anchor{93}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-partition-elaboration-policy}@anchor{aa}
@section Pragma Partition_Elaboration_Policy
@@ -5557,7 +5588,7 @@ versions of Ada as an implementation-defined pragma.
See Ada 2012 Reference Manual for details.
@node Pragma Part_Of,Pragma Passive,Pragma Partition_Elaboration_Policy,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-part-of}@anchor{94}
+@anchor{gnat_rm/implementation_defined_pragmas id25}@anchor{ab}@anchor{gnat_rm/implementation_defined_pragmas pragma-part-of}@anchor{ac}
@section Pragma Part_Of
@@ -5573,7 +5604,7 @@ For the semantics of this pragma, see the entry for aspect @cite{Part_Of} in the
SPARK 2014 Reference Manual, section 7.2.6.
@node Pragma Passive,Pragma Persistent_BSS,Pragma Part_Of,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-passive}@anchor{95}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-passive}@anchor{ad}
@section Pragma Passive
@@ -5597,7 +5628,7 @@ For more information on the subject of passive tasks, see the section
'Passive Task Optimization' in the GNAT Users Guide.
@node Pragma Persistent_BSS,Pragma Polling,Pragma Passive,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-persistent-bss}@anchor{96}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-persistent-bss}@anchor{ae}@anchor{gnat_rm/implementation_defined_pragmas id26}@anchor{af}
@section Pragma Persistent_BSS
@@ -5628,7 +5659,7 @@ If this pragma is used on a target where this feature is not supported,
then the pragma will be ignored. See also @cite{pragma Linker_Section}.
@node Pragma Polling,Pragma Post,Pragma Persistent_BSS,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-polling}@anchor{97}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-polling}@anchor{b0}
@section Pragma Polling
@@ -5670,7 +5701,7 @@ Note that polling can also be enabled by use of the @emph{-gnatP} switch.
See the section on switches for gcc in the @cite{GNAT User's Guide}.
@node Pragma Post,Pragma Postcondition,Pragma Polling,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-post}@anchor{98}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-post}@anchor{b1}
@section Pragma Post
@@ -5695,7 +5726,7 @@ appear at the start of the declarations in a subprogram body
(preceded only by other pragmas).
@node Pragma Postcondition,Pragma Post_Class,Pragma Post,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-postcondition}@anchor{99}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-postcondition}@anchor{b2}
@section Pragma Postcondition
@@ -5859,8 +5890,8 @@ use of the pragma identifier @cite{Check}. Historically, pragma
Ada 2012, and has been retained in its original form for
compatibility purposes.
-@node Pragma Post_Class,Pragma Pre,Pragma Postcondition,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-post-class}@anchor{9a}
+@node Pragma Post_Class,Pragma Rename_Pragma,Pragma Postcondition,Implementation Defined Pragmas
+@anchor{gnat_rm/implementation_defined_pragmas pragma-post-class}@anchor{b3}
@section Pragma Post_Class
@@ -5894,8 +5925,47 @@ aspects, but is prepared to ignore the pragmas. The assertion
policy that controls this pragma is @cite{Post'Class}, not
@cite{Post_Class}.
-@node Pragma Pre,Pragma Precondition,Pragma Post_Class,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-pre}@anchor{9b}
+@node Pragma Rename_Pragma,Pragma Pre,Pragma Post_Class,Implementation Defined Pragmas
+@anchor{gnat_rm/implementation_defined_pragmas pragma-rename-pragma}@anchor{b4}
+@section Pragma Rename_Pragma
+
+
+@geindex Pragmas
+@geindex synonyms
+
+Syntax:
+
+@example
+pragma Rename_Pragma (
+ [New_Name =>] IDENTIFIER,
+ [Renamed =>] pragma_IDENTIFIER);
+@end example
+
+This pragma provides a mechanism for supplying new names for existing
+pragmas. The @cite{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:
+
+@example
+pragma Rename_Pragma (
+ New_Name => Inline_Only,
+ Renamed => Inline_Always);
+@end example
+
+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.
+
+@node Pragma Pre,Pragma Precondition,Pragma Rename_Pragma,Implementation Defined Pragmas
+@anchor{gnat_rm/implementation_defined_pragmas pragma-pre}@anchor{b5}
@section Pragma Pre
@@ -5920,7 +5990,7 @@ appear at the start of the declarations in a subprogram body
(preceded only by other pragmas).
@node Pragma Precondition,Pragma Predicate,Pragma Pre,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-precondition}@anchor{9c}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-precondition}@anchor{b6}
@section Pragma Precondition
@@ -5979,7 +6049,7 @@ Ada 2012, and has been retained in its original form for
compatibility purposes.
@node Pragma Predicate,Pragma Predicate_Failure,Pragma Precondition,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-predicate}@anchor{9d}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-predicate}@anchor{b7}@anchor{gnat_rm/implementation_defined_pragmas id27}@anchor{b8}
@section Pragma Predicate
@@ -6033,7 +6103,7 @@ defined for subtype B). When following this approach, the
use of predicates should be avoided.
@node Pragma Predicate_Failure,Pragma Preelaborable_Initialization,Pragma Predicate,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-predicate-failure}@anchor{9e}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-predicate-failure}@anchor{b9}
@section Pragma Predicate_Failure
@@ -6050,7 +6120,7 @@ the language-defined
@cite{Predicate_Failure} aspect, and shares its restrictions and semantics.
@node Pragma Preelaborable_Initialization,Pragma Prefix_Exception_Messages,Pragma Predicate_Failure,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-preelaborable-initialization}@anchor{9f}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-preelaborable-initialization}@anchor{ba}
@section Pragma Preelaborable_Initialization
@@ -6065,7 +6135,7 @@ versions of Ada as an implementation-defined pragma.
See Ada 2012 Reference Manual for details.
@node Pragma Prefix_Exception_Messages,Pragma Pre_Class,Pragma Preelaborable_Initialization,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-prefix-exception-messages}@anchor{a0}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-prefix-exception-messages}@anchor{bb}
@section Pragma Prefix_Exception_Messages
@@ -6096,7 +6166,7 @@ prefixing in this case, you can always call
@cite{GNAT.Source_Info.Enclosing_Entity} and prepend the string manually.
@node Pragma Pre_Class,Pragma Priority_Specific_Dispatching,Pragma Prefix_Exception_Messages,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-pre-class}@anchor{a1}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-pre-class}@anchor{bc}
@section Pragma Pre_Class
@@ -6131,7 +6201,7 @@ policy that controls this pragma is @cite{Pre'Class}, not
@cite{Pre_Class}.
@node Pragma Priority_Specific_Dispatching,Pragma Profile,Pragma Pre_Class,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-priority-specific-dispatching}@anchor{a2}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-priority-specific-dispatching}@anchor{bd}
@section Pragma Priority_Specific_Dispatching
@@ -6155,7 +6225,7 @@ versions of Ada as an implementation-defined pragma.
See Ada 2012 Reference Manual for details.
@node Pragma Profile,Pragma Profile_Warnings,Pragma Priority_Specific_Dispatching,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-profile}@anchor{a3}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-profile}@anchor{be}
@section Pragma Profile
@@ -6337,6 +6407,9 @@ by @code{No_Implicit_Task_Allocations} and
The @code{Simple_Barriers} restriction has been replaced by
@code{Pure_Barriers}.
+The @code{Max_Protected_Entries}, @code{Max_Entry_Queue_Length}, and
+@code{No_Relative_Delay} restrictions have been removed.
+
@item
Pragma Profile (Restricted)
@@ -6418,7 +6491,7 @@ conforming Ada constructs. The profile enables the following three pragmas:
@end itemize
@node Pragma Profile_Warnings,Pragma Propagate_Exceptions,Pragma Profile,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-profile-warnings}@anchor{a4}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-profile-warnings}@anchor{bf}
@section Pragma Profile_Warnings
@@ -6436,7 +6509,7 @@ violations of the profile generate warning messages instead
of error messages.
@node Pragma Propagate_Exceptions,Pragma Provide_Shift_Operators,Pragma Profile_Warnings,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-propagate-exceptions}@anchor{a5}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-propagate-exceptions}@anchor{c0}
@section Pragma Propagate_Exceptions
@@ -6455,7 +6528,7 @@ purposes. It used to be used in connection with optimization of
a now-obsolete mechanism for implementation of exceptions.
@node Pragma Provide_Shift_Operators,Pragma Psect_Object,Pragma Propagate_Exceptions,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-provide-shift-operators}@anchor{a6}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-provide-shift-operators}@anchor{c1}
@section Pragma Provide_Shift_Operators
@@ -6475,7 +6548,7 @@ including the function declarations for these five operators, together
with the pragma Import (Intrinsic, ...) statements.
@node Pragma Psect_Object,Pragma Pure_Function,Pragma Provide_Shift_Operators,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-psect-object}@anchor{a7}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-psect-object}@anchor{c2}
@section Pragma Psect_Object
@@ -6495,7 +6568,7 @@ EXTERNAL_SYMBOL ::=
This pragma is identical in effect to pragma @cite{Common_Object}.
@node Pragma Pure_Function,Pragma Rational,Pragma Psect_Object,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-pure-function}@anchor{a8}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-pure-function}@anchor{c3}@anchor{gnat_rm/implementation_defined_pragmas id28}@anchor{c4}
@section Pragma Pure_Function
@@ -6557,7 +6630,7 @@ unit is not a Pure unit in the categorization sense. So for example, a function
thus marked is free to @cite{with} non-pure units.
@node Pragma Rational,Pragma Ravenscar,Pragma Pure_Function,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-rational}@anchor{a9}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-rational}@anchor{c5}
@section Pragma Rational
@@ -6575,7 +6648,7 @@ pragma Profile (Rational);
@end example
@node Pragma Ravenscar,Pragma Refined_Depends,Pragma Rational,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-ravenscar}@anchor{aa}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-ravenscar}@anchor{c6}
@section Pragma Ravenscar
@@ -6595,7 +6668,7 @@ pragma Profile (Ravenscar);
which is the preferred method of setting the @cite{Ravenscar} profile.
@node Pragma Refined_Depends,Pragma Refined_Global,Pragma Ravenscar,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-depends}@anchor{ab}
+@anchor{gnat_rm/implementation_defined_pragmas id29}@anchor{c7}@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-depends}@anchor{c8}
@section Pragma Refined_Depends
@@ -6628,7 +6701,7 @@ For the semantics of this pragma, see the entry for aspect @cite{Refined_Depends
the SPARK 2014 Reference Manual, section 6.1.5.
@node Pragma Refined_Global,Pragma Refined_Post,Pragma Refined_Depends,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-global}@anchor{ac}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-global}@anchor{c9}@anchor{gnat_rm/implementation_defined_pragmas id30}@anchor{ca}
@section Pragma Refined_Global
@@ -6653,7 +6726,7 @@ For the semantics of this pragma, see the entry for aspect @cite{Refined_Global}
the SPARK 2014 Reference Manual, section 6.1.4.
@node Pragma Refined_Post,Pragma Refined_State,Pragma Refined_Global,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-post}@anchor{ad}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-post}@anchor{cb}@anchor{gnat_rm/implementation_defined_pragmas id31}@anchor{cc}
@section Pragma Refined_Post
@@ -6667,7 +6740,7 @@ For the semantics of this pragma, see the entry for aspect @cite{Refined_Post} i
the SPARK 2014 Reference Manual, section 7.2.7.
@node Pragma Refined_State,Pragma Relative_Deadline,Pragma Refined_Post,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-state}@anchor{ae}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-refined-state}@anchor{cd}@anchor{gnat_rm/implementation_defined_pragmas id32}@anchor{ce}
@section Pragma Refined_State
@@ -6693,7 +6766,7 @@ For the semantics of this pragma, see the entry for aspect @cite{Refined_State}
the SPARK 2014 Reference Manual, section 7.2.2.
@node Pragma Relative_Deadline,Pragma Remote_Access_Type,Pragma Refined_State,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-relative-deadline}@anchor{af}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-relative-deadline}@anchor{cf}
@section Pragma Relative_Deadline
@@ -6708,7 +6781,7 @@ versions of Ada as an implementation-defined pragma.
See Ada 2012 Reference Manual for details.
@node Pragma Remote_Access_Type,Pragma Restricted_Run_Time,Pragma Relative_Deadline,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-remote-access-type}@anchor{b0}
+@anchor{gnat_rm/implementation_defined_pragmas id33}@anchor{d0}@anchor{gnat_rm/implementation_defined_pragmas pragma-remote-access-type}@anchor{d1}
@section Pragma Remote_Access_Type
@@ -6734,7 +6807,7 @@ pertaining to remote access to class-wide types. At instantiation, the
actual type must be a remote access to class-wide type.
@node Pragma Restricted_Run_Time,Pragma Restriction_Warnings,Pragma Remote_Access_Type,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-restricted-run-time}@anchor{b1}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-restricted-run-time}@anchor{d2}
@section Pragma Restricted_Run_Time
@@ -6755,7 +6828,7 @@ which is the preferred method of setting the restricted run time
profile.
@node Pragma Restriction_Warnings,Pragma Reviewable,Pragma Restricted_Run_Time,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-restriction-warnings}@anchor{b2}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-restriction-warnings}@anchor{d3}
@section Pragma Restriction_Warnings
@@ -6792,8 +6865,8 @@ the Ada_95 and Style_Checks pragmas are accepted without
generating a warning, but any other use of implementation
defined pragmas will cause a warning to be generated.
-@node Pragma Reviewable,Pragma Share_Generic,Pragma Restriction_Warnings,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-reviewable}@anchor{b3}
+@node Pragma Reviewable,Pragma Secondary_Stack_Size,Pragma Restriction_Warnings,Implementation Defined Pragmas
+@anchor{gnat_rm/implementation_defined_pragmas pragma-reviewable}@anchor{d4}
@section Pragma Reviewable
@@ -6896,8 +6969,44 @@ may be used to obtain complete control and data-flow information, as well as
comprehensive messages identifying possible problems based on this
information.
-@node Pragma Share_Generic,Pragma Shared,Pragma Reviewable,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-share-generic}@anchor{b4}
+@node Pragma Secondary_Stack_Size,Pragma Share_Generic,Pragma Reviewable,Implementation Defined Pragmas
+@anchor{gnat_rm/implementation_defined_pragmas id34}@anchor{d5}@anchor{gnat_rm/implementation_defined_pragmas pragma-secondary-stack-size}@anchor{d6}
+@section Pragma Secondary_Stack_Size
+
+
+Syntax:
+
+@example
+pragma Secondary_Stack_Size (integer_EXPRESSION);
+@end example
+
+This pragma appears within the task definition of a single task declaration
+or a task type declaration (like pragma @cite{Storage_Size}) and applies to all
+task objects of that type. The argument specifies the size of the secondary
+stack to be used by these task objects, and must be of an integer type. The
+secondary stack is used to handle functions that return a variable-sized
+result, for example a function returning an unconstrained String.
+
+Note this pragma only applies to targets using fixed secondary stacks, like
+VxWorks 653 and bare board targets, where a fixed block for the
+secondary stack is allocated from the primary stack of the task. By default,
+these targets assign a percentage of the primary stack for the secondary stack,
+as defined by @cite{System.Parameter.Sec_Stack_Percentage}. With this pragma,
+an @cite{integer_EXPRESSION} of bytes is assigned from the primary stack instead.
+
+For most targets, the pragma does not apply as the secondary stack grows on
+demand: allocated as a chain of blocks in the heap. The default size of these
+blocks can be modified via the @cite{-D} binder option as described in
+@cite{GNAT User's Guide}.
+
+Note that no check is made to see if the secondary stack can fit inside the
+primary stack.
+
+Note the pragma cannot appear when the restriction @cite{No_Secondary_Stack}
+is in effect.
+
+@node Pragma Share_Generic,Pragma Shared,Pragma Secondary_Stack_Size,Implementation Defined Pragmas
+@anchor{gnat_rm/implementation_defined_pragmas pragma-share-generic}@anchor{d7}
@section Pragma Share_Generic
@@ -6915,7 +7024,7 @@ than to check that the given names are all names of generic units or
generic instances.
@node Pragma Shared,Pragma Short_Circuit_And_Or,Pragma Share_Generic,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-shared}@anchor{b5}
+@anchor{gnat_rm/implementation_defined_pragmas id35}@anchor{d8}@anchor{gnat_rm/implementation_defined_pragmas pragma-shared}@anchor{d9}
@section Pragma Shared
@@ -6923,7 +7032,7 @@ This pragma is provided for compatibility with Ada 83. The syntax and
semantics are identical to pragma Atomic.
@node Pragma Short_Circuit_And_Or,Pragma Short_Descriptors,Pragma Shared,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-short-circuit-and-or}@anchor{b6}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-short-circuit-and-or}@anchor{da}
@section Pragma Short_Circuit_And_Or
@@ -6942,7 +7051,7 @@ within the file being compiled, it applies only to the file being compiled.
There is no requirement that all units in a partition use this option.
@node Pragma Short_Descriptors,Pragma Simple_Storage_Pool_Type,Pragma Short_Circuit_And_Or,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-short-descriptors}@anchor{b7}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-short-descriptors}@anchor{db}
@section Pragma Short_Descriptors
@@ -6956,7 +7065,7 @@ This pragma is provided for compatibility with other Ada implementations. It
is recognized but ignored by all current versions of GNAT.
@node Pragma Simple_Storage_Pool_Type,Pragma Source_File_Name,Pragma Short_Descriptors,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-simple-storage-pool-type}@anchor{b8}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-simple-storage-pool-type}@anchor{dc}@anchor{gnat_rm/implementation_defined_pragmas id36}@anchor{dd}
@section Pragma Simple_Storage_Pool_Type
@@ -7010,7 +7119,7 @@ storage-management discipline).
An object of a simple storage pool type can be associated with an access
type by specifying the attribute
-@ref{b9,,Simple_Storage_Pool}. For example:
+@ref{de,,Simple_Storage_Pool}. For example:
@example
My_Pool : My_Simple_Storage_Pool_Type;
@@ -7020,11 +7129,11 @@ type Acc is access My_Data_Type;
for Acc'Simple_Storage_Pool use My_Pool;
@end example
-See attribute @ref{b9,,Simple_Storage_Pool}
+See attribute @ref{de,,Simple_Storage_Pool}
for further details.
@node Pragma Source_File_Name,Pragma Source_File_Name_Project,Pragma Simple_Storage_Pool_Type,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name}@anchor{ba}@anchor{gnat_rm/implementation_defined_pragmas id3}@anchor{bb}
+@anchor{gnat_rm/implementation_defined_pragmas id37}@anchor{df}@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name}@anchor{e0}
@section Pragma Source_File_Name
@@ -7116,19 +7225,19 @@ aware of these pragmas, and so other tools that use the projet file would not
be aware of the intended naming conventions. If you are using project files,
file naming is controlled by Source_File_Name_Project pragmas, which are
usually supplied automatically by the project manager. A pragma
-Source_File_Name cannot appear after a @ref{bc,,Pragma Source_File_Name_Project}.
+Source_File_Name cannot appear after a @ref{e1,,Pragma Source_File_Name_Project}.
For more details on the use of the @cite{Source_File_Name} pragma, see the
sections on @cite{Using Other File Names} and @cite{Alternative File Naming Schemes' in the :title:`GNAT User's Guide}.
@node Pragma Source_File_Name_Project,Pragma Source_Reference,Pragma Source_File_Name,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id4}@anchor{bd}@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name-project}@anchor{bc}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-source-file-name-project}@anchor{e1}@anchor{gnat_rm/implementation_defined_pragmas id38}@anchor{e2}
@section Pragma Source_File_Name_Project
This pragma has the same syntax and semantics as pragma Source_File_Name.
It is only allowed as a stand-alone configuration pragma.
-It cannot appear after a @ref{ba,,Pragma Source_File_Name}, and
+It cannot appear after a @ref{e0,,Pragma Source_File_Name}, and
most importantly, once pragma Source_File_Name_Project appears,
no further Source_File_Name pragmas are allowed.
@@ -7140,7 +7249,7 @@ Source_File_Name or Source_File_Name_Project pragmas (which would not be
known to the project manager).
@node Pragma Source_Reference,Pragma SPARK_Mode,Pragma Source_File_Name_Project,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-source-reference}@anchor{be}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-source-reference}@anchor{e3}
@section Pragma Source_Reference
@@ -7164,7 +7273,7 @@ string expression other than a string literal. This is because its value
is needed for error messages issued by all phases of the compiler.
@node Pragma SPARK_Mode,Pragma Static_Elaboration_Desired,Pragma Source_Reference,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-spark-mode}@anchor{bf}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-spark-mode}@anchor{e4}@anchor{gnat_rm/implementation_defined_pragmas id39}@anchor{e5}
@section Pragma SPARK_Mode
@@ -7246,7 +7355,7 @@ SPARK_Mode (@cite{Off}), then that pragma will need to be repeated in
the package body.
@node Pragma Static_Elaboration_Desired,Pragma Stream_Convert,Pragma SPARK_Mode,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-static-elaboration-desired}@anchor{c0}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-static-elaboration-desired}@anchor{e6}
@section Pragma Static_Elaboration_Desired
@@ -7270,7 +7379,7 @@ construction of larger aggregates with static components that include an others
choice.)
@node Pragma Stream_Convert,Pragma Style_Checks,Pragma Static_Elaboration_Desired,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-stream-convert}@anchor{c1}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-stream-convert}@anchor{e7}
@section Pragma Stream_Convert
@@ -7347,7 +7456,7 @@ the pragma is silently ignored, and the default implementation of the stream
attributes is used instead.
@node Pragma Style_Checks,Pragma Subtitle,Pragma Stream_Convert,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-style-checks}@anchor{c2}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-style-checks}@anchor{e8}
@section Pragma Style_Checks
@@ -7420,7 +7529,7 @@ Rf2 : Integer := ARG; -- OK, no error
@end example
@node Pragma Subtitle,Pragma Suppress,Pragma Style_Checks,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-subtitle}@anchor{c3}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-subtitle}@anchor{e9}
@section Pragma Subtitle
@@ -7434,7 +7543,7 @@ This pragma is recognized for compatibility with other Ada compilers
but is ignored by GNAT.
@node Pragma Suppress,Pragma Suppress_All,Pragma Subtitle,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress}@anchor{c4}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress}@anchor{ea}
@section Pragma Suppress
@@ -7507,7 +7616,7 @@ Of course, run-time checks are omitted whenever the compiler can prove
that they will not fail, whether or not checks are suppressed.
@node Pragma Suppress_All,Pragma Suppress_Debug_Info,Pragma Suppress,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-all}@anchor{c5}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-all}@anchor{eb}
@section Pragma Suppress_All
@@ -7526,7 +7635,7 @@ The use of the standard Ada pragma @cite{Suppress (All_Checks)}
as a normal configuration pragma is the preferred usage in GNAT.
@node Pragma Suppress_Debug_Info,Pragma Suppress_Exception_Locations,Pragma Suppress_All,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-debug-info}@anchor{c6}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-debug-info}@anchor{ec}@anchor{gnat_rm/implementation_defined_pragmas id40}@anchor{ed}
@section Pragma Suppress_Debug_Info
@@ -7541,7 +7650,7 @@ for the specified entity. It is intended primarily for use in debugging
the debugger, and navigating around debugger problems.
@node Pragma Suppress_Exception_Locations,Pragma Suppress_Initialization,Pragma Suppress_Debug_Info,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-exception-locations}@anchor{c7}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-exception-locations}@anchor{ee}
@section Pragma Suppress_Exception_Locations
@@ -7564,7 +7673,7 @@ a partition, so it is fine to have some units within a partition compiled
with this pragma and others compiled in normal mode without it.
@node Pragma Suppress_Initialization,Pragma Task_Name,Pragma Suppress_Exception_Locations,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-initialization}@anchor{c8}
+@anchor{gnat_rm/implementation_defined_pragmas id41}@anchor{ef}@anchor{gnat_rm/implementation_defined_pragmas pragma-suppress-initialization}@anchor{f0}
@section Pragma Suppress_Initialization
@@ -7609,7 +7718,7 @@ is suppressed, just as though its subtype had been given in a pragma
Suppress_Initialization, as described above.
@node Pragma Task_Name,Pragma Task_Storage,Pragma Suppress_Initialization,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-task-name}@anchor{c9}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-task-name}@anchor{f1}
@section Pragma Task_Name
@@ -7665,7 +7774,7 @@ end;
@end example
@node Pragma Task_Storage,Pragma Test_Case,Pragma Task_Name,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-task-storage}@anchor{ca}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-task-storage}@anchor{f2}
@section Pragma Task_Storage
@@ -7685,7 +7794,7 @@ created, depending on the target. This pragma can appear anywhere a
type.
@node Pragma Test_Case,Pragma Thread_Local_Storage,Pragma Task_Storage,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-test-case}@anchor{cb}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-test-case}@anchor{f3}@anchor{gnat_rm/implementation_defined_pragmas id42}@anchor{f4}
@section Pragma Test_Case
@@ -7741,7 +7850,7 @@ postcondition. Mode @cite{Robustness} indicates that the precondition and
postcondition of the subprogram should be ignored for this test case.
@node Pragma Thread_Local_Storage,Pragma Time_Slice,Pragma Test_Case,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-thread-local-storage}@anchor{cc}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-thread-local-storage}@anchor{f5}@anchor{gnat_rm/implementation_defined_pragmas id43}@anchor{f6}
@section Pragma Thread_Local_Storage
@@ -7775,7 +7884,7 @@ If this pragma is used on a system where @cite{TLS} is not supported,
then an error message will be generated and the program will be rejected.
@node Pragma Time_Slice,Pragma Title,Pragma Thread_Local_Storage,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-time-slice}@anchor{cd}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-time-slice}@anchor{f7}
@section Pragma Time_Slice
@@ -7791,7 +7900,7 @@ It is ignored if it is used in a system that does not allow this control,
or if it appears in other than the main program unit.
@node Pragma Title,Pragma Type_Invariant,Pragma Time_Slice,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-title}@anchor{ce}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-title}@anchor{f8}
@section Pragma Title
@@ -7816,7 +7925,7 @@ notation is used, and named and positional notation can be mixed
following the normal rules for procedure calls in Ada.
@node Pragma Type_Invariant,Pragma Type_Invariant_Class,Pragma Title,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant}@anchor{cf}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant}@anchor{f9}
@section Pragma Type_Invariant
@@ -7837,7 +7946,7 @@ controlled by the assertion identifier @cite{Type_Invariant}
rather than @cite{Invariant}.
@node Pragma Type_Invariant_Class,Pragma Unchecked_Union,Pragma Type_Invariant,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant-class}@anchor{d0}
+@anchor{gnat_rm/implementation_defined_pragmas id44}@anchor{fa}@anchor{gnat_rm/implementation_defined_pragmas pragma-type-invariant-class}@anchor{fb}
@section Pragma Type_Invariant_Class
@@ -7864,7 +7973,7 @@ policy that controls this pragma is @cite{Type_Invariant'Class},
not @cite{Type_Invariant_Class}.
@node Pragma Unchecked_Union,Pragma Unevaluated_Use_Of_Old,Pragma Type_Invariant_Class,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-unchecked-union}@anchor{d1}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-unchecked-union}@anchor{fc}
@section Pragma Unchecked_Union
@@ -7884,7 +7993,7 @@ version in all language modes (Ada 83, Ada 95, and Ada 2005). For full
details, consult the Ada 2012 Reference Manual, section B.3.3.
@node Pragma Unevaluated_Use_Of_Old,Pragma Unimplemented_Unit,Pragma Unchecked_Union,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-unevaluated-use-of-old}@anchor{d2}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-unevaluated-use-of-old}@anchor{fd}
@section Pragma Unevaluated_Use_Of_Old
@@ -7939,7 +8048,7 @@ uses up to the end of the corresponding statement sequence or
sequence of package declarations.
@node Pragma Unimplemented_Unit,Pragma Universal_Aliasing,Pragma Unevaluated_Use_Of_Old,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-unimplemented-unit}@anchor{d3}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-unimplemented-unit}@anchor{fe}
@section Pragma Unimplemented_Unit
@@ -7959,7 +8068,7 @@ The abort only happens if code is being generated. Thus you can use
specs of unimplemented packages in syntax or semantic checking mode.
@node Pragma Universal_Aliasing,Pragma Universal_Data,Pragma Unimplemented_Unit,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-universal-aliasing}@anchor{d4}
+@anchor{gnat_rm/implementation_defined_pragmas id45}@anchor{ff}@anchor{gnat_rm/implementation_defined_pragmas pragma-universal-aliasing}@anchor{100}
@section Pragma Universal_Aliasing
@@ -7978,7 +8087,7 @@ situations in which it must be suppressed, see the section on
@cite{Optimization and Strict Aliasing} in the @cite{GNAT User's Guide}.
@node Pragma Universal_Data,Pragma Unmodified,Pragma Universal_Aliasing,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-universal-data}@anchor{d5}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-universal-data}@anchor{101}@anchor{gnat_rm/implementation_defined_pragmas id46}@anchor{102}
@section Pragma Universal_Data
@@ -8002,7 +8111,7 @@ of this pragma is also available by applying the -univ switch on the
compilations of units where universal addressing of the data is desired.
@node Pragma Unmodified,Pragma Unreferenced,Pragma Universal_Data,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-unmodified}@anchor{d6}
+@anchor{gnat_rm/implementation_defined_pragmas id47}@anchor{103}@anchor{gnat_rm/implementation_defined_pragmas pragma-unmodified}@anchor{104}
@section Pragma Unmodified
@@ -8036,7 +8145,7 @@ Thus it is never necessary to use @cite{pragma Unmodified} for such
variables, though it is harmless to do so.
@node Pragma Unreferenced,Pragma Unreferenced_Objects,Pragma Unmodified,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced}@anchor{d7}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced}@anchor{105}@anchor{gnat_rm/implementation_defined_pragmas id48}@anchor{106}
@section Pragma Unreferenced
@@ -8080,7 +8189,7 @@ Note that if a warning is desired for all calls to a given subprogram,
regardless of whether they occur in the same unit as the subprogram
declaration, then this pragma should not be used (calls from another
unit would not be flagged); pragma Obsolescent can be used instead
-for this purpose, see @ref{8d,,Pragma Obsolescent}.
+for this purpose, see @ref{a4,,Pragma Obsolescent}.
The second form of pragma @cite{Unreferenced} is used within a context
clause. In this case the arguments must be unit names of units previously
@@ -8096,7 +8205,7 @@ Thus it is never necessary to use @cite{pragma Unreferenced} for such
variables, though it is harmless to do so.
@node Pragma Unreferenced_Objects,Pragma Unreserve_All_Interrupts,Pragma Unreferenced,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced-objects}@anchor{d8}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-unreferenced-objects}@anchor{107}@anchor{gnat_rm/implementation_defined_pragmas id49}@anchor{108}
@section Pragma Unreferenced_Objects
@@ -8121,7 +8230,7 @@ compiler will automatically suppress unwanted warnings about these variables
not being referenced.
@node Pragma Unreserve_All_Interrupts,Pragma Unsuppress,Pragma Unreferenced_Objects,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-unreserve-all-interrupts}@anchor{d9}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-unreserve-all-interrupts}@anchor{109}
@section Pragma Unreserve_All_Interrupts
@@ -8157,7 +8266,7 @@ handled, see pragma @cite{Interrupt_State}, which subsumes the functionality
of the @cite{Unreserve_All_Interrupts} pragma.
@node Pragma Unsuppress,Pragma Use_VADS_Size,Pragma Unreserve_All_Interrupts,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-unsuppress}@anchor{da}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-unsuppress}@anchor{10a}
@section Pragma Unsuppress
@@ -8192,8 +8301,8 @@ Note that in addition to the checks defined in the Ada RM, GNAT recogizes a
number of implementation-defined check names. See the description of pragma
@cite{Suppress} for full details.
-@node Pragma Use_VADS_Size,Pragma Validity_Checks,Pragma Unsuppress,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-use-vads-size}@anchor{db}
+@node Pragma Use_VADS_Size,Pragma Unused,Pragma Unsuppress,Implementation Defined Pragmas
+@anchor{gnat_rm/implementation_defined_pragmas pragma-use-vads-size}@anchor{10b}
@section Pragma Use_VADS_Size
@@ -8216,8 +8325,42 @@ the handling of existing code which depends on the interpretation of Size
as implemented in the VADS compiler. See description of the VADS_Size
attribute for further details.
-@node Pragma Validity_Checks,Pragma Volatile,Pragma Use_VADS_Size,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-validity-checks}@anchor{dc}
+@node Pragma Unused,Pragma Validity_Checks,Pragma Use_VADS_Size,Implementation Defined Pragmas
+@anchor{gnat_rm/implementation_defined_pragmas pragma-unused}@anchor{10c}@anchor{gnat_rm/implementation_defined_pragmas id50}@anchor{10d}
+@section Pragma Unused
+
+
+@geindex Warnings
+@geindex unused
+
+Syntax:
+
+@example
+pragma Unused (LOCAL_NAME @{, LOCAL_NAME@});
+@end example
+
+This pragma signals that the assignable entities (variables,
+@cite{out} parameters, and @cite{in out} parameters) whose names are listed
+deliberately do not get assigned or referenced in the current source unit
+after the occurrence of the pragma in the current source unit. This
+suppresses warnings about the entities that are unreferenced and/or not
+assigned, and, in addition, a warning will be generated if one of these
+entities gets assigned or subsequently referenced in the same unit as the
+pragma (in the corresponding body or one of its subunits).
+
+This is particularly useful for clearly signaling that a particular
+parameter is not modified or referenced, even though the spec suggests
+that it might be.
+
+For the variable case, warnings are never given for unreferenced
+variables whose name contains one of the substrings
+@cite{DISCARD@comma{} DUMMY@comma{} IGNORE@comma{} JUNK@comma{} UNUSED} in any casing. Such names
+are typically to be used in cases where such warnings are expected.
+Thus it is never necessary to use @cite{pragma Unmodified} for such
+variables, though it is harmless to do so.
+
+@node Pragma Validity_Checks,Pragma Volatile,Pragma Unused,Implementation Defined Pragmas
+@anchor{gnat_rm/implementation_defined_pragmas pragma-validity-checks}@anchor{10e}
@section Pragma Validity_Checks
@@ -8274,7 +8417,7 @@ A := C; -- C will be validity checked
@end example
@node Pragma Volatile,Pragma Volatile_Full_Access,Pragma Validity_Checks,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile}@anchor{dd}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile}@anchor{10f}
@section Pragma Volatile
@@ -8292,7 +8435,7 @@ implementation of pragma Volatile is upwards compatible with the
implementation in DEC Ada 83.
@node Pragma Volatile_Full_Access,Pragma Volatile_Function,Pragma Volatile,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-full-access}@anchor{de}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-full-access}@anchor{110}@anchor{gnat_rm/implementation_defined_pragmas id51}@anchor{111}
@section Pragma Volatile_Full_Access
@@ -8324,7 +8467,7 @@ It is not permissible to specify @cite{Volatile_Full_Access} for a composite
(record or array) type or object that has at least one @cite{Aliased} component.
@node Pragma Volatile_Function,Pragma Warning_As_Error,Pragma Volatile_Full_Access,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-function}@anchor{df}
+@anchor{gnat_rm/implementation_defined_pragmas id52}@anchor{112}@anchor{gnat_rm/implementation_defined_pragmas pragma-volatile-function}@anchor{113}
@section Pragma Volatile_Function
@@ -8338,7 +8481,7 @@ For the semantics of this pragma, see the entry for aspect @cite{Volatile_Functi
in the SPARK 2014 Reference Manual, section 7.1.2.
@node Pragma Warning_As_Error,Pragma Warnings,Pragma Volatile_Function,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-warning-as-error}@anchor{e0}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-warning-as-error}@anchor{114}
@section Pragma Warning_As_Error
@@ -8373,7 +8516,7 @@ as shown in the example below, to treat a class of warnings as errors.
The above use of patterns to match the message applies only to warning
messages generated by the front end. This pragma can also be applied to
-warnings provided by the back end and mentioned in @ref{e1,,Pragma Warnings}.
+warnings provided by the back end and mentioned in @ref{115,,Pragma Warnings}.
By using a single full @emph{-Wxxx} switch in the pragma, such warnings
can also be treated as errors.
@@ -8423,7 +8566,7 @@ the tag is changed from "warning:" to "error:" and the string
"[warning-as-error]" is appended to the end of the message.
@node Pragma Warnings,Pragma Weak_External,Pragma Warning_As_Error,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas id5}@anchor{e2}@anchor{gnat_rm/implementation_defined_pragmas pragma-warnings}@anchor{e1}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-warnings}@anchor{115}@anchor{gnat_rm/implementation_defined_pragmas id53}@anchor{116}
@section Pragma Warnings
@@ -8575,7 +8718,7 @@ selectively for each tool, and as a consequence to detect useless pragma
Warnings with switch @cite{-gnatw.w}.
@node Pragma Weak_External,Pragma Wide_Character_Encoding,Pragma Warnings,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-weak-external}@anchor{e3}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-weak-external}@anchor{117}
@section Pragma Weak_External
@@ -8626,7 +8769,7 @@ end External_Module;
@end example
@node Pragma Wide_Character_Encoding,,Pragma Weak_External,Implementation Defined Pragmas
-@anchor{gnat_rm/implementation_defined_pragmas pragma-wide-character-encoding}@anchor{e4}
+@anchor{gnat_rm/implementation_defined_pragmas pragma-wide-character-encoding}@anchor{118}
@section Pragma Wide_Character_Encoding
@@ -8653,7 +8796,7 @@ encoding within that file, and does not affect withed units, specs,
or subunits.
@node Implementation Defined Aspects,Implementation Defined Attributes,Implementation Defined Pragmas,Top
-@anchor{gnat_rm/implementation_defined_aspects implementation-defined-aspects}@anchor{e5}@anchor{gnat_rm/implementation_defined_aspects doc}@anchor{e6}@anchor{gnat_rm/implementation_defined_aspects id1}@anchor{e7}
+@anchor{gnat_rm/implementation_defined_aspects implementation-defined-aspects}@anchor{119}@anchor{gnat_rm/implementation_defined_aspects doc}@anchor{11a}@anchor{gnat_rm/implementation_defined_aspects id1}@anchor{11b}
@chapter Implementation Defined Aspects
@@ -8733,6 +8876,7 @@ or attribute definition clause.
* Aspect Iterable::
* Aspect Linker_Section::
* Aspect Lock_Free::
+* Aspect Max_Queue_Length::
* Aspect No_Elaboration_Code_All::
* Aspect No_Tagged_Streams::
* Aspect Object_Size::
@@ -8746,6 +8890,7 @@ or attribute definition clause.
* Aspect Refined_Post::
* Aspect Refined_State::
* Aspect Remote_Access_Type::
+* Aspect Secondary_Stack_Size::
* Aspect Scalar_Storage_Order::
* Aspect Shared::
* Aspect Simple_Storage_Pool::
@@ -8768,23 +8913,24 @@ or attribute definition clause.
@end menu
@node Aspect Abstract_State,Annotate,,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-abstract-state}@anchor{e8}
+@anchor{gnat_rm/implementation_defined_aspects aspect-abstract-state}@anchor{11c}
@section Aspect Abstract_State
@geindex Abstract_State
-This aspect is equivalent to pragma @cite{Abstract_State}.
+This aspect is equivalent to @ref{1c,,pragma Abstract_State}.
@node Annotate,Aspect Async_Readers,Aspect Abstract_State,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects annotate}@anchor{e9}
+@anchor{gnat_rm/implementation_defined_aspects annotate}@anchor{11d}
@section Annotate
@geindex Annotate
There are three forms of this aspect (where ID is an identifier,
-and ARG is a general expression).
+and ARG is a general expression),
+corresponding to @ref{25,,pragma Annotate}.
@table @asis
@@ -8803,63 +8949,63 @@ Equivalent to @cite{pragma Annotate (ID@comma{} ID @{@comma{} ARG@}@comma{} Enti
@end table
@node Aspect Async_Readers,Aspect Async_Writers,Annotate,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-async-readers}@anchor{ea}
+@anchor{gnat_rm/implementation_defined_aspects aspect-async-readers}@anchor{11e}
@section Aspect Async_Readers
@geindex Async_Readers
-This boolean aspect is equivalent to pragma @cite{Async_Readers}.
+This boolean aspect is equivalent to @ref{2c,,pragma Async_Readers}.
@node Aspect Async_Writers,Aspect Constant_After_Elaboration,Aspect Async_Readers,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-async-writers}@anchor{eb}
+@anchor{gnat_rm/implementation_defined_aspects aspect-async-writers}@anchor{11f}
@section Aspect Async_Writers
@geindex Async_Writers
-This boolean aspect is equivalent to pragma @cite{Async_Writers}.
+This boolean aspect is equivalent to @ref{2f,,pragma Async_Writers}.
@node Aspect Constant_After_Elaboration,Aspect Contract_Cases,Aspect Async_Writers,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-constant-after-elaboration}@anchor{ec}
+@anchor{gnat_rm/implementation_defined_aspects aspect-constant-after-elaboration}@anchor{120}
@section Aspect Constant_After_Elaboration
@geindex Constant_After_Elaboration
-This aspect is equivalent to pragma @cite{Constant_After_Elaboration}.
+This aspect is equivalent to @ref{40,,pragma Constant_After_Elaboration}.
@node Aspect Contract_Cases,Aspect Depends,Aspect Constant_After_Elaboration,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-contract-cases}@anchor{ed}
+@anchor{gnat_rm/implementation_defined_aspects aspect-contract-cases}@anchor{121}
@section Aspect Contract_Cases
@geindex Contract_Cases
-This aspect is equivalent to pragma @cite{Contract_Cases}, the sequence
+This aspect is equivalent to @ref{42,,pragma Contract_Cases}, the sequence
of clauses being enclosed in parentheses so that syntactically it is an
aggregate.
@node Aspect Depends,Aspect Default_Initial_Condition,Aspect Contract_Cases,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-depends}@anchor{ee}
+@anchor{gnat_rm/implementation_defined_aspects aspect-depends}@anchor{122}
@section Aspect Depends
@geindex Depends
-This aspect is equivalent to pragma @cite{Depends}.
+This aspect is equivalent to @ref{50,,pragma Depends}.
@node Aspect Default_Initial_Condition,Aspect Dimension,Aspect Depends,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-default-initial-condition}@anchor{ef}
+@anchor{gnat_rm/implementation_defined_aspects aspect-default-initial-condition}@anchor{123}
@section Aspect Default_Initial_Condition
@geindex Default_Initial_Condition
-This aspect is equivalent to pragma @cite{Default_Initial_Condition}.
+This aspect is equivalent to @ref{4b,,pragma Default_Initial_Condition}.
@node Aspect Dimension,Aspect Dimension_System,Aspect Default_Initial_Condition,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-dimension}@anchor{f0}
+@anchor{gnat_rm/implementation_defined_aspects aspect-dimension}@anchor{124}
@section Aspect Dimension
@@ -8895,7 +9041,7 @@ Note that when the dimensioned type is an integer type, then any
dimension value must be an integer literal.
@node Aspect Dimension_System,Aspect Disable_Controlled,Aspect Dimension,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-dimension-system}@anchor{f1}
+@anchor{gnat_rm/implementation_defined_aspects aspect-dimension-system}@anchor{125}
@section Aspect Dimension_System
@@ -8955,7 +9101,7 @@ See section 'Performing Dimensionality Analysis in GNAT' in the GNAT Users
Guide for detailed examples of use of the dimension system.
@node Aspect Disable_Controlled,Aspect Effective_Reads,Aspect Dimension_System,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-disable-controlled}@anchor{f2}
+@anchor{gnat_rm/implementation_defined_aspects aspect-disable-controlled}@anchor{126}
@section Aspect Disable_Controlled
@@ -8968,110 +9114,110 @@ where for example you might want a record to be controlled or not depending on
whether some run-time check is enabled or suppressed.
@node Aspect Effective_Reads,Aspect Effective_Writes,Aspect Disable_Controlled,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-effective-reads}@anchor{f3}
+@anchor{gnat_rm/implementation_defined_aspects aspect-effective-reads}@anchor{127}
@section Aspect Effective_Reads
@geindex Effective_Reads
-This aspect is equivalent to pragma @cite{Effective_Reads}.
+This aspect is equivalent to @ref{56,,pragma Effective_Reads}.
@node Aspect Effective_Writes,Aspect Extensions_Visible,Aspect Effective_Reads,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-effective-writes}@anchor{f4}
+@anchor{gnat_rm/implementation_defined_aspects aspect-effective-writes}@anchor{128}
@section Aspect Effective_Writes
@geindex Effective_Writes
-This aspect is equivalent to pragma @cite{Effective_Writes}.
+This aspect is equivalent to @ref{58,,pragma Effective_Writes}.
@node Aspect Extensions_Visible,Aspect Favor_Top_Level,Aspect Effective_Writes,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-extensions-visible}@anchor{f5}
+@anchor{gnat_rm/implementation_defined_aspects aspect-extensions-visible}@anchor{129}
@section Aspect Extensions_Visible
@geindex Extensions_Visible
-This aspect is equivalent to pragma @cite{Extensions_Visible}.
+This aspect is equivalent to @ref{64,,pragma Extensions_Visible}.
@node Aspect Favor_Top_Level,Aspect Ghost,Aspect Extensions_Visible,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-favor-top-level}@anchor{f6}
+@anchor{gnat_rm/implementation_defined_aspects aspect-favor-top-level}@anchor{12a}
@section Aspect Favor_Top_Level
@geindex Favor_Top_Level
-This boolean aspect is equivalent to pragma @cite{Favor_Top_Level}.
+This boolean aspect is equivalent to @ref{69,,pragma Favor_Top_Level}.
@node Aspect Ghost,Aspect Global,Aspect Favor_Top_Level,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-ghost}@anchor{f7}
+@anchor{gnat_rm/implementation_defined_aspects aspect-ghost}@anchor{12b}
@section Aspect Ghost
@geindex Ghost
-This aspect is equivalent to pragma @cite{Ghost}.
+This aspect is equivalent to @ref{6c,,pragma Ghost}.
@node Aspect Global,Aspect Initial_Condition,Aspect Ghost,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-global}@anchor{f8}
+@anchor{gnat_rm/implementation_defined_aspects aspect-global}@anchor{12c}
@section Aspect Global
@geindex Global
-This aspect is equivalent to pragma @cite{Global}.
+This aspect is equivalent to @ref{6e,,pragma Global}.
@node Aspect Initial_Condition,Aspect Initializes,Aspect Global,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-initial-condition}@anchor{f9}
+@anchor{gnat_rm/implementation_defined_aspects aspect-initial-condition}@anchor{12d}
@section Aspect Initial_Condition
@geindex Initial_Condition
-This aspect is equivalent to pragma @cite{Initial_Condition}.
+This aspect is equivalent to @ref{7c,,pragma Initial_Condition}.
@node Aspect Initializes,Aspect Inline_Always,Aspect Initial_Condition,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-initializes}@anchor{fa}
+@anchor{gnat_rm/implementation_defined_aspects aspect-initializes}@anchor{12e}
@section Aspect Initializes
@geindex Initializes
-This aspect is equivalent to pragma @cite{Initializes}.
+This aspect is equivalent to @ref{7e,,pragma Initializes}.
@node Aspect Inline_Always,Aspect Invariant,Aspect Initializes,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-inline-always}@anchor{fb}
+@anchor{gnat_rm/implementation_defined_aspects aspect-inline-always}@anchor{12f}
@section Aspect Inline_Always
@geindex Inline_Always
-This boolean aspect is equivalent to pragma @cite{Inline_Always}.
+This boolean aspect is equivalent to @ref{81,,pragma Inline_Always}.
@node Aspect Invariant,Aspect Invariant'Class,Aspect Inline_Always,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-invariant}@anchor{fc}
+@anchor{gnat_rm/implementation_defined_aspects aspect-invariant}@anchor{130}
@section Aspect Invariant
@geindex Invariant
-This aspect is equivalent to pragma @cite{Invariant}. It is a
+This aspect is equivalent to @ref{88,,pragma Invariant}. It is a
synonym for the language defined aspect @cite{Type_Invariant} except
that it is separately controllable using pragma @cite{Assertion_Policy}.
@node Aspect Invariant'Class,Aspect Iterable,Aspect Invariant,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-invariant-class}@anchor{fd}
+@anchor{gnat_rm/implementation_defined_aspects aspect-invariant-class}@anchor{131}
@section Aspect Invariant'Class
@geindex Invariant'Class
-This aspect is equivalent to pragma @cite{Type_Invariant_Class}. It is a
+This aspect is equivalent to @ref{fb,,pragma Type_Invariant_Class}. It is a
synonym for the language defined aspect @cite{Type_Invariant'Class} except
that it is separately controllable using pragma @cite{Assertion_Policy}.
@node Aspect Iterable,Aspect Linker_Section,Aspect Invariant'Class,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-iterable}@anchor{fe}
+@anchor{gnat_rm/implementation_defined_aspects aspect-iterable}@anchor{132}
@section Aspect Iterable
@@ -9147,91 +9293,99 @@ function Get_Element (Cont : Container; Position : Cursor) return Element_Type;
This aspect is used in the GNAT-defined formal container packages.
@node Aspect Linker_Section,Aspect Lock_Free,Aspect Iterable,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-linker-section}@anchor{ff}
+@anchor{gnat_rm/implementation_defined_aspects aspect-linker-section}@anchor{133}
@section Aspect Linker_Section
@geindex Linker_Section
-This aspect is equivalent to an @cite{Linker_Section} pragma.
+This aspect is equivalent to @ref{90,,pragma Linker_Section}.
-@node Aspect Lock_Free,Aspect No_Elaboration_Code_All,Aspect Linker_Section,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-lock-free}@anchor{100}
+@node Aspect Lock_Free,Aspect Max_Queue_Length,Aspect Linker_Section,Implementation Defined Aspects
+@anchor{gnat_rm/implementation_defined_aspects aspect-lock-free}@anchor{134}
@section Aspect Lock_Free
@geindex Lock_Free
-This boolean aspect is equivalent to pragma @cite{Lock_Free}.
+This boolean aspect is equivalent to @ref{92,,pragma Lock_Free}.
+
+@node Aspect Max_Queue_Length,Aspect No_Elaboration_Code_All,Aspect Lock_Free,Implementation Defined Aspects
+@anchor{gnat_rm/implementation_defined_aspects aspect-max-queue-length}@anchor{135}
+@section Aspect Max_Queue_Length
+
+
+@geindex Max_Queue_Length
+
+This aspect is equivalent to @emph{pragma Max_Queue_Length}.
-@node Aspect No_Elaboration_Code_All,Aspect No_Tagged_Streams,Aspect Lock_Free,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-no-elaboration-code-all}@anchor{101}
+@node Aspect No_Elaboration_Code_All,Aspect No_Tagged_Streams,Aspect Max_Queue_Length,Implementation Defined Aspects
+@anchor{gnat_rm/implementation_defined_aspects aspect-no-elaboration-code-all}@anchor{136}
@section Aspect No_Elaboration_Code_All
@geindex No_Elaboration_Code_All
-This aspect is equivalent to a @cite{pragma No_Elaboration_Code_All}
-statement for a program unit.
+This aspect is equivalent to @ref{9c,,pragma No_Elaboration_Code_All}
+for a program unit.
@node Aspect No_Tagged_Streams,Aspect Object_Size,Aspect No_Elaboration_Code_All,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-no-tagged-streams}@anchor{102}
+@anchor{gnat_rm/implementation_defined_aspects aspect-no-tagged-streams}@anchor{137}
@section Aspect No_Tagged_Streams
@geindex No_Tagged_Streams
-This aspect is equivalent to a @cite{pragma No_Tagged_Streams} with an
+This aspect is equivalent to @ref{a1,,pragma No_Tagged_Streams} with an
argument specifying a root tagged type (thus this aspect can only be
applied to such a type).
@node Aspect Object_Size,Aspect Obsolescent,Aspect No_Tagged_Streams,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-object-size}@anchor{103}
+@anchor{gnat_rm/implementation_defined_aspects aspect-object-size}@anchor{138}
@section Aspect Object_Size
@geindex Object_Size
-This aspect is equivalent to an @cite{Object_Size} attribute definition
-clause.
+This aspect is equivalent to @ref{139,,attribute Object_Size}.
@node Aspect Obsolescent,Aspect Part_Of,Aspect Object_Size,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-obsolescent}@anchor{104}
+@anchor{gnat_rm/implementation_defined_aspects aspect-obsolescent}@anchor{13a}
@section Aspect Obsolescent
@geindex Obsolsecent
-This aspect is equivalent to an @cite{Obsolescent} pragma. Note that the
+This aspect is equivalent to @ref{a4,,pragma Obsolescent}. Note that the
evaluation of this aspect happens at the point of occurrence, it is not
delayed until the freeze point.
@node Aspect Part_Of,Aspect Persistent_BSS,Aspect Obsolescent,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-part-of}@anchor{105}
+@anchor{gnat_rm/implementation_defined_aspects aspect-part-of}@anchor{13b}
@section Aspect Part_Of
@geindex Part_Of
-This aspect is equivalent to pragma @cite{Part_Of}.
+This aspect is equivalent to @ref{ac,,pragma Part_Of}.
@node Aspect Persistent_BSS,Aspect Predicate,Aspect Part_Of,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-persistent-bss}@anchor{106}
+@anchor{gnat_rm/implementation_defined_aspects aspect-persistent-bss}@anchor{13c}
@section Aspect Persistent_BSS
@geindex Persistent_BSS
-This boolean aspect is equivalent to pragma @cite{Persistent_BSS}.
+This boolean aspect is equivalent to @ref{ae,,pragma Persistent_BSS}.
@node Aspect Predicate,Aspect Pure_Function,Aspect Persistent_BSS,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-predicate}@anchor{107}
+@anchor{gnat_rm/implementation_defined_aspects aspect-predicate}@anchor{13d}
@section Aspect Predicate
@geindex Predicate
-This aspect is equivalent to pragma @cite{Predicate}. It is thus
+This aspect is equivalent to @ref{b7,,pragma Predicate}. It is thus
similar to the language defined aspects @cite{Dynamic_Predicate}
and @cite{Static_Predicate} except that whether the resulting
predicate is static or dynamic is controlled by the form of the
@@ -9239,233 +9393,239 @@ expression. It is also separately controllable using pragma
@cite{Assertion_Policy}.
@node Aspect Pure_Function,Aspect Refined_Depends,Aspect Predicate,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-pure-function}@anchor{108}
+@anchor{gnat_rm/implementation_defined_aspects aspect-pure-function}@anchor{13e}
@section Aspect Pure_Function
@geindex Pure_Function
-This boolean aspect is equivalent to pragma @cite{Pure_Function}.
+This boolean aspect is equivalent to @ref{c3,,pragma Pure_Function}.
@node Aspect Refined_Depends,Aspect Refined_Global,Aspect Pure_Function,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-refined-depends}@anchor{109}
+@anchor{gnat_rm/implementation_defined_aspects aspect-refined-depends}@anchor{13f}
@section Aspect Refined_Depends
@geindex Refined_Depends
-This aspect is equivalent to pragma @cite{Refined_Depends}.
+This aspect is equivalent to @ref{c8,,pragma Refined_Depends}.
@node Aspect Refined_Global,Aspect Refined_Post,Aspect Refined_Depends,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-refined-global}@anchor{10a}
+@anchor{gnat_rm/implementation_defined_aspects aspect-refined-global}@anchor{140}
@section Aspect Refined_Global
@geindex Refined_Global
-This aspect is equivalent to pragma @cite{Refined_Global}.
+This aspect is equivalent to @ref{c9,,pragma Refined_Global}.
@node Aspect Refined_Post,Aspect Refined_State,Aspect Refined_Global,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-refined-post}@anchor{10b}
+@anchor{gnat_rm/implementation_defined_aspects aspect-refined-post}@anchor{141}
@section Aspect Refined_Post
@geindex Refined_Post
-This aspect is equivalent to pragma @cite{Refined_Post}.
+This aspect is equivalent to @ref{cb,,pragma Refined_Post}.
@node Aspect Refined_State,Aspect Remote_Access_Type,Aspect Refined_Post,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-refined-state}@anchor{10c}
+@anchor{gnat_rm/implementation_defined_aspects aspect-refined-state}@anchor{142}
@section Aspect Refined_State
@geindex Refined_State
-This aspect is equivalent to pragma @cite{Refined_State}.
+This aspect is equivalent to @ref{cd,,pragma Refined_State}.
-@node Aspect Remote_Access_Type,Aspect Scalar_Storage_Order,Aspect Refined_State,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-remote-access-type}@anchor{10d}
+@node Aspect Remote_Access_Type,Aspect Secondary_Stack_Size,Aspect Refined_State,Implementation Defined Aspects
+@anchor{gnat_rm/implementation_defined_aspects aspect-remote-access-type}@anchor{143}
@section Aspect Remote_Access_Type
@geindex Remote_Access_Type
-This aspect is equivalent to pragma @cite{Remote_Access_Type}.
+This aspect is equivalent to @ref{d1,,pragma Remote_Access_Type}.
-@node Aspect Scalar_Storage_Order,Aspect Shared,Aspect Remote_Access_Type,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-scalar-storage-order}@anchor{10e}
+@node Aspect Secondary_Stack_Size,Aspect Scalar_Storage_Order,Aspect Remote_Access_Type,Implementation Defined Aspects
+@anchor{gnat_rm/implementation_defined_aspects aspect-secondary-stack-size}@anchor{144}
+@section Aspect Secondary_Stack_Size
+
+
+@geindex Secondary_Stack_Size
+
+This aspect is equivalent to @ref{d6,,pragma Secondary_Stack_Size}.
+
+@node Aspect Scalar_Storage_Order,Aspect Shared,Aspect Secondary_Stack_Size,Implementation Defined Aspects
+@anchor{gnat_rm/implementation_defined_aspects aspect-scalar-storage-order}@anchor{145}
@section Aspect Scalar_Storage_Order
@geindex Scalar_Storage_Order
-This aspect is equivalent to a @cite{Scalar_Storage_Order}
-attribute definition clause.
+This aspect is equivalent to a @ref{146,,attribute Scalar_Storage_Order}.
@node Aspect Shared,Aspect Simple_Storage_Pool,Aspect Scalar_Storage_Order,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-shared}@anchor{10f}
+@anchor{gnat_rm/implementation_defined_aspects aspect-shared}@anchor{147}
@section Aspect Shared
@geindex Shared
-This boolean aspect is equivalent to pragma @cite{Shared},
+This boolean aspect is equivalent to @ref{d9,,pragma Shared}
and is thus a synonym for aspect @cite{Atomic}.
@node Aspect Simple_Storage_Pool,Aspect Simple_Storage_Pool_Type,Aspect Shared,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-simple-storage-pool}@anchor{110}
+@anchor{gnat_rm/implementation_defined_aspects aspect-simple-storage-pool}@anchor{148}
@section Aspect Simple_Storage_Pool
@geindex Simple_Storage_Pool
-This aspect is equivalent to a @cite{Simple_Storage_Pool}
-attribute definition clause.
+This aspect is equivalent to @ref{de,,attribute Simple_Storage_Pool}.
@node Aspect Simple_Storage_Pool_Type,Aspect SPARK_Mode,Aspect Simple_Storage_Pool,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-simple-storage-pool-type}@anchor{111}
+@anchor{gnat_rm/implementation_defined_aspects aspect-simple-storage-pool-type}@anchor{149}
@section Aspect Simple_Storage_Pool_Type
@geindex Simple_Storage_Pool_Type
-This boolean aspect is equivalent to pragma @cite{Simple_Storage_Pool_Type}.
+This boolean aspect is equivalent to @ref{dc,,pragma Simple_Storage_Pool_Type}.
@node Aspect SPARK_Mode,Aspect Suppress_Debug_Info,Aspect Simple_Storage_Pool_Type,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-spark-mode}@anchor{112}
+@anchor{gnat_rm/implementation_defined_aspects aspect-spark-mode}@anchor{14a}
@section Aspect SPARK_Mode
@geindex SPARK_Mode
-This aspect is equivalent to pragma @cite{SPARK_Mode} and
+This aspect is equivalent to @ref{e4,,pragma SPARK_Mode} and
may be specified for either or both of the specification and body
of a subprogram or package.
@node Aspect Suppress_Debug_Info,Aspect Suppress_Initialization,Aspect SPARK_Mode,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-suppress-debug-info}@anchor{113}
+@anchor{gnat_rm/implementation_defined_aspects aspect-suppress-debug-info}@anchor{14b}
@section Aspect Suppress_Debug_Info
@geindex Suppress_Debug_Info
-This boolean aspect is equivalent to pragma @cite{Suppress_Debug_Info}.
+This boolean aspect is equivalent to @ref{ec,,pragma Suppress_Debug_Info}.
@node Aspect Suppress_Initialization,Aspect Test_Case,Aspect Suppress_Debug_Info,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-suppress-initialization}@anchor{114}
+@anchor{gnat_rm/implementation_defined_aspects aspect-suppress-initialization}@anchor{14c}
@section Aspect Suppress_Initialization
@geindex Suppress_Initialization
-This boolean aspect is equivalent to pragma @cite{Suppress_Initialization}.
+This boolean aspect is equivalent to @ref{f0,,pragma Suppress_Initialization}.
@node Aspect Test_Case,Aspect Thread_Local_Storage,Aspect Suppress_Initialization,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-test-case}@anchor{115}
+@anchor{gnat_rm/implementation_defined_aspects aspect-test-case}@anchor{14d}
@section Aspect Test_Case
@geindex Test_Case
-This aspect is equivalent to pragma @cite{Test_Case}.
+This aspect is equivalent to @ref{f3,,pragma Test_Case}.
@node Aspect Thread_Local_Storage,Aspect Universal_Aliasing,Aspect Test_Case,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-thread-local-storage}@anchor{116}
+@anchor{gnat_rm/implementation_defined_aspects aspect-thread-local-storage}@anchor{14e}
@section Aspect Thread_Local_Storage
@geindex Thread_Local_Storage
-This boolean aspect is equivalent to pragma @cite{Thread_Local_Storage}.
+This boolean aspect is equivalent to @ref{f5,,pragma Thread_Local_Storage}.
@node Aspect Universal_Aliasing,Aspect Universal_Data,Aspect Thread_Local_Storage,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-universal-aliasing}@anchor{117}
+@anchor{gnat_rm/implementation_defined_aspects aspect-universal-aliasing}@anchor{14f}
@section Aspect Universal_Aliasing
@geindex Universal_Aliasing
-This boolean aspect is equivalent to pragma @cite{Universal_Aliasing}.
+This boolean aspect is equivalent to @ref{100,,pragma Universal_Aliasing}.
@node Aspect Universal_Data,Aspect Unmodified,Aspect Universal_Aliasing,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-universal-data}@anchor{118}
+@anchor{gnat_rm/implementation_defined_aspects aspect-universal-data}@anchor{150}
@section Aspect Universal_Data
@geindex Universal_Data
-This aspect is equivalent to pragma @cite{Universal_Data}.
+This aspect is equivalent to @ref{101,,pragma Universal_Data}.
@node Aspect Unmodified,Aspect Unreferenced,Aspect Universal_Data,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-unmodified}@anchor{119}
+@anchor{gnat_rm/implementation_defined_aspects aspect-unmodified}@anchor{151}
@section Aspect Unmodified
@geindex Unmodified
-This boolean aspect is equivalent to pragma @cite{Unmodified}.
+This boolean aspect is equivalent to @ref{104,,pragma Unmodified}.
@node Aspect Unreferenced,Aspect Unreferenced_Objects,Aspect Unmodified,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced}@anchor{11a}
+@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced}@anchor{152}
@section Aspect Unreferenced
@geindex Unreferenced
-This boolean aspect is equivalent to pragma @cite{Unreferenced}. Note that
+This boolean aspect is equivalent to @ref{105,,pragma Unreferenced}. Note that
in the case of formal parameters, it is not permitted to have aspects for
a formal parameter, so in this case the pragma form must be used.
@node Aspect Unreferenced_Objects,Aspect Value_Size,Aspect Unreferenced,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced-objects}@anchor{11b}
+@anchor{gnat_rm/implementation_defined_aspects aspect-unreferenced-objects}@anchor{153}
@section Aspect Unreferenced_Objects
@geindex Unreferenced_Objects
-This boolean aspect is equivalent to pragma @cite{Unreferenced_Objects}.
+This boolean aspect is equivalent to @ref{107,,pragma Unreferenced_Objects}.
@node Aspect Value_Size,Aspect Volatile_Full_Access,Aspect Unreferenced_Objects,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-value-size}@anchor{11c}
+@anchor{gnat_rm/implementation_defined_aspects aspect-value-size}@anchor{154}
@section Aspect Value_Size
@geindex Value_Size
-This aspect is equivalent to a @cite{Value_Size}
-attribute definition clause.
+This aspect is equivalent to @ref{155,,attribute Value_Size}.
@node Aspect Volatile_Full_Access,Aspect Volatile_Function,Aspect Value_Size,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-volatile-full-access}@anchor{11d}
+@anchor{gnat_rm/implementation_defined_aspects aspect-volatile-full-access}@anchor{156}
@section Aspect Volatile_Full_Access
@geindex Volatile_Full_Access
-This boolean aspect is equivalent to pragma @cite{Volatile_Full_Access}.
+This boolean aspect is equivalent to @ref{110,,pragma Volatile_Full_Access}.
@node Aspect Volatile_Function,Aspect Warnings,Aspect Volatile_Full_Access,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-volatile-function}@anchor{11e}
+@anchor{gnat_rm/implementation_defined_aspects aspect-volatile-function}@anchor{157}
@section Aspect Volatile_Function
@geindex Volatile_Function
-This boolean aspect is equivalent to pragma @cite{Volatile_Function}.
+This boolean aspect is equivalent to @ref{113,,pragma Volatile_Function}.
@node Aspect Warnings,,Aspect Volatile_Function,Implementation Defined Aspects
-@anchor{gnat_rm/implementation_defined_aspects aspect-warnings}@anchor{11f}
+@anchor{gnat_rm/implementation_defined_aspects aspect-warnings}@anchor{158}
@section Aspect Warnings
@geindex Warnings
-This aspect is equivalent to the two argument form of pragma @cite{Warnings},
+This aspect is equivalent to the two argument form of @ref{115,,pragma Warnings},
where the first argument is @cite{ON} or @cite{OFF} and the second argument
is the entity.
@node Implementation Defined Attributes,Standard and Implementation Defined Restrictions,Implementation Defined Aspects,Top
-@anchor{gnat_rm/implementation_defined_attributes doc}@anchor{120}@anchor{gnat_rm/implementation_defined_attributes implementation-defined-attributes}@anchor{8}@anchor{gnat_rm/implementation_defined_attributes id1}@anchor{121}
+@anchor{gnat_rm/implementation_defined_attributes doc}@anchor{159}@anchor{gnat_rm/implementation_defined_attributes implementation-defined-attributes}@anchor{8}@anchor{gnat_rm/implementation_defined_attributes id1}@anchor{15a}
@chapter Implementation Defined Attributes
@@ -9513,6 +9673,7 @@ consideration, you should minimize the use of these attributes.
* Attribute Enum_Val::
* Attribute Epsilon::
* Attribute Fast_Math::
+* Attribute Finalization_Size::
* Attribute Fixed_Value::
* Attribute From_Any::
* Attribute Has_Access_Values::
@@ -9565,7 +9726,7 @@ consideration, you should minimize the use of these attributes.
@end menu
@node Attribute Abort_Signal,Attribute Address_Size,,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-abort-signal}@anchor{122}
+@anchor{gnat_rm/implementation_defined_attributes attribute-abort-signal}@anchor{15b}
@section Attribute Abort_Signal
@@ -9579,7 +9740,7 @@ completely outside the normal semantics of Ada, for a user program to
intercept the abort exception).
@node Attribute Address_Size,Attribute Asm_Input,Attribute Abort_Signal,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-address-size}@anchor{123}
+@anchor{gnat_rm/implementation_defined_attributes attribute-address-size}@anchor{15c}
@section Attribute Address_Size
@@ -9595,7 +9756,7 @@ reference to System.Address'Size is nonstatic because Address
is a private type.
@node Attribute Asm_Input,Attribute Asm_Output,Attribute Address_Size,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-asm-input}@anchor{124}
+@anchor{gnat_rm/implementation_defined_attributes attribute-asm-input}@anchor{15d}
@section Attribute Asm_Input
@@ -9609,10 +9770,10 @@ to be a static expression, and is the constraint for the parameter,
value to be used as the input argument. The possible values for the
constant are the same as those used in the RTL, and are dependent on
the configuration file used to built the GCC back end.
-@ref{125,,Machine Code Insertions}
+@ref{15e,,Machine Code Insertions}
@node Attribute Asm_Output,Attribute Atomic_Always_Lock_Free,Attribute Asm_Input,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-asm-output}@anchor{126}
+@anchor{gnat_rm/implementation_defined_attributes attribute-asm-output}@anchor{15f}
@section Attribute Asm_Output
@@ -9628,10 +9789,10 @@ result. The possible values for constraint are the same as those used in
the RTL, and are dependent on the configuration file used to build the
GCC back end. If there are no output operands, then this argument may
either be omitted, or explicitly given as @cite{No_Output_Operands}.
-@ref{125,,Machine Code Insertions}
+@ref{15e,,Machine Code Insertions}
@node Attribute Atomic_Always_Lock_Free,Attribute Bit,Attribute Asm_Output,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-atomic-always-lock-free}@anchor{127}
+@anchor{gnat_rm/implementation_defined_attributes attribute-atomic-always-lock-free}@anchor{160}
@section Attribute Atomic_Always_Lock_Free
@@ -9643,7 +9804,7 @@ and False otherwise. The result indicate whether atomic operations are
supported by the target for the given type.
@node Attribute Bit,Attribute Bit_Position,Attribute Atomic_Always_Lock_Free,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-bit}@anchor{128}
+@anchor{gnat_rm/implementation_defined_attributes attribute-bit}@anchor{161}
@section Attribute Bit
@@ -9674,7 +9835,7 @@ This attribute is designed to be compatible with the DEC Ada 83 definition
and implementation of the @cite{Bit} attribute.
@node Attribute Bit_Position,Attribute Code_Address,Attribute Bit,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-bit-position}@anchor{129}
+@anchor{gnat_rm/implementation_defined_attributes attribute-bit-position}@anchor{162}
@section Attribute Bit_Position
@@ -9689,7 +9850,7 @@ type @cite{Universal_Integer}. The value depends only on the field
the containing record @cite{R}.
@node Attribute Code_Address,Attribute Compiler_Version,Attribute Bit_Position,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-code-address}@anchor{12a}
+@anchor{gnat_rm/implementation_defined_attributes attribute-code-address}@anchor{163}
@section Attribute Code_Address
@@ -9732,7 +9893,7 @@ the same value as is returned by the corresponding @cite{'Address}
attribute.
@node Attribute Compiler_Version,Attribute Constrained,Attribute Code_Address,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-compiler-version}@anchor{12b}
+@anchor{gnat_rm/implementation_defined_attributes attribute-compiler-version}@anchor{164}
@section Attribute Compiler_Version
@@ -9743,7 +9904,7 @@ prefix) yields a static string identifying the version of the compiler
being used to compile the unit containing the attribute reference.
@node Attribute Constrained,Attribute Default_Bit_Order,Attribute Compiler_Version,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-constrained}@anchor{12c}
+@anchor{gnat_rm/implementation_defined_attributes attribute-constrained}@anchor{165}
@section Attribute Constrained
@@ -9758,7 +9919,7 @@ record type without discriminants is always @cite{True}. This usage is
compatible with older Ada compilers, including notably DEC Ada.
@node Attribute Default_Bit_Order,Attribute Default_Scalar_Storage_Order,Attribute Constrained,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-default-bit-order}@anchor{12d}
+@anchor{gnat_rm/implementation_defined_attributes attribute-default-bit-order}@anchor{166}
@section Attribute Default_Bit_Order
@@ -9775,7 +9936,7 @@ as a @cite{Pos} value (0 for @cite{High_Order_First}, 1 for
@cite{Default_Bit_Order} in package @cite{System}.
@node Attribute Default_Scalar_Storage_Order,Attribute Deref,Attribute Default_Bit_Order,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-default-scalar-storage-order}@anchor{12e}
+@anchor{gnat_rm/implementation_defined_attributes attribute-default-scalar-storage-order}@anchor{167}
@section Attribute Default_Scalar_Storage_Order
@@ -9792,7 +9953,7 @@ equal to @cite{Default_Bit_Order} if unspecified) as a
@cite{System.Bit_Order} value. This is a static attribute.
@node Attribute Deref,Attribute Descriptor_Size,Attribute Default_Scalar_Storage_Order,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-deref}@anchor{12f}
+@anchor{gnat_rm/implementation_defined_attributes attribute-deref}@anchor{168}
@section Attribute Deref
@@ -9805,7 +9966,7 @@ a named access-to-@cite{typ} type, except that it yields a variable, so it can b
used on the left side of an assignment.
@node Attribute Descriptor_Size,Attribute Elaborated,Attribute Deref,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-descriptor-size}@anchor{130}
+@anchor{gnat_rm/implementation_defined_attributes attribute-descriptor-size}@anchor{169}
@section Attribute Descriptor_Size
@@ -9832,7 +9993,7 @@ In the example above, the descriptor contains two values of type
a size of 31 bits and an alignment of 4, the descriptor size is @cite{2 * Positive'Size + 2} or 64 bits.
@node Attribute Elaborated,Attribute Elab_Body,Attribute Descriptor_Size,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-elaborated}@anchor{131}
+@anchor{gnat_rm/implementation_defined_attributes attribute-elaborated}@anchor{16a}
@section Attribute Elaborated
@@ -9847,7 +10008,7 @@ units has been completed. An exception is for units which need no
elaboration, the value is always False for such units.
@node Attribute Elab_Body,Attribute Elab_Spec,Attribute Elaborated,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-elab-body}@anchor{132}
+@anchor{gnat_rm/implementation_defined_attributes attribute-elab-body}@anchor{16b}
@section Attribute Elab_Body
@@ -9863,7 +10024,7 @@ e.g., if it is necessary to do selective re-elaboration to fix some
error.
@node Attribute Elab_Spec,Attribute Elab_Subp_Body,Attribute Elab_Body,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-elab-spec}@anchor{133}
+@anchor{gnat_rm/implementation_defined_attributes attribute-elab-spec}@anchor{16c}
@section Attribute Elab_Spec
@@ -9879,7 +10040,7 @@ Ada code, e.g., if it is necessary to do selective re-elaboration to fix
some error.
@node Attribute Elab_Subp_Body,Attribute Emax,Attribute Elab_Spec,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-elab-subp-body}@anchor{134}
+@anchor{gnat_rm/implementation_defined_attributes attribute-elab-subp-body}@anchor{16d}
@section Attribute Elab_Subp_Body
@@ -9893,7 +10054,7 @@ elaboration procedure by the binder in CodePeer mode only and is unrecognized
otherwise.
@node Attribute Emax,Attribute Enabled,Attribute Elab_Subp_Body,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-emax}@anchor{135}
+@anchor{gnat_rm/implementation_defined_attributes attribute-emax}@anchor{16e}
@section Attribute Emax
@@ -9906,7 +10067,7 @@ the Ada 83 reference manual for an exact description of the semantics of
this attribute.
@node Attribute Enabled,Attribute Enum_Rep,Attribute Emax,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-enabled}@anchor{136}
+@anchor{gnat_rm/implementation_defined_attributes attribute-enabled}@anchor{16f}
@section Attribute Enabled
@@ -9930,7 +10091,7 @@ a @cite{pragma Suppress} or @cite{pragma Unsuppress} before instantiating
the package or subprogram, controlling whether the check will be present.
@node Attribute Enum_Rep,Attribute Enum_Val,Attribute Enabled,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-enum-rep}@anchor{137}
+@anchor{gnat_rm/implementation_defined_attributes attribute-enum-rep}@anchor{170}
@section Attribute Enum_Rep
@@ -9967,7 +10128,7 @@ integer calculation is done at run time, then the call to @cite{Enum_Rep}
may raise @cite{Constraint_Error}.
@node Attribute Enum_Val,Attribute Epsilon,Attribute Enum_Rep,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-enum-val}@anchor{138}
+@anchor{gnat_rm/implementation_defined_attributes attribute-enum-val}@anchor{171}
@section Attribute Enum_Val
@@ -9990,7 +10151,7 @@ absence of an enumeration representation clause. This is a static
attribute (i.e., the result is static if the argument is static).
@node Attribute Epsilon,Attribute Fast_Math,Attribute Enum_Val,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-epsilon}@anchor{139}
+@anchor{gnat_rm/implementation_defined_attributes attribute-epsilon}@anchor{172}
@section Attribute Epsilon
@@ -10002,8 +10163,8 @@ The @cite{Epsilon} attribute is provided for compatibility with Ada 83. See
the Ada 83 reference manual for an exact description of the semantics of
this attribute.
-@node Attribute Fast_Math,Attribute Fixed_Value,Attribute Epsilon,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-fast-math}@anchor{13a}
+@node Attribute Fast_Math,Attribute Finalization_Size,Attribute Epsilon,Implementation Defined Attributes
+@anchor{gnat_rm/implementation_defined_attributes attribute-fast-math}@anchor{173}
@section Attribute Fast_Math
@@ -10013,8 +10174,26 @@ this attribute.
prefix) yields a static Boolean value that is True if pragma
@cite{Fast_Math} is active, and False otherwise.
-@node Attribute Fixed_Value,Attribute From_Any,Attribute Fast_Math,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-fixed-value}@anchor{13b}
+@node Attribute Finalization_Size,Attribute Fixed_Value,Attribute Fast_Math,Implementation Defined Attributes
+@anchor{gnat_rm/implementation_defined_attributes attribute-finalization-size}@anchor{174}
+@section Attribute Finalization_Size
+
+
+@geindex Finalization_Size
+
+The prefix of attribute @cite{Finalization_Size} must be an object or
+a non-class-wide type. This attribute returns the size of any hidden data
+reserved by the compiler to handle finalization-related actions. The type of
+the attribute is @cite{universal_integer}.
+
+@cite{Finalization_Size} yields a value of zero for a type with no controlled
+parts, an object whose type has no controlled parts, or an object of a
+class-wide type whose tag denotes a type with no controlled parts.
+
+Note that only heap-allocated objects contain finalization data.
+
+@node Attribute Fixed_Value,Attribute From_Any,Attribute Finalization_Size,Implementation Defined Attributes
+@anchor{gnat_rm/implementation_defined_attributes attribute-fixed-value}@anchor{175}
@section Attribute Fixed_Value
@@ -10041,7 +10220,7 @@ This attribute is primarily intended for use in implementation of the
input-output functions for fixed-point values.
@node Attribute From_Any,Attribute Has_Access_Values,Attribute Fixed_Value,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-from-any}@anchor{13c}
+@anchor{gnat_rm/implementation_defined_attributes attribute-from-any}@anchor{176}
@section Attribute From_Any
@@ -10051,7 +10230,7 @@ This internal attribute is used for the generation of remote subprogram
stubs in the context of the Distributed Systems Annex.
@node Attribute Has_Access_Values,Attribute Has_Discriminants,Attribute From_Any,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-has-access-values}@anchor{13d}
+@anchor{gnat_rm/implementation_defined_attributes attribute-has-access-values}@anchor{177}
@section Attribute Has_Access_Values
@@ -10069,7 +10248,7 @@ definitions. If the attribute is applied to a generic private type, it
indicates whether or not the corresponding actual type has access values.
@node Attribute Has_Discriminants,Attribute Img,Attribute Has_Access_Values,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-has-discriminants}@anchor{13e}
+@anchor{gnat_rm/implementation_defined_attributes attribute-has-discriminants}@anchor{178}
@section Attribute Has_Discriminants
@@ -10085,7 +10264,7 @@ definitions. If the attribute is applied to a generic private type, it
indicates whether or not the corresponding actual type has discriminants.
@node Attribute Img,Attribute Integer_Value,Attribute Has_Discriminants,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-img}@anchor{13f}
+@anchor{gnat_rm/implementation_defined_attributes attribute-img}@anchor{179}
@section Attribute Img
@@ -10115,7 +10294,7 @@ that returns the appropriate string when called. This means that
in an instantiation as a function parameter.
@node Attribute Integer_Value,Attribute Invalid_Value,Attribute Img,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-integer-value}@anchor{140}
+@anchor{gnat_rm/implementation_defined_attributes attribute-integer-value}@anchor{17a}
@section Attribute Integer_Value
@@ -10143,7 +10322,7 @@ This attribute is primarily intended for use in implementation of the
standard input-output functions for fixed-point values.
@node Attribute Invalid_Value,Attribute Iterable,Attribute Integer_Value,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-invalid-value}@anchor{141}
+@anchor{gnat_rm/implementation_defined_attributes attribute-invalid-value}@anchor{17b}
@section Attribute Invalid_Value
@@ -10157,7 +10336,7 @@ including the ability to modify the value with the binder -Sxx flag and
relevant environment variables at run time.
@node Attribute Iterable,Attribute Large,Attribute Invalid_Value,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-iterable}@anchor{142}
+@anchor{gnat_rm/implementation_defined_attributes attribute-iterable}@anchor{17c}
@section Attribute Iterable
@@ -10166,7 +10345,7 @@ relevant environment variables at run time.
Equivalent to Aspect Iterable.
@node Attribute Large,Attribute Library_Level,Attribute Iterable,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-large}@anchor{143}
+@anchor{gnat_rm/implementation_defined_attributes attribute-large}@anchor{17d}
@section Attribute Large
@@ -10179,7 +10358,7 @@ the Ada 83 reference manual for an exact description of the semantics of
this attribute.
@node Attribute Library_Level,Attribute Lock_Free,Attribute Large,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-library-level}@anchor{144}
+@anchor{gnat_rm/implementation_defined_attributes attribute-library-level}@anchor{17e}
@section Attribute Library_Level
@@ -10205,7 +10384,7 @@ end Gen;
@end example
@node Attribute Lock_Free,Attribute Loop_Entry,Attribute Library_Level,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-lock-free}@anchor{145}
+@anchor{gnat_rm/implementation_defined_attributes attribute-lock-free}@anchor{17f}
@section Attribute Lock_Free
@@ -10215,7 +10394,7 @@ end Gen;
pragma @cite{Lock_Free} applies to P.
@node Attribute Loop_Entry,Attribute Machine_Size,Attribute Lock_Free,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-loop-entry}@anchor{146}
+@anchor{gnat_rm/implementation_defined_attributes attribute-loop-entry}@anchor{180}
@section Attribute Loop_Entry
@@ -10245,7 +10424,7 @@ entry. This copy is not performed if the loop is not entered, or if the
corresponding pragmas are ignored or disabled.
@node Attribute Machine_Size,Attribute Mantissa,Attribute Loop_Entry,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-machine-size}@anchor{147}
+@anchor{gnat_rm/implementation_defined_attributes attribute-machine-size}@anchor{181}
@section Attribute Machine_Size
@@ -10255,7 +10434,7 @@ This attribute is identical to the @cite{Object_Size} attribute. It is
provided for compatibility with the DEC Ada 83 attribute of this name.
@node Attribute Mantissa,Attribute Maximum_Alignment,Attribute Machine_Size,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-mantissa}@anchor{148}
+@anchor{gnat_rm/implementation_defined_attributes attribute-mantissa}@anchor{182}
@section Attribute Mantissa
@@ -10268,7 +10447,7 @@ the Ada 83 reference manual for an exact description of the semantics of
this attribute.
@node Attribute Maximum_Alignment,Attribute Mechanism_Code,Attribute Mantissa,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-maximum-alignment}@anchor{149}@anchor{gnat_rm/implementation_defined_attributes id2}@anchor{14a}
+@anchor{gnat_rm/implementation_defined_attributes attribute-maximum-alignment}@anchor{183}@anchor{gnat_rm/implementation_defined_attributes id2}@anchor{184}
@section Attribute Maximum_Alignment
@@ -10284,7 +10463,7 @@ for an object, guaranteeing that it is properly aligned in all
cases.
@node Attribute Mechanism_Code,Attribute Null_Parameter,Attribute Maximum_Alignment,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-mechanism-code}@anchor{14b}
+@anchor{gnat_rm/implementation_defined_attributes attribute-mechanism-code}@anchor{185}
@section Attribute Mechanism_Code
@@ -10315,7 +10494,7 @@ by reference
@end table
@node Attribute Null_Parameter,Attribute Object_Size,Attribute Mechanism_Code,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-null-parameter}@anchor{14c}
+@anchor{gnat_rm/implementation_defined_attributes attribute-null-parameter}@anchor{186}
@section Attribute Null_Parameter
@@ -10340,7 +10519,7 @@ There is no way of indicating this without the @cite{Null_Parameter}
attribute.
@node Attribute Object_Size,Attribute Old,Attribute Null_Parameter,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-object-size}@anchor{14d}
+@anchor{gnat_rm/implementation_defined_attributes attribute-object-size}@anchor{139}@anchor{gnat_rm/implementation_defined_attributes id3}@anchor{187}
@section Attribute Object_Size
@@ -10410,7 +10589,7 @@ Similar additional checks are performed in other contexts requiring
statically matching subtypes.
@node Attribute Old,Attribute Passed_By_Reference,Attribute Object_Size,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-old}@anchor{14e}
+@anchor{gnat_rm/implementation_defined_attributes attribute-old}@anchor{188}
@section Attribute Old
@@ -10425,7 +10604,7 @@ definition are allowed under control of
implementation defined pragma @cite{Unevaluated_Use_Of_Old}.
@node Attribute Passed_By_Reference,Attribute Pool_Address,Attribute Old,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-passed-by-reference}@anchor{14f}
+@anchor{gnat_rm/implementation_defined_attributes attribute-passed-by-reference}@anchor{189}
@section Attribute Passed_By_Reference
@@ -10441,7 +10620,7 @@ passed by copy in calls. For scalar types, the result is always @cite{False}
and is static. For non-scalar types, the result is nonstatic.
@node Attribute Pool_Address,Attribute Range_Length,Attribute Passed_By_Reference,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-pool-address}@anchor{150}
+@anchor{gnat_rm/implementation_defined_attributes attribute-pool-address}@anchor{18a}
@section Attribute Pool_Address
@@ -10466,7 +10645,7 @@ For an object created by @cite{new}, @code{Ptr.all'Pool_Address} is
what is passed to @cite{Allocate} and returned from @cite{Deallocate}.
@node Attribute Range_Length,Attribute Restriction_Set,Attribute Pool_Address,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-range-length}@anchor{151}
+@anchor{gnat_rm/implementation_defined_attributes attribute-range-length}@anchor{18b}
@section Attribute Range_Length
@@ -10479,7 +10658,7 @@ applied to the index subtype of a one dimensional array always gives the
same result as @cite{Length} applied to the array itself.
@node Attribute Restriction_Set,Attribute Result,Attribute Range_Length,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-restriction-set}@anchor{152}
+@anchor{gnat_rm/implementation_defined_attributes attribute-restriction-set}@anchor{18c}
@section Attribute Restriction_Set
@@ -10549,7 +10728,7 @@ Restrictions pragma, they are not analyzed semantically,
so they do not have a type.
@node Attribute Result,Attribute Safe_Emax,Attribute Restriction_Set,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-result}@anchor{153}
+@anchor{gnat_rm/implementation_defined_attributes attribute-result}@anchor{18d}
@section Attribute Result
@@ -10562,7 +10741,7 @@ For a further discussion of the use of this attribute and examples of its use,
see the description of pragma Postcondition.
@node Attribute Safe_Emax,Attribute Safe_Large,Attribute Result,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-safe-emax}@anchor{154}
+@anchor{gnat_rm/implementation_defined_attributes attribute-safe-emax}@anchor{18e}
@section Attribute Safe_Emax
@@ -10575,7 +10754,7 @@ the Ada 83 reference manual for an exact description of the semantics of
this attribute.
@node Attribute Safe_Large,Attribute Safe_Small,Attribute Safe_Emax,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-safe-large}@anchor{155}
+@anchor{gnat_rm/implementation_defined_attributes attribute-safe-large}@anchor{18f}
@section Attribute Safe_Large
@@ -10588,7 +10767,7 @@ the Ada 83 reference manual for an exact description of the semantics of
this attribute.
@node Attribute Safe_Small,Attribute Scalar_Storage_Order,Attribute Safe_Large,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-safe-small}@anchor{156}
+@anchor{gnat_rm/implementation_defined_attributes attribute-safe-small}@anchor{190}
@section Attribute Safe_Small
@@ -10601,7 +10780,7 @@ the Ada 83 reference manual for an exact description of the semantics of
this attribute.
@node Attribute Scalar_Storage_Order,Attribute Simple_Storage_Pool,Attribute Safe_Small,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-scalar-storage-order}@anchor{157}
+@anchor{gnat_rm/implementation_defined_attributes id4}@anchor{191}@anchor{gnat_rm/implementation_defined_attributes attribute-scalar-storage-order}@anchor{146}
@section Attribute Scalar_Storage_Order
@@ -10663,10 +10842,7 @@ types. This may be overridden for the derived type by giving an explicit scalar
storage order for the derived type. For a record extension, the derived type
must have the same scalar storage order as the parent type.
-If a component of @cite{T} is of a record or array type, then that type must
-also have a @cite{Scalar_Storage_Order} attribute definition clause.
-
-A component of a record or array type that is a packed array, or that
+A component of a record or array type that is a bit-packed array, or that
does not start on a byte boundary, must have the same scalar storage order
as the enclosing record or array type.
@@ -10713,12 +10889,17 @@ inheritance in the case of a derived type), then the default is normally
the native ordering of the target, but this default can be overridden using
pragma @cite{Default_Scalar_Storage_Order}.
+Note that if a component of @cite{T} is itself of a record or array type,
+the specfied @cite{Scalar_Storage_Order} does @emph{not} apply to that nested type:
+an explicit attribute definition clause must be provided for the component
+type as well if desired.
+
Note that the scalar storage order only affects the in-memory data
representation. It has no effect on the representation used by stream
attributes.
@node Attribute Simple_Storage_Pool,Attribute Small,Attribute Scalar_Storage_Order,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-simple-storage-pool}@anchor{b9}@anchor{gnat_rm/implementation_defined_attributes id3}@anchor{158}
+@anchor{gnat_rm/implementation_defined_attributes attribute-simple-storage-pool}@anchor{de}@anchor{gnat_rm/implementation_defined_attributes id5}@anchor{192}
@section Attribute Simple_Storage_Pool
@@ -10781,7 +10962,7 @@ as defined in section 13.11.2 of the Ada Reference Manual, except that the
term 'simple storage pool' is substituted for 'storage pool'.
@node Attribute Small,Attribute Storage_Unit,Attribute Simple_Storage_Pool,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-small}@anchor{159}
+@anchor{gnat_rm/implementation_defined_attributes attribute-small}@anchor{193}
@section Attribute Small
@@ -10797,7 +10978,7 @@ the Ada 83 reference manual for an exact description of the semantics of
this attribute when applied to floating-point types.
@node Attribute Storage_Unit,Attribute Stub_Type,Attribute Small,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-storage-unit}@anchor{15a}
+@anchor{gnat_rm/implementation_defined_attributes attribute-storage-unit}@anchor{194}
@section Attribute Storage_Unit
@@ -10807,7 +10988,7 @@ this attribute when applied to floating-point types.
prefix) provides the same value as @cite{System.Storage_Unit}.
@node Attribute Stub_Type,Attribute System_Allocator_Alignment,Attribute Storage_Unit,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-stub-type}@anchor{15b}
+@anchor{gnat_rm/implementation_defined_attributes attribute-stub-type}@anchor{195}
@section Attribute Stub_Type
@@ -10831,7 +11012,7 @@ unit @cite{System.Partition_Interface}. Use of this attribute will create
an implicit dependency on this unit.
@node Attribute System_Allocator_Alignment,Attribute Target_Name,Attribute Stub_Type,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-system-allocator-alignment}@anchor{15c}
+@anchor{gnat_rm/implementation_defined_attributes attribute-system-allocator-alignment}@anchor{196}
@section Attribute System_Allocator_Alignment
@@ -10848,7 +11029,7 @@ with alignment too large or to enable a realignment circuitry if the
alignment request is larger than this value.
@node Attribute Target_Name,Attribute To_Address,Attribute System_Allocator_Alignment,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-target-name}@anchor{15d}
+@anchor{gnat_rm/implementation_defined_attributes attribute-target-name}@anchor{197}
@section Attribute Target_Name
@@ -10861,7 +11042,7 @@ standard gcc target name without the terminating slash (for
example, GNAT 5.0 on windows yields "i586-pc-mingw32msv").
@node Attribute To_Address,Attribute To_Any,Attribute Target_Name,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-to-address}@anchor{15e}
+@anchor{gnat_rm/implementation_defined_attributes attribute-to-address}@anchor{198}
@section Attribute To_Address
@@ -10884,7 +11065,7 @@ modular manner (e.g., -1 means the same as 16#FFFF_FFFF# on
a 32 bits machine).
@node Attribute To_Any,Attribute Type_Class,Attribute To_Address,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-to-any}@anchor{15f}
+@anchor{gnat_rm/implementation_defined_attributes attribute-to-any}@anchor{199}
@section Attribute To_Any
@@ -10894,7 +11075,7 @@ This internal attribute is used for the generation of remote subprogram
stubs in the context of the Distributed Systems Annex.
@node Attribute Type_Class,Attribute Type_Key,Attribute To_Any,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-type-class}@anchor{160}
+@anchor{gnat_rm/implementation_defined_attributes attribute-type-class}@anchor{19a}
@section Attribute Type_Class
@@ -10924,7 +11105,7 @@ applies to all concurrent types. This attribute is designed to
be compatible with the DEC Ada 83 attribute of the same name.
@node Attribute Type_Key,Attribute TypeCode,Attribute Type_Class,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-type-key}@anchor{161}
+@anchor{gnat_rm/implementation_defined_attributes attribute-type-key}@anchor{19b}
@section Attribute Type_Key
@@ -10936,7 +11117,7 @@ about the type or subtype. This provides improved compatibility with
other implementations that support this attribute.
@node Attribute TypeCode,Attribute Unconstrained_Array,Attribute Type_Key,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-typecode}@anchor{162}
+@anchor{gnat_rm/implementation_defined_attributes attribute-typecode}@anchor{19c}
@section Attribute TypeCode
@@ -10946,7 +11127,7 @@ This internal attribute is used for the generation of remote subprogram
stubs in the context of the Distributed Systems Annex.
@node Attribute Unconstrained_Array,Attribute Universal_Literal_String,Attribute TypeCode,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-unconstrained-array}@anchor{163}
+@anchor{gnat_rm/implementation_defined_attributes attribute-unconstrained-array}@anchor{19d}
@section Attribute Unconstrained_Array
@@ -10960,7 +11141,7 @@ still static, and yields the result of applying this test to the
generic actual.
@node Attribute Universal_Literal_String,Attribute Unrestricted_Access,Attribute Unconstrained_Array,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-universal-literal-string}@anchor{164}
+@anchor{gnat_rm/implementation_defined_attributes attribute-universal-literal-string}@anchor{19e}
@section Attribute Universal_Literal_String
@@ -10988,7 +11169,7 @@ end;
@end example
@node Attribute Unrestricted_Access,Attribute Update,Attribute Universal_Literal_String,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-unrestricted-access}@anchor{165}
+@anchor{gnat_rm/implementation_defined_attributes attribute-unrestricted-access}@anchor{19f}
@section Attribute Unrestricted_Access
@@ -11175,7 +11356,7 @@ In general this is a risky approach. It may appear to "work" but such uses of
of @cite{GNAT} to another, so are best avoided if possible.
@node Attribute Update,Attribute Valid_Scalars,Attribute Unrestricted_Access,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-update}@anchor{166}
+@anchor{gnat_rm/implementation_defined_attributes attribute-update}@anchor{1a0}
@section Attribute Update
@@ -11256,7 +11437,7 @@ A := A'Update ((1, 2) => 20, (3, 4) => 30);
which changes element (1,2) to 20 and (3,4) to 30.
@node Attribute Valid_Scalars,Attribute VADS_Size,Attribute Update,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-valid-scalars}@anchor{167}
+@anchor{gnat_rm/implementation_defined_attributes attribute-valid-scalars}@anchor{1a1}
@section Attribute Valid_Scalars
@@ -11291,7 +11472,7 @@ to write a function with a single use of the attribute, and then call that
function from multiple places.
@node Attribute VADS_Size,Attribute Value_Size,Attribute Valid_Scalars,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-vads-size}@anchor{168}
+@anchor{gnat_rm/implementation_defined_attributes attribute-vads-size}@anchor{1a2}
@section Attribute VADS_Size
@@ -11311,7 +11492,7 @@ gives the result that would be obtained by applying the attribute to
the corresponding type.
@node Attribute Value_Size,Attribute Wchar_T_Size,Attribute VADS_Size,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-value-size}@anchor{169}
+@anchor{gnat_rm/implementation_defined_attributes id6}@anchor{1a3}@anchor{gnat_rm/implementation_defined_attributes attribute-value-size}@anchor{155}
@section Attribute Value_Size
@@ -11325,7 +11506,7 @@ a value of the given subtype. It is the same as @code{type'Size},
but, unlike @cite{Size}, may be set for non-first subtypes.
@node Attribute Wchar_T_Size,Attribute Word_Size,Attribute Value_Size,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-wchar-t-size}@anchor{16a}
+@anchor{gnat_rm/implementation_defined_attributes attribute-wchar-t-size}@anchor{1a4}
@section Attribute Wchar_T_Size
@@ -11337,7 +11518,7 @@ primarily for constructing the definition of this type in
package @cite{Interfaces.C}. The result is a static constant.
@node Attribute Word_Size,,Attribute Wchar_T_Size,Implementation Defined Attributes
-@anchor{gnat_rm/implementation_defined_attributes attribute-word-size}@anchor{16b}
+@anchor{gnat_rm/implementation_defined_attributes attribute-word-size}@anchor{1a5}
@section Attribute Word_Size
@@ -11348,7 +11529,7 @@ prefix) provides the value @cite{System.Word_Size}. The result is
a static constant.
@node Standard and Implementation Defined Restrictions,Implementation Advice,Implementation Defined Attributes,Top
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions standard-and-implementation-defined-restrictions}@anchor{9}@anchor{gnat_rm/standard_and_implementation_defined_restrictions doc}@anchor{16c}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id1}@anchor{16d}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions standard-and-implementation-defined-restrictions}@anchor{9}@anchor{gnat_rm/standard_and_implementation_defined_restrictions doc}@anchor{1a6}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id1}@anchor{1a7}
@chapter Standard and Implementation Defined Restrictions
@@ -11377,7 +11558,7 @@ language defined or GNAT-specific, are listed in the following.
@end menu
@node Partition-Wide Restrictions,Program Unit Level Restrictions,,Standard and Implementation Defined Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions partition-wide-restrictions}@anchor{16e}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id2}@anchor{16f}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions partition-wide-restrictions}@anchor{1a8}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id2}@anchor{1a9}
@section Partition-Wide Restrictions
@@ -11423,7 +11604,6 @@ then all compilation units in the partition must obey the restriction).
* No_Implicit_Conditionals::
* No_Implicit_Dynamic_Code::
* No_Implicit_Heap_Allocations::
-* No_Implicit_Loops::
* No_Implicit_Protected_Object_Allocations::
* No_Implicit_Task_Allocations::
* No_Initialize_Scalars::
@@ -11467,7 +11647,7 @@ then all compilation units in the partition must obey the restriction).
@end menu
@node Immediate_Reclamation,Max_Asynchronous_Select_Nesting,,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions immediate-reclamation}@anchor{170}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions immediate-reclamation}@anchor{1aa}
@subsection Immediate_Reclamation
@@ -11479,7 +11659,7 @@ deallocation, any storage reserved at run time for an object is
immediately reclaimed when the object no longer exists.
@node Max_Asynchronous_Select_Nesting,Max_Entry_Queue_Length,Immediate_Reclamation,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-asynchronous-select-nesting}@anchor{171}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-asynchronous-select-nesting}@anchor{1ab}
@subsection Max_Asynchronous_Select_Nesting
@@ -11491,7 +11671,7 @@ detected at compile time. Violations of this restriction with values
other than zero cause Storage_Error to be raised.
@node Max_Entry_Queue_Length,Max_Protected_Entries,Max_Asynchronous_Select_Nesting,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-entry-queue-length}@anchor{172}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-entry-queue-length}@anchor{1ac}
@subsection Max_Entry_Queue_Length
@@ -11512,7 +11692,7 @@ compatibility purposes (and a warning will be generated for its use if
warnings on obsolescent features are activated).
@node Max_Protected_Entries,Max_Select_Alternatives,Max_Entry_Queue_Length,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-protected-entries}@anchor{173}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-protected-entries}@anchor{1ad}
@subsection Max_Protected_Entries
@@ -11523,7 +11703,7 @@ bounds of every entry family of a protected unit shall be static, or shall be
defined by a discriminant of a subtype whose corresponding bound is static.
@node Max_Select_Alternatives,Max_Storage_At_Blocking,Max_Protected_Entries,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-select-alternatives}@anchor{174}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-select-alternatives}@anchor{1ae}
@subsection Max_Select_Alternatives
@@ -11532,7 +11712,7 @@ defined by a discriminant of a subtype whose corresponding bound is static.
[RM D.7] Specifies the maximum number of alternatives in a selective accept.
@node Max_Storage_At_Blocking,Max_Task_Entries,Max_Select_Alternatives,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-storage-at-blocking}@anchor{175}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-storage-at-blocking}@anchor{1af}
@subsection Max_Storage_At_Blocking
@@ -11543,7 +11723,7 @@ Storage_Size that can be retained by a blocked task. A violation of this
restriction causes Storage_Error to be raised.
@node Max_Task_Entries,Max_Tasks,Max_Storage_At_Blocking,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-task-entries}@anchor{176}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-task-entries}@anchor{1b0}
@subsection Max_Task_Entries
@@ -11556,7 +11736,7 @@ defined by a discriminant of a subtype whose
corresponding bound is static.
@node Max_Tasks,No_Abort_Statements,Max_Task_Entries,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-tasks}@anchor{177}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions max-tasks}@anchor{1b1}
@subsection Max_Tasks
@@ -11569,7 +11749,7 @@ time. Violations of this restriction with values other than zero cause
Storage_Error to be raised.
@node No_Abort_Statements,No_Access_Parameter_Allocators,Max_Tasks,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-abort-statements}@anchor{178}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-abort-statements}@anchor{1b2}
@subsection No_Abort_Statements
@@ -11579,7 +11759,7 @@ Storage_Error to be raised.
no calls to Task_Identification.Abort_Task.
@node No_Access_Parameter_Allocators,No_Access_Subprograms,No_Abort_Statements,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-parameter-allocators}@anchor{179}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-parameter-allocators}@anchor{1b3}
@subsection No_Access_Parameter_Allocators
@@ -11590,7 +11770,7 @@ occurrences of an allocator as the actual parameter to an access
parameter.
@node No_Access_Subprograms,No_Allocators,No_Access_Parameter_Allocators,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-subprograms}@anchor{17a}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-access-subprograms}@anchor{1b4}
@subsection No_Access_Subprograms
@@ -11600,7 +11780,7 @@ parameter.
declarations of access-to-subprogram types.
@node No_Allocators,No_Anonymous_Allocators,No_Access_Subprograms,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-allocators}@anchor{17b}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-allocators}@anchor{1b5}
@subsection No_Allocators
@@ -11610,7 +11790,7 @@ declarations of access-to-subprogram types.
occurrences of an allocator.
@node No_Anonymous_Allocators,No_Asynchronous_Control,No_Allocators,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-anonymous-allocators}@anchor{17c}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-anonymous-allocators}@anchor{1b6}
@subsection No_Anonymous_Allocators
@@ -11620,7 +11800,7 @@ occurrences of an allocator.
occurrences of an allocator of anonymous access type.
@node No_Asynchronous_Control,No_Calendar,No_Anonymous_Allocators,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-asynchronous-control}@anchor{17d}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-asynchronous-control}@anchor{1b7}
@subsection No_Asynchronous_Control
@@ -11630,7 +11810,7 @@ occurrences of an allocator of anonymous access type.
dependences on the predefined package Asynchronous_Task_Control.
@node No_Calendar,No_Coextensions,No_Asynchronous_Control,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-calendar}@anchor{17e}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-calendar}@anchor{1b8}
@subsection No_Calendar
@@ -11640,7 +11820,7 @@ dependences on the predefined package Asynchronous_Task_Control.
dependences on package Calendar.
@node No_Coextensions,No_Default_Initialization,No_Calendar,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-coextensions}@anchor{17f}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-coextensions}@anchor{1b9}
@subsection No_Coextensions
@@ -11650,7 +11830,7 @@ dependences on package Calendar.
coextensions. See 3.10.2.
@node No_Default_Initialization,No_Delay,No_Coextensions,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-default-initialization}@anchor{180}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-default-initialization}@anchor{1ba}
@subsection No_Default_Initialization
@@ -11667,7 +11847,7 @@ is to prohibit all cases of variables declared without a specific
initializer (including the case of OUT scalar parameters).
@node No_Delay,No_Dependence,No_Default_Initialization,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-delay}@anchor{181}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-delay}@anchor{1bb}
@subsection No_Delay
@@ -11677,7 +11857,7 @@ initializer (including the case of OUT scalar parameters).
delay statements and no semantic dependences on package Calendar.
@node No_Dependence,No_Direct_Boolean_Operators,No_Delay,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dependence}@anchor{182}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dependence}@anchor{1bc}
@subsection No_Dependence
@@ -11687,7 +11867,7 @@ delay statements and no semantic dependences on package Calendar.
dependences on a library unit.
@node No_Direct_Boolean_Operators,No_Dispatch,No_Dependence,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-direct-boolean-operators}@anchor{183}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-direct-boolean-operators}@anchor{1bd}
@subsection No_Direct_Boolean_Operators
@@ -11700,7 +11880,7 @@ protocol requires the use of short-circuit (and then, or else) forms for all
composite boolean operations.
@node No_Dispatch,No_Dispatching_Calls,No_Direct_Boolean_Operators,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatch}@anchor{184}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatch}@anchor{1be}
@subsection No_Dispatch
@@ -11710,7 +11890,7 @@ composite boolean operations.
occurrences of @cite{T'Class}, for any (tagged) subtype @cite{T}.
@node No_Dispatching_Calls,No_Dynamic_Attachment,No_Dispatch,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatching-calls}@anchor{185}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dispatching-calls}@anchor{1bf}
@subsection No_Dispatching_Calls
@@ -11771,7 +11951,7 @@ end Example;
@end example
@node No_Dynamic_Attachment,No_Dynamic_Priorities,No_Dispatching_Calls,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-attachment}@anchor{186}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-attachment}@anchor{1c0}
@subsection No_Dynamic_Attachment
@@ -11790,7 +11970,7 @@ compatibility purposes (and a warning will be generated for its use if
warnings on obsolescent features are activated).
@node No_Dynamic_Priorities,No_Entry_Calls_In_Elaboration_Code,No_Dynamic_Attachment,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-priorities}@anchor{187}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-priorities}@anchor{1c1}
@subsection No_Dynamic_Priorities
@@ -11799,7 +11979,7 @@ warnings on obsolescent features are activated).
[RM D.7] There are no semantic dependencies on the package Dynamic_Priorities.
@node No_Entry_Calls_In_Elaboration_Code,No_Enumeration_Maps,No_Dynamic_Priorities,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-calls-in-elaboration-code}@anchor{188}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-calls-in-elaboration-code}@anchor{1c2}
@subsection No_Entry_Calls_In_Elaboration_Code
@@ -11811,7 +11991,7 @@ restriction, the compiler can assume that no code past an accept statement
in a task can be executed at elaboration time.
@node No_Enumeration_Maps,No_Exception_Handlers,No_Entry_Calls_In_Elaboration_Code,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-enumeration-maps}@anchor{189}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-enumeration-maps}@anchor{1c3}
@subsection No_Enumeration_Maps
@@ -11822,7 +12002,7 @@ enumeration maps are used (that is Image and Value attributes applied
to enumeration types).
@node No_Exception_Handlers,No_Exception_Propagation,No_Enumeration_Maps,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-handlers}@anchor{18a}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-handlers}@anchor{1c4}
@subsection No_Exception_Handlers
@@ -11847,7 +12027,7 @@ statement generated by the compiler). The Line parameter when nonzero
represents the line number in the source program where the raise occurs.
@node No_Exception_Propagation,No_Exception_Registration,No_Exception_Handlers,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-propagation}@anchor{18b}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-propagation}@anchor{1c5}
@subsection No_Exception_Propagation
@@ -11864,7 +12044,7 @@ the package GNAT.Current_Exception is not permitted, and reraise
statements (raise with no operand) are not permitted.
@node No_Exception_Registration,No_Exceptions,No_Exception_Propagation,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-registration}@anchor{18c}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exception-registration}@anchor{1c6}
@subsection No_Exception_Registration
@@ -11878,7 +12058,7 @@ code is simplified by omitting the otherwise-required global registration
of exceptions when they are declared.
@node No_Exceptions,No_Finalization,No_Exception_Registration,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exceptions}@anchor{18d}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-exceptions}@anchor{1c7}
@subsection No_Exceptions
@@ -11888,7 +12068,7 @@ of exceptions when they are declared.
raise statements and no exception handlers.
@node No_Finalization,No_Fixed_Point,No_Exceptions,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-finalization}@anchor{18e}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-finalization}@anchor{1c8}
@subsection No_Finalization
@@ -11929,7 +12109,7 @@ object or a nested component, either declared on the stack or on the heap. The
deallocation of a controlled object no longer finalizes its contents.
@node No_Fixed_Point,No_Floating_Point,No_Finalization,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-fixed-point}@anchor{18f}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-fixed-point}@anchor{1c9}
@subsection No_Fixed_Point
@@ -11939,7 +12119,7 @@ deallocation of a controlled object no longer finalizes its contents.
occurrences of fixed point types and operations.
@node No_Floating_Point,No_Implicit_Conditionals,No_Fixed_Point,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-floating-point}@anchor{190}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-floating-point}@anchor{1ca}
@subsection No_Floating_Point
@@ -11949,7 +12129,7 @@ occurrences of fixed point types and operations.
occurrences of floating point types and operations.
@node No_Implicit_Conditionals,No_Implicit_Dynamic_Code,No_Floating_Point,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-conditionals}@anchor{191}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-conditionals}@anchor{1cb}
@subsection No_Implicit_Conditionals
@@ -11965,7 +12145,7 @@ normal manner. Constructs generating implicit conditionals include comparisons
of composite objects and the Max/Min attributes.
@node No_Implicit_Dynamic_Code,No_Implicit_Heap_Allocations,No_Implicit_Conditionals,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-dynamic-code}@anchor{192}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-dynamic-code}@anchor{1cc}
@subsection No_Implicit_Dynamic_Code
@@ -11994,8 +12174,8 @@ but only if pragma Favor_Top_Level applies, or the access type has a
foreign-language convention; primitive operations of nested tagged
types.
-@node No_Implicit_Heap_Allocations,No_Implicit_Loops,No_Implicit_Dynamic_Code,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-heap-allocations}@anchor{193}
+@node No_Implicit_Heap_Allocations,No_Implicit_Protected_Object_Allocations,No_Implicit_Dynamic_Code,Partition-Wide Restrictions
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-heap-allocations}@anchor{1cd}
@subsection No_Implicit_Heap_Allocations
@@ -12003,25 +12183,8 @@ types.
[RM D.7] No constructs are allowed to cause implicit heap allocation.
-@node No_Implicit_Loops,No_Implicit_Protected_Object_Allocations,No_Implicit_Heap_Allocations,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-loops}@anchor{194}
-@subsection No_Implicit_Loops
-
-
-@geindex No_Implicit_Loops
-
-[GNAT] This restriction ensures that the generated code does not contain any
-implicit @cite{for} loops, either by modifying
-the generated code where possible,
-or by rejecting any construct that would otherwise generate an implicit
-@cite{for} loop. If this restriction is active, it is possible to build
-large array aggregates with all static components without generating an
-intermediate temporary, and without generating a loop to initialize individual
-components. Otherwise, a loop is created for arrays larger than about 5000
-scalar components.
-
-@node No_Implicit_Protected_Object_Allocations,No_Implicit_Task_Allocations,No_Implicit_Loops,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-protected-object-allocations}@anchor{195}
+@node No_Implicit_Protected_Object_Allocations,No_Implicit_Task_Allocations,No_Implicit_Heap_Allocations,Partition-Wide Restrictions
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-protected-object-allocations}@anchor{1ce}
@subsection No_Implicit_Protected_Object_Allocations
@@ -12031,7 +12194,7 @@ scalar components.
protected object.
@node No_Implicit_Task_Allocations,No_Initialize_Scalars,No_Implicit_Protected_Object_Allocations,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-task-allocations}@anchor{196}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-task-allocations}@anchor{1cf}
@subsection No_Implicit_Task_Allocations
@@ -12040,7 +12203,7 @@ protected object.
[GNAT] No constructs are allowed to cause implicit heap allocation of a task.
@node No_Initialize_Scalars,No_IO,No_Implicit_Task_Allocations,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-initialize-scalars}@anchor{197}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-initialize-scalars}@anchor{1d0}
@subsection No_Initialize_Scalars
@@ -12052,7 +12215,7 @@ code, and in particular eliminates dummy null initialization routines that
are otherwise generated for some record and array types.
@node No_IO,No_Local_Allocators,No_Initialize_Scalars,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-io}@anchor{198}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-io}@anchor{1d1}
@subsection No_IO
@@ -12063,7 +12226,7 @@ dependences on any of the library units Sequential_IO, Direct_IO,
Text_IO, Wide_Text_IO, Wide_Wide_Text_IO, or Stream_IO.
@node No_Local_Allocators,No_Local_Protected_Objects,No_IO,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-allocators}@anchor{199}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-allocators}@anchor{1d2}
@subsection No_Local_Allocators
@@ -12074,7 +12237,7 @@ occurrences of an allocator in subprograms, generic subprograms, tasks,
and entry bodies.
@node No_Local_Protected_Objects,No_Local_Timing_Events,No_Local_Allocators,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-protected-objects}@anchor{19a}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-protected-objects}@anchor{1d3}
@subsection No_Local_Protected_Objects
@@ -12084,7 +12247,7 @@ and entry bodies.
only declared at the library level.
@node No_Local_Timing_Events,No_Long_Long_Integers,No_Local_Protected_Objects,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-timing-events}@anchor{19b}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-local-timing-events}@anchor{1d4}
@subsection No_Local_Timing_Events
@@ -12094,7 +12257,7 @@ only declared at the library level.
declared at the library level.
@node No_Long_Long_Integers,No_Multiple_Elaboration,No_Local_Timing_Events,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-long-long-integers}@anchor{19c}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-long-long-integers}@anchor{1d5}
@subsection No_Long_Long_Integers
@@ -12106,28 +12269,24 @@ implicit base type is Long_Long_Integer, and modular types whose size exceeds
Long_Integer'Size.
@node No_Multiple_Elaboration,No_Nested_Finalization,No_Long_Long_Integers,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-multiple-elaboration}@anchor{19d}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-multiple-elaboration}@anchor{1d6}
@subsection No_Multiple_Elaboration
@geindex No_Multiple_Elaboration
-[GNAT] Normally each package contains a 16-bit counter used to check for access
-before elaboration, and to control multiple elaboration attempts.
-This counter is eliminated for units compiled with the static model
-of elaboration if restriction @cite{No_Elaboration_Code}
-is active but because of
-the need to check for multiple elaboration in the general case, these
-counters cannot be eliminated if elaboration code may be present. The
-restriction @cite{No_Multiple_Elaboration}
-allows suppression of these counters
-in static elaboration units even if they do have elaboration code. If this
-restriction is used, then the situations in which multiple elaboration is
-possible, including non-Ada main programs, and Stand Alone libraries, are not
-permitted, and will be diagnosed by the binder.
+[GNAT] When this restriction is active, we are not requesting control-flow
+preservation with -fpreserve-control-flow, and the static elaboration model is
+used, the compiler is allowed to suppress the elaboration counter normally
+associated with the unit, even if the unit has elaboration code. This counter
+is typically used to check for access before elaboration and to control
+multiple elaboration attempts. If the restriction is used, then the
+situations in which multiple elaboration is possible, including non-Ada main
+programs and Stand Alone libraries, are not permitted and will be diagnosed
+by the binder.
@node No_Nested_Finalization,No_Protected_Type_Allocators,No_Multiple_Elaboration,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-nested-finalization}@anchor{19e}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-nested-finalization}@anchor{1d7}
@subsection No_Nested_Finalization
@@ -12136,7 +12295,7 @@ permitted, and will be diagnosed by the binder.
[RM D.7] All objects requiring finalization are declared at the library level.
@node No_Protected_Type_Allocators,No_Protected_Types,No_Nested_Finalization,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-protected-type-allocators}@anchor{19f}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-protected-type-allocators}@anchor{1d8}
@subsection No_Protected_Type_Allocators
@@ -12146,7 +12305,7 @@ permitted, and will be diagnosed by the binder.
expressions that attempt to allocate protected objects.
@node No_Protected_Types,No_Recursion,No_Protected_Type_Allocators,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-protected-types}@anchor{1a0}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-protected-types}@anchor{1d9}
@subsection No_Protected_Types
@@ -12156,7 +12315,7 @@ expressions that attempt to allocate protected objects.
declarations of protected types or protected objects.
@node No_Recursion,No_Reentrancy,No_Protected_Types,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-recursion}@anchor{1a1}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-recursion}@anchor{1da}
@subsection No_Recursion
@@ -12166,7 +12325,7 @@ declarations of protected types or protected objects.
part of its execution.
@node No_Reentrancy,No_Relative_Delay,No_Recursion,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-reentrancy}@anchor{1a2}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-reentrancy}@anchor{1db}
@subsection No_Reentrancy
@@ -12176,7 +12335,7 @@ part of its execution.
two tasks at the same time.
@node No_Relative_Delay,No_Requeue_Statements,No_Reentrancy,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-relative-delay}@anchor{1a3}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-relative-delay}@anchor{1dc}
@subsection No_Relative_Delay
@@ -12187,7 +12346,7 @@ relative statements and prevents expressions such as @cite{delay 1.23;} from
appearing in source code.
@node No_Requeue_Statements,No_Secondary_Stack,No_Relative_Delay,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-requeue-statements}@anchor{1a4}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-requeue-statements}@anchor{1dd}
@subsection No_Requeue_Statements
@@ -12205,7 +12364,7 @@ compatibility purposes (and a warning will be generated for its use if
warnings on oNobsolescent features are activated).
@node No_Secondary_Stack,No_Select_Statements,No_Requeue_Statements,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-secondary-stack}@anchor{1a5}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-secondary-stack}@anchor{1de}
@subsection No_Secondary_Stack
@@ -12214,10 +12373,11 @@ warnings on oNobsolescent features are activated).
[GNAT] This restriction ensures at compile time that the generated code
does not contain any reference to the secondary stack. The secondary
stack is used to implement functions returning unconstrained objects
-(arrays or records) on some targets.
+(arrays or records) on some targets. Suppresses the allocation of
+secondary stacks for tasks (excluding the environment task) at run time.
@node No_Select_Statements,No_Specific_Termination_Handlers,No_Secondary_Stack,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-select-statements}@anchor{1a6}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-select-statements}@anchor{1df}
@subsection No_Select_Statements
@@ -12227,7 +12387,7 @@ stack is used to implement functions returning unconstrained objects
kind are permitted, that is the keyword @cite{select} may not appear.
@node No_Specific_Termination_Handlers,No_Specification_of_Aspect,No_Select_Statements,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-specific-termination-handlers}@anchor{1a7}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-specific-termination-handlers}@anchor{1e0}
@subsection No_Specific_Termination_Handlers
@@ -12237,7 +12397,7 @@ kind are permitted, that is the keyword @cite{select} may not appear.
or to Ada.Task_Termination.Specific_Handler.
@node No_Specification_of_Aspect,No_Standard_Allocators_After_Elaboration,No_Specific_Termination_Handlers,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-specification-of-aspect}@anchor{1a8}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-specification-of-aspect}@anchor{1e1}
@subsection No_Specification_of_Aspect
@@ -12248,7 +12408,7 @@ specification, attribute definition clause, or pragma is given for a
given aspect.
@node No_Standard_Allocators_After_Elaboration,No_Standard_Storage_Pools,No_Specification_of_Aspect,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-standard-allocators-after-elaboration}@anchor{1a9}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-standard-allocators-after-elaboration}@anchor{1e2}
@subsection No_Standard_Allocators_After_Elaboration
@@ -12260,7 +12420,7 @@ library items of the partition has completed. Otherwise, Storage_Error
is raised.
@node No_Standard_Storage_Pools,No_Stream_Optimizations,No_Standard_Allocators_After_Elaboration,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-standard-storage-pools}@anchor{1aa}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-standard-storage-pools}@anchor{1e3}
@subsection No_Standard_Storage_Pools
@@ -12272,7 +12432,7 @@ have an explicit Storage_Pool attribute defined specifying a
user-defined storage pool.
@node No_Stream_Optimizations,No_Streams,No_Standard_Storage_Pools,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-stream-optimizations}@anchor{1ab}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-stream-optimizations}@anchor{1e4}
@subsection No_Stream_Optimizations
@@ -12285,7 +12445,7 @@ due to their supperior performance. When this restriction is in effect, the
compiler performs all IO operations on a per-character basis.
@node No_Streams,No_Task_Allocators,No_Stream_Optimizations,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-streams}@anchor{1ac}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-streams}@anchor{1e5}
@subsection No_Streams
@@ -12306,7 +12466,7 @@ unit declaring a tagged type should be compiled with the restriction,
though this is not required.
@node No_Task_Allocators,No_Task_At_Interrupt_Priority,No_Streams,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-allocators}@anchor{1ad}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-allocators}@anchor{1e6}
@subsection No_Task_Allocators
@@ -12316,7 +12476,7 @@ though this is not required.
or types containing task subcomponents.
@node No_Task_At_Interrupt_Priority,No_Task_Attributes_Package,No_Task_Allocators,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-at-interrupt-priority}@anchor{1ae}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-at-interrupt-priority}@anchor{1e7}
@subsection No_Task_At_Interrupt_Priority
@@ -12328,7 +12488,7 @@ a consequence, the tasks are always created with a priority below
that an interrupt priority.
@node No_Task_Attributes_Package,No_Task_Hierarchy,No_Task_At_Interrupt_Priority,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-attributes-package}@anchor{1af}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-attributes-package}@anchor{1e8}
@subsection No_Task_Attributes_Package
@@ -12345,7 +12505,7 @@ compatibility purposes (and a warning will be generated for its use if
warnings on obsolescent features are activated).
@node No_Task_Hierarchy,No_Task_Termination,No_Task_Attributes_Package,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-hierarchy}@anchor{1b0}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-hierarchy}@anchor{1e9}
@subsection No_Task_Hierarchy
@@ -12355,7 +12515,7 @@ warnings on obsolescent features are activated).
directly on the environment task of the partition.
@node No_Task_Termination,No_Tasking,No_Task_Hierarchy,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-termination}@anchor{1b1}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-task-termination}@anchor{1ea}
@subsection No_Task_Termination
@@ -12364,7 +12524,7 @@ directly on the environment task of the partition.
[RM D.7] Tasks that terminate are erroneous.
@node No_Tasking,No_Terminate_Alternatives,No_Task_Termination,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-tasking}@anchor{1b2}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-tasking}@anchor{1eb}
@subsection No_Tasking
@@ -12377,7 +12537,7 @@ and cause an error message to be output either by the compiler or
binder.
@node No_Terminate_Alternatives,No_Unchecked_Access,No_Tasking,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-terminate-alternatives}@anchor{1b3}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-terminate-alternatives}@anchor{1ec}
@subsection No_Terminate_Alternatives
@@ -12386,7 +12546,7 @@ binder.
[RM D.7] There are no selective accepts with terminate alternatives.
@node No_Unchecked_Access,No_Unchecked_Conversion,No_Terminate_Alternatives,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-access}@anchor{1b4}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-access}@anchor{1ed}
@subsection No_Unchecked_Access
@@ -12396,7 +12556,7 @@ binder.
occurrences of the Unchecked_Access attribute.
@node No_Unchecked_Conversion,No_Unchecked_Deallocation,No_Unchecked_Access,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-conversion}@anchor{1b5}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-conversion}@anchor{1ee}
@subsection No_Unchecked_Conversion
@@ -12406,7 +12566,7 @@ occurrences of the Unchecked_Access attribute.
dependences on the predefined generic function Unchecked_Conversion.
@node No_Unchecked_Deallocation,No_Use_Of_Entity,No_Unchecked_Conversion,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-deallocation}@anchor{1b6}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-unchecked-deallocation}@anchor{1ef}
@subsection No_Unchecked_Deallocation
@@ -12416,7 +12576,7 @@ dependences on the predefined generic function Unchecked_Conversion.
dependences on the predefined generic procedure Unchecked_Deallocation.
@node No_Use_Of_Entity,Pure_Barriers,No_Unchecked_Deallocation,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-use-of-entity}@anchor{1b7}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-use-of-entity}@anchor{1f0}
@subsection No_Use_Of_Entity
@@ -12436,7 +12596,7 @@ No_Use_Of_Entity => Ada.Text_IO.Put_Line
@end example
@node Pure_Barriers,Simple_Barriers,No_Use_Of_Entity,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions pure-barriers}@anchor{1b8}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions pure-barriers}@anchor{1f1}
@subsection Pure_Barriers
@@ -12485,7 +12645,7 @@ but still ensures absence of side effects, exceptions, and recursion
during the evaluation of the barriers.
@node Simple_Barriers,Static_Priorities,Pure_Barriers,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions simple-barriers}@anchor{1b9}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions simple-barriers}@anchor{1f2}
@subsection Simple_Barriers
@@ -12504,7 +12664,7 @@ compatibility purposes (and a warning will be generated for its use if
warnings on obsolescent features are activated).
@node Static_Priorities,Static_Storage_Size,Simple_Barriers,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-priorities}@anchor{1ba}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-priorities}@anchor{1f3}
@subsection Static_Priorities
@@ -12515,7 +12675,7 @@ are static, and that there are no dependences on the package
@cite{Ada.Dynamic_Priorities}.
@node Static_Storage_Size,,Static_Priorities,Partition-Wide Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-storage-size}@anchor{1bb}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions static-storage-size}@anchor{1f4}
@subsection Static_Storage_Size
@@ -12525,7 +12685,7 @@ are static, and that there are no dependences on the package
in a Storage_Size pragma or attribute definition clause is static.
@node Program Unit Level Restrictions,,Partition-Wide Restrictions,Standard and Implementation Defined Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions program-unit-level-restrictions}@anchor{1bc}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id3}@anchor{1bd}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions program-unit-level-restrictions}@anchor{1f5}@anchor{gnat_rm/standard_and_implementation_defined_restrictions id3}@anchor{1f6}
@section Program Unit Level Restrictions
@@ -12546,6 +12706,7 @@ other compilation units in the partition.
* No_Implementation_Restrictions::
* No_Implementation_Units::
* No_Implicit_Aliasing::
+* No_Implicit_Loops::
* No_Obsolescent_Features::
* No_Wide_Characters::
* SPARK_05::
@@ -12553,7 +12714,7 @@ other compilation units in the partition.
@end menu
@node No_Elaboration_Code,No_Dynamic_Sized_Objects,,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-elaboration-code}@anchor{1be}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-elaboration-code}@anchor{1f7}
@subsection No_Elaboration_Code
@@ -12602,8 +12763,14 @@ Note that this the implementation of this restriction requires full
code generation. If it is used in conjunction with "semantics only"
checking, then some cases of violations may be missed.
+When this restriction is active, we are not requesting control-flow
+preservation with -fpreserve-control-flow, and the static elaboration model is
+used, the compiler is allowed to suppress the elaboration counter normally
+associated with the unit. This counter is typically used to check for access
+before elaboration and to control multiple elaboration attempts.
+
@node No_Dynamic_Sized_Objects,No_Entry_Queue,No_Elaboration_Code,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-sized-objects}@anchor{1bf}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-dynamic-sized-objects}@anchor{1f8}
@subsection No_Dynamic_Sized_Objects
@@ -12621,7 +12788,7 @@ access discriminants. It is often a good idea to combine this restriction
with No_Secondary_Stack.
@node No_Entry_Queue,No_Implementation_Aspect_Specifications,No_Dynamic_Sized_Objects,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-queue}@anchor{1c0}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-entry-queue}@anchor{1f9}
@subsection No_Entry_Queue
@@ -12634,7 +12801,7 @@ checked at compile time. A program execution is erroneous if an attempt
is made to queue a second task on such an entry.
@node No_Implementation_Aspect_Specifications,No_Implementation_Attributes,No_Entry_Queue,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-aspect-specifications}@anchor{1c1}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-aspect-specifications}@anchor{1fa}
@subsection No_Implementation_Aspect_Specifications
@@ -12645,7 +12812,7 @@ GNAT-defined aspects are present. With this restriction, the only
aspects that can be used are those defined in the Ada Reference Manual.
@node No_Implementation_Attributes,No_Implementation_Identifiers,No_Implementation_Aspect_Specifications,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-attributes}@anchor{1c2}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-attributes}@anchor{1fb}
@subsection No_Implementation_Attributes
@@ -12657,7 +12824,7 @@ attributes that can be used are those defined in the Ada Reference
Manual.
@node No_Implementation_Identifiers,No_Implementation_Pragmas,No_Implementation_Attributes,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-identifiers}@anchor{1c3}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-identifiers}@anchor{1fc}
@subsection No_Implementation_Identifiers
@@ -12668,7 +12835,7 @@ implementation-defined identifiers (marked with pragma Implementation_Defined)
occur within language-defined packages.
@node No_Implementation_Pragmas,No_Implementation_Restrictions,No_Implementation_Identifiers,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-pragmas}@anchor{1c4}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-pragmas}@anchor{1fd}
@subsection No_Implementation_Pragmas
@@ -12679,7 +12846,7 @@ GNAT-defined pragmas are present. With this restriction, the only
pragmas that can be used are those defined in the Ada Reference Manual.
@node No_Implementation_Restrictions,No_Implementation_Units,No_Implementation_Pragmas,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-restrictions}@anchor{1c5}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-restrictions}@anchor{1fe}
@subsection No_Implementation_Restrictions
@@ -12691,7 +12858,7 @@ are present. With this restriction, the only other restriction identifiers
that can be used are those defined in the Ada Reference Manual.
@node No_Implementation_Units,No_Implicit_Aliasing,No_Implementation_Restrictions,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-units}@anchor{1c6}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implementation-units}@anchor{1ff}
@subsection No_Implementation_Units
@@ -12701,8 +12868,8 @@ that can be used are those defined in the Ada Reference Manual.
mention in the context clause of any implementation-defined descendants
of packages Ada, Interfaces, or System.
-@node No_Implicit_Aliasing,No_Obsolescent_Features,No_Implementation_Units,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-aliasing}@anchor{1c7}
+@node No_Implicit_Aliasing,No_Implicit_Loops,No_Implementation_Units,Program Unit Level Restrictions
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-aliasing}@anchor{200}
@subsection No_Implicit_Aliasing
@@ -12716,8 +12883,25 @@ Unrestricted_Access is forbidden is that it would require the prefix
to be aliased, and in such cases, it can always be replaced by
the standard attribute Unchecked_Access which is preferable.
-@node No_Obsolescent_Features,No_Wide_Characters,No_Implicit_Aliasing,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-obsolescent-features}@anchor{1c8}
+@node No_Implicit_Loops,No_Obsolescent_Features,No_Implicit_Aliasing,Program Unit Level Restrictions
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-implicit-loops}@anchor{201}
+@subsection No_Implicit_Loops
+
+
+@geindex No_Implicit_Loops
+
+[GNAT] This restriction ensures that the generated code of the unit marked
+with this restriction does not contain any implicit @cite{for} loops, either by
+modifying the generated code where possible, or by rejecting any construct
+that would otherwise generate an implicit @cite{for} loop. If this restriction is
+active, it is possible to build large array aggregates with all static
+components without generating an intermediate temporary, and without generating
+a loop to initialize individual components. Otherwise, a loop is created for
+arrays larger than about 5000 scalar components. Note that if this restriction
+is set in the spec of a package, it will not apply to its body.
+
+@node No_Obsolescent_Features,No_Wide_Characters,No_Implicit_Loops,Program Unit Level Restrictions
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-obsolescent-features}@anchor{202}
@subsection No_Obsolescent_Features
@@ -12727,7 +12911,7 @@ the standard attribute Unchecked_Access which is preferable.
features are used, as defined in Annex J of the Ada Reference Manual.
@node No_Wide_Characters,SPARK_05,No_Obsolescent_Features,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-wide-characters}@anchor{1c9}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions no-wide-characters}@anchor{203}
@subsection No_Wide_Characters
@@ -12741,7 +12925,7 @@ appear in the program (that is literals representing characters not in
type @cite{Character}).
@node SPARK_05,,No_Wide_Characters,Program Unit Level Restrictions
-@anchor{gnat_rm/standard_and_implementation_defined_restrictions spark-05}@anchor{1ca}
+@anchor{gnat_rm/standard_and_implementation_defined_restrictions spark-05}@anchor{204}
@subsection SPARK_05
@@ -13100,7 +13284,7 @@ violations will be reported for constructs forbidden in SPARK 95,
instead of SPARK 2005.
@node Implementation Advice,Implementation Defined Characteristics,Standard and Implementation Defined Restrictions,Top
-@anchor{gnat_rm/implementation_advice doc}@anchor{1cb}@anchor{gnat_rm/implementation_advice implementation-advice}@anchor{a}@anchor{gnat_rm/implementation_advice id1}@anchor{1cc}
+@anchor{gnat_rm/implementation_advice doc}@anchor{205}@anchor{gnat_rm/implementation_advice implementation-advice}@anchor{a}@anchor{gnat_rm/implementation_advice id1}@anchor{206}
@chapter Implementation Advice
@@ -13197,7 +13381,7 @@ case the text describes what GNAT does and why.
@end menu
@node RM 1 1 3 20 Error Detection,RM 1 1 3 31 Child Units,,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-1-1-3-20-error-detection}@anchor{1cd}
+@anchor{gnat_rm/implementation_advice rm-1-1-3-20-error-detection}@anchor{207}
@section RM 1.1.3(20): Error Detection
@@ -13214,7 +13398,7 @@ or diagnosed at compile time.
@geindex Child Units
@node RM 1 1 3 31 Child Units,RM 1 1 5 12 Bounded Errors,RM 1 1 3 20 Error Detection,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-1-1-3-31-child-units}@anchor{1ce}
+@anchor{gnat_rm/implementation_advice rm-1-1-3-31-child-units}@anchor{208}
@section RM 1.1.3(31): Child Units
@@ -13230,7 +13414,7 @@ Followed.
@geindex Bounded errors
@node RM 1 1 5 12 Bounded Errors,RM 2 8 16 Pragmas,RM 1 1 3 31 Child Units,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-1-1-5-12-bounded-errors}@anchor{1cf}
+@anchor{gnat_rm/implementation_advice rm-1-1-5-12-bounded-errors}@anchor{209}
@section RM 1.1.5(12): Bounded Errors
@@ -13247,7 +13431,7 @@ runtime.
@geindex Pragmas
@node RM 2 8 16 Pragmas,RM 2 8 17-19 Pragmas,RM 1 1 5 12 Bounded Errors,Implementation Advice
-@anchor{gnat_rm/implementation_advice id2}@anchor{1d0}@anchor{gnat_rm/implementation_advice rm-2-8-16-pragmas}@anchor{1d1}
+@anchor{gnat_rm/implementation_advice id2}@anchor{20a}@anchor{gnat_rm/implementation_advice rm-2-8-16-pragmas}@anchor{20b}
@section RM 2.8(16): Pragmas
@@ -13360,7 +13544,7 @@ that this advice not be followed. For details see
@ref{7,,Implementation Defined Pragmas}.
@node RM 2 8 17-19 Pragmas,RM 3 5 2 5 Alternative Character Sets,RM 2 8 16 Pragmas,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-2-8-17-19-pragmas}@anchor{1d2}
+@anchor{gnat_rm/implementation_advice rm-2-8-17-19-pragmas}@anchor{20c}
@section RM 2.8(17-19): Pragmas
@@ -13381,14 +13565,14 @@ replacing @cite{library_items}."
@end itemize
@end quotation
-See @ref{1d1,,RM 2.8(16); Pragmas}.
+See @ref{20b,,RM 2.8(16); Pragmas}.
@geindex Character Sets
@geindex Alternative Character Sets
@node RM 3 5 2 5 Alternative Character Sets,RM 3 5 4 28 Integer Types,RM 2 8 17-19 Pragmas,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-3-5-2-5-alternative-character-sets}@anchor{1d3}
+@anchor{gnat_rm/implementation_advice rm-3-5-2-5-alternative-character-sets}@anchor{20d}
@section RM 3.5.2(5): Alternative Character Sets
@@ -13416,7 +13600,7 @@ there is no such restriction.
@geindex Integer types
@node RM 3 5 4 28 Integer Types,RM 3 5 4 29 Integer Types,RM 3 5 2 5 Alternative Character Sets,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-3-5-4-28-integer-types}@anchor{1d4}
+@anchor{gnat_rm/implementation_advice rm-3-5-4-28-integer-types}@anchor{20e}
@section RM 3.5.4(28): Integer Types
@@ -13435,7 +13619,7 @@ are supported for convenient interface to C, and so that all hardware
types of the machine are easily available.
@node RM 3 5 4 29 Integer Types,RM 3 5 5 8 Enumeration Values,RM 3 5 4 28 Integer Types,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-3-5-4-29-integer-types}@anchor{1d5}
+@anchor{gnat_rm/implementation_advice rm-3-5-4-29-integer-types}@anchor{20f}
@section RM 3.5.4(29): Integer Types
@@ -13451,7 +13635,7 @@ Followed.
@geindex Enumeration values
@node RM 3 5 5 8 Enumeration Values,RM 3 5 7 17 Float Types,RM 3 5 4 29 Integer Types,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-3-5-5-8-enumeration-values}@anchor{1d6}
+@anchor{gnat_rm/implementation_advice rm-3-5-5-8-enumeration-values}@anchor{210}
@section RM 3.5.5(8): Enumeration Values
@@ -13471,7 +13655,7 @@ Followed.
@geindex Float types
@node RM 3 5 7 17 Float Types,RM 3 6 2 11 Multidimensional Arrays,RM 3 5 5 8 Enumeration Values,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-3-5-7-17-float-types}@anchor{1d7}
+@anchor{gnat_rm/implementation_advice rm-3-5-7-17-float-types}@anchor{211}
@section RM 3.5.7(17): Float Types
@@ -13501,7 +13685,7 @@ since this is a software rather than a hardware format.
@geindex multidimensional
@node RM 3 6 2 11 Multidimensional Arrays,RM 9 6 30-31 Duration'Small,RM 3 5 7 17 Float Types,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-3-6-2-11-multidimensional-arrays}@anchor{1d8}
+@anchor{gnat_rm/implementation_advice rm-3-6-2-11-multidimensional-arrays}@anchor{212}
@section RM 3.6.2(11): Multidimensional Arrays
@@ -13519,7 +13703,7 @@ Followed.
@geindex Duration'Small
@node RM 9 6 30-31 Duration'Small,RM 10 2 1 12 Consistent Representation,RM 3 6 2 11 Multidimensional Arrays,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-9-6-30-31-duration-small}@anchor{1d9}
+@anchor{gnat_rm/implementation_advice rm-9-6-30-31-duration-small}@anchor{213}
@section RM 9.6(30-31): Duration'Small
@@ -13540,7 +13724,7 @@ it need not be the same time base as used for @cite{Calendar.Clock}."
Followed.
@node RM 10 2 1 12 Consistent Representation,RM 11 4 1 19 Exception Information,RM 9 6 30-31 Duration'Small,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-10-2-1-12-consistent-representation}@anchor{1da}
+@anchor{gnat_rm/implementation_advice rm-10-2-1-12-consistent-representation}@anchor{214}
@section RM 10.2.1(12): Consistent Representation
@@ -13562,7 +13746,7 @@ advice without severely impacting efficiency of execution.
@geindex Exception information
@node RM 11 4 1 19 Exception Information,RM 11 5 28 Suppression of Checks,RM 10 2 1 12 Consistent Representation,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-11-4-1-19-exception-information}@anchor{1db}
+@anchor{gnat_rm/implementation_advice rm-11-4-1-19-exception-information}@anchor{215}
@section RM 11.4.1(19): Exception Information
@@ -13593,7 +13777,7 @@ Pragma @cite{Discard_Names}.
@geindex suppression of
@node RM 11 5 28 Suppression of Checks,RM 13 1 21-24 Representation Clauses,RM 11 4 1 19 Exception Information,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-11-5-28-suppression-of-checks}@anchor{1dc}
+@anchor{gnat_rm/implementation_advice rm-11-5-28-suppression-of-checks}@anchor{216}
@section RM 11.5(28): Suppression of Checks
@@ -13608,7 +13792,7 @@ Followed.
@geindex Representation clauses
@node RM 13 1 21-24 Representation Clauses,RM 13 2 6-8 Packed Types,RM 11 5 28 Suppression of Checks,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-1-21-24-representation-clauses}@anchor{1dd}
+@anchor{gnat_rm/implementation_advice rm-13-1-21-24-representation-clauses}@anchor{217}
@section RM 13.1 (21-24): Representation Clauses
@@ -13657,7 +13841,7 @@ Followed.
@geindex Packed types
@node RM 13 2 6-8 Packed Types,RM 13 3 14-19 Address Clauses,RM 13 1 21-24 Representation Clauses,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-2-6-8-packed-types}@anchor{1de}
+@anchor{gnat_rm/implementation_advice rm-13-2-6-8-packed-types}@anchor{218}
@section RM 13.2(6-8): Packed Types
@@ -13696,7 +13880,7 @@ Followed.
@geindex Address clauses
@node RM 13 3 14-19 Address Clauses,RM 13 3 29-35 Alignment Clauses,RM 13 2 6-8 Packed Types,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-3-14-19-address-clauses}@anchor{1df}
+@anchor{gnat_rm/implementation_advice rm-13-3-14-19-address-clauses}@anchor{219}
@section RM 13.3(14-19): Address Clauses
@@ -13749,7 +13933,7 @@ Followed.
@geindex Alignment clauses
@node RM 13 3 29-35 Alignment Clauses,RM 13 3 42-43 Size Clauses,RM 13 3 14-19 Address Clauses,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-3-29-35-alignment-clauses}@anchor{1e0}
+@anchor{gnat_rm/implementation_advice rm-13-3-29-35-alignment-clauses}@anchor{21a}
@section RM 13.3(29-35): Alignment Clauses
@@ -13806,7 +13990,7 @@ Followed.
@geindex Size clauses
@node RM 13 3 42-43 Size Clauses,RM 13 3 50-56 Size Clauses,RM 13 3 29-35 Alignment Clauses,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-3-42-43-size-clauses}@anchor{1e1}
+@anchor{gnat_rm/implementation_advice rm-13-3-42-43-size-clauses}@anchor{21b}
@section RM 13.3(42-43): Size Clauses
@@ -13824,7 +14008,7 @@ object's @cite{Alignment} (if the @cite{Alignment} is nonzero)."
Followed.
@node RM 13 3 50-56 Size Clauses,RM 13 3 71-73 Component Size Clauses,RM 13 3 42-43 Size Clauses,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-3-50-56-size-clauses}@anchor{1e2}
+@anchor{gnat_rm/implementation_advice rm-13-3-50-56-size-clauses}@anchor{21c}
@section RM 13.3(50-56): Size Clauses
@@ -13875,7 +14059,7 @@ Followed.
@geindex Component_Size clauses
@node RM 13 3 71-73 Component Size Clauses,RM 13 4 9-10 Enumeration Representation Clauses,RM 13 3 50-56 Size Clauses,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-3-71-73-component-size-clauses}@anchor{1e3}
+@anchor{gnat_rm/implementation_advice rm-13-3-71-73-component-size-clauses}@anchor{21d}
@section RM 13.3(71-73): Component Size Clauses
@@ -13909,7 +14093,7 @@ Followed.
@geindex enumeration
@node RM 13 4 9-10 Enumeration Representation Clauses,RM 13 5 1 17-22 Record Representation Clauses,RM 13 3 71-73 Component Size Clauses,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-4-9-10-enumeration-representation-clauses}@anchor{1e4}
+@anchor{gnat_rm/implementation_advice rm-13-4-9-10-enumeration-representation-clauses}@anchor{21e}
@section RM 13.4(9-10): Enumeration Representation Clauses
@@ -13931,7 +14115,7 @@ Followed.
@geindex records
@node RM 13 5 1 17-22 Record Representation Clauses,RM 13 5 2 5 Storage Place Attributes,RM 13 4 9-10 Enumeration Representation Clauses,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-5-1-17-22-record-representation-clauses}@anchor{1e5}
+@anchor{gnat_rm/implementation_advice rm-13-5-1-17-22-record-representation-clauses}@anchor{21f}
@section RM 13.5.1(17-22): Record Representation Clauses
@@ -13991,7 +14175,7 @@ and all mentioned features are implemented.
@geindex Storage place attributes
@node RM 13 5 2 5 Storage Place Attributes,RM 13 5 3 7-8 Bit Ordering,RM 13 5 1 17-22 Record Representation Clauses,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-5-2-5-storage-place-attributes}@anchor{1e6}
+@anchor{gnat_rm/implementation_advice rm-13-5-2-5-storage-place-attributes}@anchor{220}
@section RM 13.5.2(5): Storage Place Attributes
@@ -14011,7 +14195,7 @@ Followed. There are no such components in GNAT.
@geindex Bit ordering
@node RM 13 5 3 7-8 Bit Ordering,RM 13 7 37 Address as Private,RM 13 5 2 5 Storage Place Attributes,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-5-3-7-8-bit-ordering}@anchor{1e7}
+@anchor{gnat_rm/implementation_advice rm-13-5-3-7-8-bit-ordering}@anchor{221}
@section RM 13.5.3(7-8): Bit Ordering
@@ -14031,7 +14215,7 @@ Thus non-default bit ordering is not supported.
@geindex as private type
@node RM 13 7 37 Address as Private,RM 13 7 1 16 Address Operations,RM 13 5 3 7-8 Bit Ordering,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-7-37-address-as-private}@anchor{1e8}
+@anchor{gnat_rm/implementation_advice rm-13-7-37-address-as-private}@anchor{222}
@section RM 13.7(37): Address as Private
@@ -14049,7 +14233,7 @@ Followed.
@geindex operations of
@node RM 13 7 1 16 Address Operations,RM 13 9 14-17 Unchecked Conversion,RM 13 7 37 Address as Private,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-7-1-16-address-operations}@anchor{1e9}
+@anchor{gnat_rm/implementation_advice rm-13-7-1-16-address-operations}@anchor{223}
@section RM 13.7.1(16): Address Operations
@@ -14067,7 +14251,7 @@ operation raises @cite{Program_Error}, since all operations make sense.
@geindex Unchecked conversion
@node RM 13 9 14-17 Unchecked Conversion,RM 13 11 23-25 Implicit Heap Usage,RM 13 7 1 16 Address Operations,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-9-14-17-unchecked-conversion}@anchor{1ea}
+@anchor{gnat_rm/implementation_advice rm-13-9-14-17-unchecked-conversion}@anchor{224}
@section RM 13.9(14-17): Unchecked Conversion
@@ -14111,7 +14295,7 @@ Followed.
@geindex implicit
@node RM 13 11 23-25 Implicit Heap Usage,RM 13 11 2 17 Unchecked Deallocation,RM 13 9 14-17 Unchecked Conversion,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-11-23-25-implicit-heap-usage}@anchor{1eb}
+@anchor{gnat_rm/implementation_advice rm-13-11-23-25-implicit-heap-usage}@anchor{225}
@section RM 13.11(23-25): Implicit Heap Usage
@@ -14162,7 +14346,7 @@ Followed.
@geindex Unchecked deallocation
@node RM 13 11 2 17 Unchecked Deallocation,RM 13 13 2 17 Stream Oriented Attributes,RM 13 11 23-25 Implicit Heap Usage,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-11-2-17-unchecked-deallocation}@anchor{1ec}
+@anchor{gnat_rm/implementation_advice rm-13-11-2-17-unchecked-deallocation}@anchor{226}
@section RM 13.11.2(17): Unchecked Deallocation
@@ -14177,7 +14361,7 @@ Followed.
@geindex Stream oriented attributes
@node RM 13 13 2 17 Stream Oriented Attributes,RM A 1 52 Names of Predefined Numeric Types,RM 13 11 2 17 Unchecked Deallocation,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-13-13-2-17-stream-oriented-attributes}@anchor{1ed}
+@anchor{gnat_rm/implementation_advice rm-13-13-2-17-stream-oriented-attributes}@anchor{227}
@section RM 13.13.2(17): Stream Oriented Attributes
@@ -14232,7 +14416,7 @@ the @cite{GNAT and Libraries} section of the @cite{GNAT User's Guide}.
@end itemize
@node RM A 1 52 Names of Predefined Numeric Types,RM A 3 2 49 Ada Characters Handling,RM 13 13 2 17 Stream Oriented Attributes,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-a-1-52-names-of-predefined-numeric-types}@anchor{1ee}
+@anchor{gnat_rm/implementation_advice rm-a-1-52-names-of-predefined-numeric-types}@anchor{228}
@section RM A.1(52): Names of Predefined Numeric Types
@@ -14250,7 +14434,7 @@ Followed.
@geindex Ada.Characters.Handling
@node RM A 3 2 49 Ada Characters Handling,RM A 4 4 106 Bounded-Length String Handling,RM A 1 52 Names of Predefined Numeric Types,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-a-3-2-49-ada-characters-handling}@anchor{1ef}
+@anchor{gnat_rm/implementation_advice rm-a-3-2-49-ada-characters-handling}@anchor{229}
@section RM A.3.2(49): @cite{Ada.Characters.Handling}
@@ -14267,7 +14451,7 @@ Followed. GNAT provides no such localized definitions.
@geindex Bounded-length strings
@node RM A 4 4 106 Bounded-Length String Handling,RM A 5 2 46-47 Random Number Generation,RM A 3 2 49 Ada Characters Handling,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-a-4-4-106-bounded-length-string-handling}@anchor{1f0}
+@anchor{gnat_rm/implementation_advice rm-a-4-4-106-bounded-length-string-handling}@anchor{22a}
@section RM A.4.4(106): Bounded-Length String Handling
@@ -14282,7 +14466,7 @@ Followed. No implicit pointers or dynamic allocation are used.
@geindex Random number generation
@node RM A 5 2 46-47 Random Number Generation,RM A 10 7 23 Get_Immediate,RM A 4 4 106 Bounded-Length String Handling,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-a-5-2-46-47-random-number-generation}@anchor{1f1}
+@anchor{gnat_rm/implementation_advice rm-a-5-2-46-47-random-number-generation}@anchor{22b}
@section RM A.5.2(46-47): Random Number Generation
@@ -14311,7 +14495,7 @@ condition here to hold true.
@geindex Get_Immediate
@node RM A 10 7 23 Get_Immediate,RM B 1 39-41 Pragma Export,RM A 5 2 46-47 Random Number Generation,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-a-10-7-23-get-immediate}@anchor{1f2}
+@anchor{gnat_rm/implementation_advice rm-a-10-7-23-get-immediate}@anchor{22c}
@section RM A.10.7(23): @cite{Get_Immediate}
@@ -14335,7 +14519,7 @@ this functionality.
@geindex Export
@node RM B 1 39-41 Pragma Export,RM B 2 12-13 Package Interfaces,RM A 10 7 23 Get_Immediate,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-b-1-39-41-pragma-export}@anchor{1f3}
+@anchor{gnat_rm/implementation_advice rm-b-1-39-41-pragma-export}@anchor{22d}
@section RM B.1(39-41): Pragma @cite{Export}
@@ -14383,7 +14567,7 @@ Followed.
@geindex Interfaces
@node RM B 2 12-13 Package Interfaces,RM B 3 63-71 Interfacing with C,RM B 1 39-41 Pragma Export,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-b-2-12-13-package-interfaces}@anchor{1f4}
+@anchor{gnat_rm/implementation_advice rm-b-2-12-13-package-interfaces}@anchor{22e}
@section RM B.2(12-13): Package @cite{Interfaces}
@@ -14413,7 +14597,7 @@ Followed. GNAT provides all the packages described in this section.
@geindex interfacing with
@node RM B 3 63-71 Interfacing with C,RM B 4 95-98 Interfacing with COBOL,RM B 2 12-13 Package Interfaces,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-b-3-63-71-interfacing-with-c}@anchor{1f5}
+@anchor{gnat_rm/implementation_advice rm-b-3-63-71-interfacing-with-c}@anchor{22f}
@section RM B.3(63-71): Interfacing with C
@@ -14501,7 +14685,7 @@ Followed.
@geindex interfacing with
@node RM B 4 95-98 Interfacing with COBOL,RM B 5 22-26 Interfacing with Fortran,RM B 3 63-71 Interfacing with C,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-b-4-95-98-interfacing-with-cobol}@anchor{1f6}
+@anchor{gnat_rm/implementation_advice rm-b-4-95-98-interfacing-with-cobol}@anchor{230}
@section RM B.4(95-98): Interfacing with COBOL
@@ -14542,7 +14726,7 @@ Followed.
@geindex interfacing with
@node RM B 5 22-26 Interfacing with Fortran,RM C 1 3-5 Access to Machine Operations,RM B 4 95-98 Interfacing with COBOL,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-b-5-22-26-interfacing-with-fortran}@anchor{1f7}
+@anchor{gnat_rm/implementation_advice rm-b-5-22-26-interfacing-with-fortran}@anchor{231}
@section RM B.5(22-26): Interfacing with Fortran
@@ -14593,7 +14777,7 @@ Followed.
@geindex Machine operations
@node RM C 1 3-5 Access to Machine Operations,RM C 1 10-16 Access to Machine Operations,RM B 5 22-26 Interfacing with Fortran,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-c-1-3-5-access-to-machine-operations}@anchor{1f8}
+@anchor{gnat_rm/implementation_advice rm-c-1-3-5-access-to-machine-operations}@anchor{232}
@section RM C.1(3-5): Access to Machine Operations
@@ -14628,7 +14812,7 @@ object that is specified as exported."
Followed.
@node RM C 1 10-16 Access to Machine Operations,RM C 3 28 Interrupt Support,RM C 1 3-5 Access to Machine Operations,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-c-1-10-16-access-to-machine-operations}@anchor{1f9}
+@anchor{gnat_rm/implementation_advice rm-c-1-10-16-access-to-machine-operations}@anchor{233}
@section RM C.1(10-16): Access to Machine Operations
@@ -14689,7 +14873,7 @@ Followed on any target supporting such operations.
@geindex Interrupt support
@node RM C 3 28 Interrupt Support,RM C 3 1 20-21 Protected Procedure Handlers,RM C 1 10-16 Access to Machine Operations,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-c-3-28-interrupt-support}@anchor{1fa}
+@anchor{gnat_rm/implementation_advice rm-c-3-28-interrupt-support}@anchor{234}
@section RM C.3(28): Interrupt Support
@@ -14707,7 +14891,7 @@ of interrupt blocking.
@geindex Protected procedure handlers
@node RM C 3 1 20-21 Protected Procedure Handlers,RM C 3 2 25 Package Interrupts,RM C 3 28 Interrupt Support,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-c-3-1-20-21-protected-procedure-handlers}@anchor{1fb}
+@anchor{gnat_rm/implementation_advice rm-c-3-1-20-21-protected-procedure-handlers}@anchor{235}
@section RM C.3.1(20-21): Protected Procedure Handlers
@@ -14733,7 +14917,7 @@ Followed. Compile time warnings are given when possible.
@geindex Interrupts
@node RM C 3 2 25 Package Interrupts,RM C 4 14 Pre-elaboration Requirements,RM C 3 1 20-21 Protected Procedure Handlers,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-c-3-2-25-package-interrupts}@anchor{1fc}
+@anchor{gnat_rm/implementation_advice rm-c-3-2-25-package-interrupts}@anchor{236}
@section RM C.3.2(25): Package @cite{Interrupts}
@@ -14751,7 +14935,7 @@ Followed.
@geindex Pre-elaboration requirements
@node RM C 4 14 Pre-elaboration Requirements,RM C 5 8 Pragma Discard_Names,RM C 3 2 25 Package Interrupts,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-c-4-14-pre-elaboration-requirements}@anchor{1fd}
+@anchor{gnat_rm/implementation_advice rm-c-4-14-pre-elaboration-requirements}@anchor{237}
@section RM C.4(14): Pre-elaboration Requirements
@@ -14767,7 +14951,7 @@ Followed. Executable code is generated in some cases, e.g., loops
to initialize large arrays.
@node RM C 5 8 Pragma Discard_Names,RM C 7 2 30 The Package Task_Attributes,RM C 4 14 Pre-elaboration Requirements,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-c-5-8-pragma-discard-names}@anchor{1fe}
+@anchor{gnat_rm/implementation_advice rm-c-5-8-pragma-discard-names}@anchor{238}
@section RM C.5(8): Pragma @cite{Discard_Names}
@@ -14785,7 +14969,7 @@ Followed.
@geindex Task_Attributes
@node RM C 7 2 30 The Package Task_Attributes,RM D 3 17 Locking Policies,RM C 5 8 Pragma Discard_Names,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-c-7-2-30-the-package-task-attributes}@anchor{1ff}
+@anchor{gnat_rm/implementation_advice rm-c-7-2-30-the-package-task-attributes}@anchor{239}
@section RM C.7.2(30): The Package Task_Attributes
@@ -14806,7 +14990,7 @@ Not followed. This implementation is not targeted to such a domain.
@geindex Locking Policies
@node RM D 3 17 Locking Policies,RM D 4 16 Entry Queuing Policies,RM C 7 2 30 The Package Task_Attributes,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-d-3-17-locking-policies}@anchor{200}
+@anchor{gnat_rm/implementation_advice rm-d-3-17-locking-policies}@anchor{23a}
@section RM D.3(17): Locking Policies
@@ -14823,7 +15007,7 @@ whose names (@cite{Inheritance_Locking} and
@geindex Entry queuing policies
@node RM D 4 16 Entry Queuing Policies,RM D 6 9-10 Preemptive Abort,RM D 3 17 Locking Policies,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-d-4-16-entry-queuing-policies}@anchor{201}
+@anchor{gnat_rm/implementation_advice rm-d-4-16-entry-queuing-policies}@anchor{23b}
@section RM D.4(16): Entry Queuing Policies
@@ -14838,7 +15022,7 @@ Followed. No such implementation-defined queuing policies exist.
@geindex Preemptive abort
@node RM D 6 9-10 Preemptive Abort,RM D 7 21 Tasking Restrictions,RM D 4 16 Entry Queuing Policies,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-d-6-9-10-preemptive-abort}@anchor{202}
+@anchor{gnat_rm/implementation_advice rm-d-6-9-10-preemptive-abort}@anchor{23c}
@section RM D.6(9-10): Preemptive Abort
@@ -14864,7 +15048,7 @@ Followed.
@geindex Tasking restrictions
@node RM D 7 21 Tasking Restrictions,RM D 8 47-49 Monotonic Time,RM D 6 9-10 Preemptive Abort,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-d-7-21-tasking-restrictions}@anchor{203}
+@anchor{gnat_rm/implementation_advice rm-d-7-21-tasking-restrictions}@anchor{23d}
@section RM D.7(21): Tasking Restrictions
@@ -14883,7 +15067,7 @@ pragma @cite{Profile (Restricted)} for more details.
@geindex monotonic
@node RM D 8 47-49 Monotonic Time,RM E 5 28-29 Partition Communication Subsystem,RM D 7 21 Tasking Restrictions,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-d-8-47-49-monotonic-time}@anchor{204}
+@anchor{gnat_rm/implementation_advice rm-d-8-47-49-monotonic-time}@anchor{23e}
@section RM D.8(47-49): Monotonic Time
@@ -14918,7 +15102,7 @@ Followed.
@geindex PCS
@node RM E 5 28-29 Partition Communication Subsystem,RM F 7 COBOL Support,RM D 8 47-49 Monotonic Time,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-e-5-28-29-partition-communication-subsystem}@anchor{205}
+@anchor{gnat_rm/implementation_advice rm-e-5-28-29-partition-communication-subsystem}@anchor{23f}
@section RM E.5(28-29): Partition Communication Subsystem
@@ -14946,7 +15130,7 @@ GNAT.
@geindex COBOL support
@node RM F 7 COBOL Support,RM F 1 2 Decimal Radix Support,RM E 5 28-29 Partition Communication Subsystem,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-f-7-cobol-support}@anchor{206}
+@anchor{gnat_rm/implementation_advice rm-f-7-cobol-support}@anchor{240}
@section RM F(7): COBOL Support
@@ -14966,7 +15150,7 @@ Followed.
@geindex Decimal radix support
@node RM F 1 2 Decimal Radix Support,RM G Numerics,RM F 7 COBOL Support,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-f-1-2-decimal-radix-support}@anchor{207}
+@anchor{gnat_rm/implementation_advice rm-f-1-2-decimal-radix-support}@anchor{241}
@section RM F.1(2): Decimal Radix Support
@@ -14982,7 +15166,7 @@ representations.
@geindex Numerics
@node RM G Numerics,RM G 1 1 56-58 Complex Types,RM F 1 2 Decimal Radix Support,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-g-numerics}@anchor{208}
+@anchor{gnat_rm/implementation_advice rm-g-numerics}@anchor{242}
@section RM G: Numerics
@@ -15002,7 +15186,7 @@ Followed.
@geindex Complex types
@node RM G 1 1 56-58 Complex Types,RM G 1 2 49 Complex Elementary Functions,RM G Numerics,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-g-1-1-56-58-complex-types}@anchor{209}
+@anchor{gnat_rm/implementation_advice rm-g-1-1-56-58-complex-types}@anchor{243}
@section RM G.1.1(56-58): Complex Types
@@ -15064,7 +15248,7 @@ Followed.
@geindex Complex elementary functions
@node RM G 1 2 49 Complex Elementary Functions,RM G 2 4 19 Accuracy Requirements,RM G 1 1 56-58 Complex Types,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-g-1-2-49-complex-elementary-functions}@anchor{20a}
+@anchor{gnat_rm/implementation_advice rm-g-1-2-49-complex-elementary-functions}@anchor{244}
@section RM G.1.2(49): Complex Elementary Functions
@@ -15086,7 +15270,7 @@ Followed.
@geindex Accuracy requirements
@node RM G 2 4 19 Accuracy Requirements,RM G 2 6 15 Complex Arithmetic Accuracy,RM G 1 2 49 Complex Elementary Functions,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-g-2-4-19-accuracy-requirements}@anchor{20b}
+@anchor{gnat_rm/implementation_advice rm-g-2-4-19-accuracy-requirements}@anchor{245}
@section RM G.2.4(19): Accuracy Requirements
@@ -15110,7 +15294,7 @@ Followed.
@geindex complex arithmetic
@node RM G 2 6 15 Complex Arithmetic Accuracy,RM H 6 15/2 Pragma Partition_Elaboration_Policy,RM G 2 4 19 Accuracy Requirements,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-g-2-6-15-complex-arithmetic-accuracy}@anchor{20c}
+@anchor{gnat_rm/implementation_advice rm-g-2-6-15-complex-arithmetic-accuracy}@anchor{246}
@section RM G.2.6(15): Complex Arithmetic Accuracy
@@ -15128,7 +15312,7 @@ Followed.
@geindex Sequential elaboration policy
@node RM H 6 15/2 Pragma Partition_Elaboration_Policy,,RM G 2 6 15 Complex Arithmetic Accuracy,Implementation Advice
-@anchor{gnat_rm/implementation_advice rm-h-6-15-2-pragma-partition-elaboration-policy}@anchor{20d}
+@anchor{gnat_rm/implementation_advice rm-h-6-15-2-pragma-partition-elaboration-policy}@anchor{247}
@section RM H.6(15/2): Pragma Partition_Elaboration_Policy
@@ -15143,7 +15327,7 @@ immediately terminated."
Not followed.
@node Implementation Defined Characteristics,Intrinsic Subprograms,Implementation Advice,Top
-@anchor{gnat_rm/implementation_defined_characteristics implementation-defined-characteristics}@anchor{b}@anchor{gnat_rm/implementation_defined_characteristics doc}@anchor{20e}@anchor{gnat_rm/implementation_defined_characteristics id1}@anchor{20f}
+@anchor{gnat_rm/implementation_defined_characteristics implementation-defined-characteristics}@anchor{b}@anchor{gnat_rm/implementation_defined_characteristics doc}@anchor{248}@anchor{gnat_rm/implementation_defined_characteristics id1}@anchor{249}
@chapter Implementation Defined Characteristics
@@ -16338,7 +16522,7 @@ When the @cite{Pattern} parameter is not the null string, it is interpreted
according to the syntax of regular expressions as defined in the
@cite{GNAT.Regexp} package.
-See @ref{210,,GNAT.Regexp (g-regexp.ads)}.
+See @ref{24a,,GNAT.Regexp (g-regexp.ads)}.
@itemize *
@@ -17380,7 +17564,7 @@ H.4(27)."
There are no restrictions on pragma @cite{Restrictions}.
@node Intrinsic Subprograms,Representation Clauses and Pragmas,Implementation Defined Characteristics,Top
-@anchor{gnat_rm/intrinsic_subprograms doc}@anchor{211}@anchor{gnat_rm/intrinsic_subprograms intrinsic-subprograms}@anchor{c}@anchor{gnat_rm/intrinsic_subprograms id1}@anchor{212}
+@anchor{gnat_rm/intrinsic_subprograms doc}@anchor{24b}@anchor{gnat_rm/intrinsic_subprograms intrinsic-subprograms}@anchor{c}@anchor{gnat_rm/intrinsic_subprograms id1}@anchor{24c}
@chapter Intrinsic Subprograms
@@ -17417,7 +17601,7 @@ Ada standard does not require Ada compilers to implement this feature.
@end menu
@node Intrinsic Operators,Compilation_Date,,Intrinsic Subprograms
-@anchor{gnat_rm/intrinsic_subprograms id2}@anchor{213}@anchor{gnat_rm/intrinsic_subprograms intrinsic-operators}@anchor{214}
+@anchor{gnat_rm/intrinsic_subprograms id2}@anchor{24d}@anchor{gnat_rm/intrinsic_subprograms intrinsic-operators}@anchor{24e}
@section Intrinsic Operators
@@ -17448,7 +17632,7 @@ It is also possible to specify such operators for private types, if the
full views are appropriate arithmetic types.
@node Compilation_Date,Compilation_Time,Intrinsic Operators,Intrinsic Subprograms
-@anchor{gnat_rm/intrinsic_subprograms compilation-date}@anchor{215}@anchor{gnat_rm/intrinsic_subprograms id3}@anchor{216}
+@anchor{gnat_rm/intrinsic_subprograms compilation-date}@anchor{24f}@anchor{gnat_rm/intrinsic_subprograms id3}@anchor{250}
@section Compilation_Date
@@ -17462,7 +17646,7 @@ application program should simply call the function
the current compilation (in local time format MMM DD YYYY).
@node Compilation_Time,Enclosing_Entity,Compilation_Date,Intrinsic Subprograms
-@anchor{gnat_rm/intrinsic_subprograms compilation-time}@anchor{217}@anchor{gnat_rm/intrinsic_subprograms id4}@anchor{218}
+@anchor{gnat_rm/intrinsic_subprograms compilation-time}@anchor{251}@anchor{gnat_rm/intrinsic_subprograms id4}@anchor{252}
@section Compilation_Time
@@ -17476,7 +17660,7 @@ application program should simply call the function
the current compilation (in local time format HH:MM:SS).
@node Enclosing_Entity,Exception_Information,Compilation_Time,Intrinsic Subprograms
-@anchor{gnat_rm/intrinsic_subprograms id5}@anchor{219}@anchor{gnat_rm/intrinsic_subprograms enclosing-entity}@anchor{21a}
+@anchor{gnat_rm/intrinsic_subprograms id5}@anchor{253}@anchor{gnat_rm/intrinsic_subprograms enclosing-entity}@anchor{254}
@section Enclosing_Entity
@@ -17490,7 +17674,7 @@ application program should simply call the function
the current subprogram, package, task, entry, or protected subprogram.
@node Exception_Information,Exception_Message,Enclosing_Entity,Intrinsic Subprograms
-@anchor{gnat_rm/intrinsic_subprograms id6}@anchor{21b}@anchor{gnat_rm/intrinsic_subprograms exception-information}@anchor{21c}
+@anchor{gnat_rm/intrinsic_subprograms id6}@anchor{255}@anchor{gnat_rm/intrinsic_subprograms exception-information}@anchor{256}
@section Exception_Information
@@ -17504,7 +17688,7 @@ so an application program should simply call the function
the exception information associated with the current exception.
@node Exception_Message,Exception_Name,Exception_Information,Intrinsic Subprograms
-@anchor{gnat_rm/intrinsic_subprograms exception-message}@anchor{21d}@anchor{gnat_rm/intrinsic_subprograms id7}@anchor{21e}
+@anchor{gnat_rm/intrinsic_subprograms exception-message}@anchor{257}@anchor{gnat_rm/intrinsic_subprograms id7}@anchor{258}
@section Exception_Message
@@ -17518,7 +17702,7 @@ so an application program should simply call the function
the message associated with the current exception.
@node Exception_Name,File,Exception_Message,Intrinsic Subprograms
-@anchor{gnat_rm/intrinsic_subprograms exception-name}@anchor{21f}@anchor{gnat_rm/intrinsic_subprograms id8}@anchor{220}
+@anchor{gnat_rm/intrinsic_subprograms exception-name}@anchor{259}@anchor{gnat_rm/intrinsic_subprograms id8}@anchor{25a}
@section Exception_Name
@@ -17532,7 +17716,7 @@ so an application program should simply call the function
the name of the current exception.
@node File,Line,Exception_Name,Intrinsic Subprograms
-@anchor{gnat_rm/intrinsic_subprograms file}@anchor{221}@anchor{gnat_rm/intrinsic_subprograms id9}@anchor{222}
+@anchor{gnat_rm/intrinsic_subprograms file}@anchor{25b}@anchor{gnat_rm/intrinsic_subprograms id9}@anchor{25c}
@section File
@@ -17546,7 +17730,7 @@ application program should simply call the function
file.
@node Line,Shifts and Rotates,File,Intrinsic Subprograms
-@anchor{gnat_rm/intrinsic_subprograms id10}@anchor{223}@anchor{gnat_rm/intrinsic_subprograms line}@anchor{224}
+@anchor{gnat_rm/intrinsic_subprograms id10}@anchor{25d}@anchor{gnat_rm/intrinsic_subprograms line}@anchor{25e}
@section Line
@@ -17560,7 +17744,7 @@ application program should simply call the function
source line.
@node Shifts and Rotates,Source_Location,Line,Intrinsic Subprograms
-@anchor{gnat_rm/intrinsic_subprograms id11}@anchor{225}@anchor{gnat_rm/intrinsic_subprograms shifts-and-rotates}@anchor{226}
+@anchor{gnat_rm/intrinsic_subprograms id11}@anchor{25f}@anchor{gnat_rm/intrinsic_subprograms shifts-and-rotates}@anchor{260}
@section Shifts and Rotates
@@ -17599,7 +17783,7 @@ the Provide_Shift_Operators pragma, which provides the function declarations
and corresponding pragma Import's for all five shift functions.
@node Source_Location,,Shifts and Rotates,Intrinsic Subprograms
-@anchor{gnat_rm/intrinsic_subprograms source-location}@anchor{227}@anchor{gnat_rm/intrinsic_subprograms id12}@anchor{228}
+@anchor{gnat_rm/intrinsic_subprograms source-location}@anchor{261}@anchor{gnat_rm/intrinsic_subprograms id12}@anchor{262}
@section Source_Location
@@ -17613,7 +17797,7 @@ application program should simply call the function
source file location.
@node Representation Clauses and Pragmas,Standard Library Routines,Intrinsic Subprograms,Top
-@anchor{gnat_rm/representation_clauses_and_pragmas representation-clauses-and-pragmas}@anchor{d}@anchor{gnat_rm/representation_clauses_and_pragmas doc}@anchor{229}@anchor{gnat_rm/representation_clauses_and_pragmas id1}@anchor{22a}
+@anchor{gnat_rm/representation_clauses_and_pragmas representation-clauses-and-pragmas}@anchor{d}@anchor{gnat_rm/representation_clauses_and_pragmas doc}@anchor{263}@anchor{gnat_rm/representation_clauses_and_pragmas id1}@anchor{264}
@chapter Representation Clauses and Pragmas
@@ -17659,7 +17843,7 @@ and this section describes the additional capabilities provided.
@end menu
@node Alignment Clauses,Size Clauses,,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas id2}@anchor{22b}@anchor{gnat_rm/representation_clauses_and_pragmas alignment-clauses}@anchor{22c}
+@anchor{gnat_rm/representation_clauses_and_pragmas id2}@anchor{265}@anchor{gnat_rm/representation_clauses_and_pragmas alignment-clauses}@anchor{266}
@section Alignment Clauses
@@ -17673,13 +17857,13 @@ values are as follows:
@itemize *
@item
-@emph{Primitive Types}.
+@emph{Elementary Types}.
-For primitive types, the alignment is the minimum of the actual size of
+For elementary types, the alignment is the minimum of the actual size of
objects of the type divided by @cite{Storage_Unit},
and the maximum alignment supported by the target.
(This maximum alignment is given by the GNAT-specific attribute
-@cite{Standard'Maximum_Alignment}; see @ref{149,,Attribute Maximum_Alignment}.)
+@cite{Standard'Maximum_Alignment}; see @ref{183,,Attribute Maximum_Alignment}.)
@geindex Maximum_Alignment attribute
@@ -17695,10 +17879,11 @@ aligned.
For arrays, the alignment is equal to the alignment of the component type
for the normal case where no packing or component size is given. If the
array is packed, and the packing is effective (see separate section on
-packed arrays), then the alignment will be one for long packed arrays,
-or arrays whose length is not known at compile time. For short packed
+packed arrays), then the alignment will be either 4, 2, or 1 for long packed
+arrays or arrays whose length is not known at compile time, depending on
+whether the component size is divisible by 4, 2, or is odd. For short packed
arrays, which are handled internally as modular types, the alignment
-will be as described for primitive types, e.g., a packed array of length
+will be as described for elementary types, e.g. a packed array of length
31 bits will have an object size of four bytes, and an alignment of 4.
@item
@@ -17787,7 +17972,7 @@ assumption is non-portable, and other compilers may choose different
alignments for the subtype @cite{RS}.
@node Size Clauses,Storage_Size Clauses,Alignment Clauses,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas id3}@anchor{22d}@anchor{gnat_rm/representation_clauses_and_pragmas size-clauses}@anchor{22e}
+@anchor{gnat_rm/representation_clauses_and_pragmas id3}@anchor{267}@anchor{gnat_rm/representation_clauses_and_pragmas size-clauses}@anchor{268}
@section Size Clauses
@@ -17864,7 +18049,7 @@ if it is known that a Size value can be accommodated in an object of
type Integer.
@node Storage_Size Clauses,Size of Variant Record Objects,Size Clauses,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas storage-size-clauses}@anchor{22f}@anchor{gnat_rm/representation_clauses_and_pragmas id4}@anchor{230}
+@anchor{gnat_rm/representation_clauses_and_pragmas storage-size-clauses}@anchor{269}@anchor{gnat_rm/representation_clauses_and_pragmas id4}@anchor{26a}
@section Storage_Size Clauses
@@ -17937,7 +18122,7 @@ Of course in practice, there will not be any explicit allocators in the
case of such an access declaration.
@node Size of Variant Record Objects,Biased Representation,Storage_Size Clauses,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas id5}@anchor{231}@anchor{gnat_rm/representation_clauses_and_pragmas size-of-variant-record-objects}@anchor{232}
+@anchor{gnat_rm/representation_clauses_and_pragmas id5}@anchor{26b}@anchor{gnat_rm/representation_clauses_and_pragmas size-of-variant-record-objects}@anchor{26c}
@section Size of Variant Record Objects
@@ -18047,7 +18232,7 @@ the maximum size, regardless of the current variant value, the
variant value.
@node Biased Representation,Value_Size and Object_Size Clauses,Size of Variant Record Objects,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas id6}@anchor{233}@anchor{gnat_rm/representation_clauses_and_pragmas biased-representation}@anchor{234}
+@anchor{gnat_rm/representation_clauses_and_pragmas id6}@anchor{26d}@anchor{gnat_rm/representation_clauses_and_pragmas biased-representation}@anchor{26e}
@section Biased Representation
@@ -18085,7 +18270,7 @@ biased representation can be used for all discrete types except for
enumeration types for which a representation clause is given.
@node Value_Size and Object_Size Clauses,Component_Size Clauses,Biased Representation,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas id7}@anchor{235}@anchor{gnat_rm/representation_clauses_and_pragmas value-size-and-object-size-clauses}@anchor{236}
+@anchor{gnat_rm/representation_clauses_and_pragmas id7}@anchor{26f}@anchor{gnat_rm/representation_clauses_and_pragmas value-size-and-object-size-clauses}@anchor{270}
@section Value_Size and Object_Size Clauses
@@ -18148,7 +18333,7 @@ discrete types are as follows:
The @cite{Object_Size} for base subtypes reflect the natural hardware
size in bits (run the compiler with @emph{-gnatS} to find those values
for numeric types). Enumeration types and fixed-point base subtypes have
-8, 16, 32 or 64 bits for this size, depending on the range of values
+8, 16, 32, or 64 bits for this size, depending on the range of values
to be stored.
@item
@@ -18392,7 +18577,7 @@ definition clause forces biased representation. This
warning can be turned off using @cite{-gnatw.B}.
@node Component_Size Clauses,Bit_Order Clauses,Value_Size and Object_Size Clauses,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas id8}@anchor{237}@anchor{gnat_rm/representation_clauses_and_pragmas component-size-clauses}@anchor{238}
+@anchor{gnat_rm/representation_clauses_and_pragmas id8}@anchor{271}@anchor{gnat_rm/representation_clauses_and_pragmas component-size-clauses}@anchor{272}
@section Component_Size Clauses
@@ -18439,7 +18624,7 @@ and a pragma Pack for the same array type. if such duplicate
clauses are given, the pragma Pack will be ignored.
@node Bit_Order Clauses,Effect of Bit_Order on Byte Ordering,Component_Size Clauses,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas bit-order-clauses}@anchor{239}@anchor{gnat_rm/representation_clauses_and_pragmas id9}@anchor{23a}
+@anchor{gnat_rm/representation_clauses_and_pragmas bit-order-clauses}@anchor{273}@anchor{gnat_rm/representation_clauses_and_pragmas id9}@anchor{274}
@section Bit_Order Clauses
@@ -18528,7 +18713,7 @@ little-endian machines, this must be explicitly programmed. This capability
is not provided by @cite{Bit_Order}.
@item
-Components that are positioned across byte boundaries
+Components that are positioned across byte boundaries.
but do not occupy an integral number of bytes. Given that bytes are not
reordered, such fields would occupy a non-contiguous sequence of bits
@@ -18545,7 +18730,7 @@ if desired. The following section contains additional
details regarding the issue of byte ordering.
@node Effect of Bit_Order on Byte Ordering,Pragma Pack for Arrays,Bit_Order Clauses,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas id10}@anchor{23b}@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-bit-order-on-byte-ordering}@anchor{23c}
+@anchor{gnat_rm/representation_clauses_and_pragmas id10}@anchor{275}@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-bit-order-on-byte-ordering}@anchor{276}
@section Effect of Bit_Order on Byte Ordering
@@ -18802,35 +18987,36 @@ to set the boolean constant @cite{Master_Byte_First} in
an appropriate manner.
@node Pragma Pack for Arrays,Pragma Pack for Records,Effect of Bit_Order on Byte Ordering,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-arrays}@anchor{23d}@anchor{gnat_rm/representation_clauses_and_pragmas id11}@anchor{23e}
+@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-arrays}@anchor{277}@anchor{gnat_rm/representation_clauses_and_pragmas id11}@anchor{278}
@section Pragma Pack for Arrays
@geindex Pragma Pack (for arrays)
-Pragma @cite{Pack} applied to an array has no effect unless the component type
-is packable. For a component type to be packable, it must be one of the
-following cases:
+Pragma @cite{Pack} applied to an array has an effect that depends upon whether the
+component type is @emph{packable}. For a component type to be @emph{packable}, it must
+be one of the following cases:
@itemize *
@item
-Any scalar type
-
-@item
-Any type whose size is specified with a size clause
+Any elementary type.
@item
-Any packed array type with a static size
+Any small packed array type with a static size.
@item
-Any record type padded because of its default alignment
+Any small simple record type with a static size.
@end itemize
For all these cases, if the component subtype size is in the range
-1 through 63, then the effect of the pragma @cite{Pack} is exactly as though a
+1 through 64, then the effect of the pragma @cite{Pack} is exactly as though a
component size were specified giving the component subtype size.
+
+All other types are non-packable, they occupy an integral number of storage
+units and the only effect of pragma Pack is to remove alignment gaps.
+
For example if we have:
@example
@@ -18841,7 +19027,7 @@ pragma Pack (ar);
@end example
Then the component size of @cite{ar} will be set to 5 (i.e., to @cite{r'size},
-and the size of the array @cite{ar} will be exactly 40 bits.
+and the size of the array @cite{ar} will be exactly 40 bits).
Note that in some cases this rather fierce approach to packing can produce
unexpected effects. For example, in Ada 95 and Ada 2005,
@@ -18918,7 +19104,7 @@ Here 31-bit packing is achieved as required, and no warning is generated,
since in this case the programmer intention is clear.
@node Pragma Pack for Records,Record Representation Clauses,Pragma Pack for Arrays,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-records}@anchor{23f}@anchor{gnat_rm/representation_clauses_and_pragmas id12}@anchor{240}
+@anchor{gnat_rm/representation_clauses_and_pragmas pragma-pack-for-records}@anchor{279}@anchor{gnat_rm/representation_clauses_and_pragmas id12}@anchor{27a}
@section Pragma Pack for Records
@@ -18934,22 +19120,24 @@ Components of the following types are considered packable:
@itemize *
@item
-Components of a primitive type are packable unless they are aliased
-or of an atomic type.
+Components of an elementary type are packable unless they are aliased,
+independent, or of an atomic type.
@item
-Small packed arrays, whose size does not exceed 64 bits, and where the
-size is statically known at compile time, are represented internally
-as modular integers, and so they are also packable.
+Small packed arrays, where the size is statically known, are represented
+internally as modular integers, and so they are also packable.
+
+@item
+Small simple records, where the size is statically known, are also packable.
@end itemize
-All packable components occupy the exact number of bits corresponding to
-their @cite{Size} value, and are packed with no padding bits, i.e., they
-can start on an arbitrary bit boundary.
+For all these cases, if the 'Size value is in the range 1 through 64, the
+components occupy the exact number of bits corresponding to this value
+and are packed with no padding bits, i.e. they can start on an arbitrary
+bit boundary.
-All other types are non-packable, they occupy an integral number of
-storage units, and
-are placed at a boundary corresponding to their alignment requirements.
+All other types are non-packable, they occupy an integral number of storage
+units and the only effect of pragma Pack is to remove alignment gaps.
For example, consider the record
@@ -19001,7 +19189,7 @@ the @cite{L6} field is aligned to the next byte boundary, and takes an
integral number of bytes, i.e., 72 bits.
@node Record Representation Clauses,Handling of Records with Holes,Pragma Pack for Records,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas id13}@anchor{241}@anchor{gnat_rm/representation_clauses_and_pragmas record-representation-clauses}@anchor{242}
+@anchor{gnat_rm/representation_clauses_and_pragmas id13}@anchor{27b}@anchor{gnat_rm/representation_clauses_and_pragmas record-representation-clauses}@anchor{27c}
@section Record Representation Clauses
@@ -19080,13 +19268,13 @@ end record;
Note: the above rules apply to recent releases of GNAT 5.
In GNAT 3, there are more severe restrictions on larger components.
-For non-primitive types, including packed arrays with a size greater than
+For composite types, including packed arrays with a size greater than
64 bits, component clauses must respect the alignment requirement of the
type, in particular, always starting on a byte boundary, and the length
must be a multiple of the storage unit.
@node Handling of Records with Holes,Enumeration Clauses,Record Representation Clauses,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas handling-of-records-with-holes}@anchor{243}@anchor{gnat_rm/representation_clauses_and_pragmas id14}@anchor{244}
+@anchor{gnat_rm/representation_clauses_and_pragmas handling-of-records-with-holes}@anchor{27d}@anchor{gnat_rm/representation_clauses_and_pragmas id14}@anchor{27e}
@section Handling of Records with Holes
@@ -19163,7 +19351,7 @@ for Hrec'Size use 64;
@end example
@node Enumeration Clauses,Address Clauses,Handling of Records with Holes,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas enumeration-clauses}@anchor{245}@anchor{gnat_rm/representation_clauses_and_pragmas id15}@anchor{246}
+@anchor{gnat_rm/representation_clauses_and_pragmas enumeration-clauses}@anchor{27f}@anchor{gnat_rm/representation_clauses_and_pragmas id15}@anchor{280}
@section Enumeration Clauses
@@ -19206,7 +19394,7 @@ the overhead of converting representation values to the corresponding
positional values, (i.e., the value delivered by the @cite{Pos} attribute).
@node Address Clauses,Use of Address Clauses for Memory-Mapped I/O,Enumeration Clauses,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas id16}@anchor{247}@anchor{gnat_rm/representation_clauses_and_pragmas address-clauses}@anchor{248}
+@anchor{gnat_rm/representation_clauses_and_pragmas id16}@anchor{281}@anchor{gnat_rm/representation_clauses_and_pragmas address-clauses}@anchor{282}
@section Address Clauses
@@ -19536,7 +19724,7 @@ then the program compiles without the warning and when run will generate
the output @cite{X was not clobbered}.
@node Use of Address Clauses for Memory-Mapped I/O,Effect of Convention on Representation,Address Clauses,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas id17}@anchor{249}@anchor{gnat_rm/representation_clauses_and_pragmas use-of-address-clauses-for-memory-mapped-i-o}@anchor{24a}
+@anchor{gnat_rm/representation_clauses_and_pragmas id17}@anchor{283}@anchor{gnat_rm/representation_clauses_and_pragmas use-of-address-clauses-for-memory-mapped-i-o}@anchor{284}
@section Use of Address Clauses for Memory-Mapped I/O
@@ -19594,7 +19782,7 @@ provides the pragma @cite{Volatile_Full_Access} which can be used in lieu of
pragma @cite{Atomic} and will give the additional guarantee.
@node Effect of Convention on Representation,Conventions and Anonymous Access Types,Use of Address Clauses for Memory-Mapped I/O,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas id18}@anchor{24b}@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-convention-on-representation}@anchor{24c}
+@anchor{gnat_rm/representation_clauses_and_pragmas id18}@anchor{285}@anchor{gnat_rm/representation_clauses_and_pragmas effect-of-convention-on-representation}@anchor{286}
@section Effect of Convention on Representation
@@ -19672,7 +19860,7 @@ when one of these values is read, any nonzero value is treated as True.
@end itemize
@node Conventions and Anonymous Access Types,Determining the Representations chosen by GNAT,Effect of Convention on Representation,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas conventions-and-anonymous-access-types}@anchor{24d}@anchor{gnat_rm/representation_clauses_and_pragmas id19}@anchor{24e}
+@anchor{gnat_rm/representation_clauses_and_pragmas conventions-and-anonymous-access-types}@anchor{287}@anchor{gnat_rm/representation_clauses_and_pragmas id19}@anchor{288}
@section Conventions and Anonymous Access Types
@@ -19748,7 +19936,7 @@ package ConvComp is
@end example
@node Determining the Representations chosen by GNAT,,Conventions and Anonymous Access Types,Representation Clauses and Pragmas
-@anchor{gnat_rm/representation_clauses_and_pragmas id20}@anchor{24f}@anchor{gnat_rm/representation_clauses_and_pragmas determining-the-representations-chosen-by-gnat}@anchor{250}
+@anchor{gnat_rm/representation_clauses_and_pragmas id20}@anchor{289}@anchor{gnat_rm/representation_clauses_and_pragmas determining-the-representations-chosen-by-gnat}@anchor{28a}
@section Determining the Representations chosen by GNAT
@@ -19900,7 +20088,7 @@ generated by the compiler into the original source to fix and guarantee
the actual representation to be used.
@node Standard Library Routines,The Implementation of Standard I/O,Representation Clauses and Pragmas,Top
-@anchor{gnat_rm/standard_library_routines standard-library-routines}@anchor{e}@anchor{gnat_rm/standard_library_routines doc}@anchor{251}@anchor{gnat_rm/standard_library_routines id1}@anchor{252}
+@anchor{gnat_rm/standard_library_routines standard-library-routines}@anchor{e}@anchor{gnat_rm/standard_library_routines doc}@anchor{28b}@anchor{gnat_rm/standard_library_routines id1}@anchor{28c}
@chapter Standard Library Routines
@@ -20723,7 +20911,7 @@ For packages in Interfaces and System, all the RM defined packages are
available in GNAT, see the Ada 2012 RM for full details.
@node The Implementation of Standard I/O,The GNAT Library,Standard Library Routines,Top
-@anchor{gnat_rm/the_implementation_of_standard_i_o the-implementation-of-standard-i-o}@anchor{f}@anchor{gnat_rm/the_implementation_of_standard_i_o doc}@anchor{253}@anchor{gnat_rm/the_implementation_of_standard_i_o id1}@anchor{254}
+@anchor{gnat_rm/the_implementation_of_standard_i_o the-implementation-of-standard-i-o}@anchor{f}@anchor{gnat_rm/the_implementation_of_standard_i_o doc}@anchor{28d}@anchor{gnat_rm/the_implementation_of_standard_i_o id1}@anchor{28e}
@chapter The Implementation of Standard I/O
@@ -20775,7 +20963,7 @@ these additional facilities are also described in this chapter.
@end menu
@node Standard I/O Packages,FORM Strings,,The Implementation of Standard I/O
-@anchor{gnat_rm/the_implementation_of_standard_i_o standard-i-o-packages}@anchor{255}@anchor{gnat_rm/the_implementation_of_standard_i_o id2}@anchor{256}
+@anchor{gnat_rm/the_implementation_of_standard_i_o standard-i-o-packages}@anchor{28f}@anchor{gnat_rm/the_implementation_of_standard_i_o id2}@anchor{290}
@section Standard I/O Packages
@@ -20846,7 +21034,7 @@ flush the common I/O streams and in particular Standard_Output before
elaborating the Ada code.
@node FORM Strings,Direct_IO,Standard I/O Packages,The Implementation of Standard I/O
-@anchor{gnat_rm/the_implementation_of_standard_i_o form-strings}@anchor{257}@anchor{gnat_rm/the_implementation_of_standard_i_o id3}@anchor{258}
+@anchor{gnat_rm/the_implementation_of_standard_i_o form-strings}@anchor{291}@anchor{gnat_rm/the_implementation_of_standard_i_o id3}@anchor{292}
@section FORM Strings
@@ -20872,7 +21060,7 @@ unrecognized keyword appears in a form string, it is silently ignored
and not considered invalid.
@node Direct_IO,Sequential_IO,FORM Strings,The Implementation of Standard I/O
-@anchor{gnat_rm/the_implementation_of_standard_i_o direct-io}@anchor{259}@anchor{gnat_rm/the_implementation_of_standard_i_o id4}@anchor{25a}
+@anchor{gnat_rm/the_implementation_of_standard_i_o direct-io}@anchor{293}@anchor{gnat_rm/the_implementation_of_standard_i_o id4}@anchor{294}
@section Direct_IO
@@ -20892,7 +21080,7 @@ There is no limit on the size of Direct_IO files, they are expanded as
necessary to accommodate whatever records are written to the file.
@node Sequential_IO,Text_IO,Direct_IO,The Implementation of Standard I/O
-@anchor{gnat_rm/the_implementation_of_standard_i_o sequential-io}@anchor{25b}@anchor{gnat_rm/the_implementation_of_standard_i_o id5}@anchor{25c}
+@anchor{gnat_rm/the_implementation_of_standard_i_o sequential-io}@anchor{295}@anchor{gnat_rm/the_implementation_of_standard_i_o id5}@anchor{296}
@section Sequential_IO
@@ -20939,7 +21127,7 @@ using Stream_IO, and this is the preferred mechanism. In particular, the
above program fragment rewritten to use Stream_IO will work correctly.
@node Text_IO,Wide_Text_IO,Sequential_IO,The Implementation of Standard I/O
-@anchor{gnat_rm/the_implementation_of_standard_i_o id6}@anchor{25d}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io}@anchor{25e}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id6}@anchor{297}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io}@anchor{298}
@section Text_IO
@@ -21022,7 +21210,7 @@ the file.
@end menu
@node Stream Pointer Positioning,Reading and Writing Non-Regular Files,,Text_IO
-@anchor{gnat_rm/the_implementation_of_standard_i_o id7}@anchor{25f}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning}@anchor{260}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id7}@anchor{299}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning}@anchor{29a}
@subsection Stream Pointer Positioning
@@ -21058,7 +21246,7 @@ between two Ada files, then the difference may be observable in some
situations.
@node Reading and Writing Non-Regular Files,Get_Immediate,Stream Pointer Positioning,Text_IO
-@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files}@anchor{261}@anchor{gnat_rm/the_implementation_of_standard_i_o id8}@anchor{262}
+@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files}@anchor{29b}@anchor{gnat_rm/the_implementation_of_standard_i_o id8}@anchor{29c}
@subsection Reading and Writing Non-Regular Files
@@ -21109,7 +21297,7 @@ to read data past that end of
file indication, until another end of file indication is entered.
@node Get_Immediate,Treating Text_IO Files as Streams,Reading and Writing Non-Regular Files,Text_IO
-@anchor{gnat_rm/the_implementation_of_standard_i_o get-immediate}@anchor{263}@anchor{gnat_rm/the_implementation_of_standard_i_o id9}@anchor{264}
+@anchor{gnat_rm/the_implementation_of_standard_i_o get-immediate}@anchor{29d}@anchor{gnat_rm/the_implementation_of_standard_i_o id9}@anchor{29e}
@subsection Get_Immediate
@@ -21127,7 +21315,7 @@ possible), it is undefined whether the FF character will be treated as a
page mark.
@node Treating Text_IO Files as Streams,Text_IO Extensions,Get_Immediate,Text_IO
-@anchor{gnat_rm/the_implementation_of_standard_i_o id10}@anchor{265}@anchor{gnat_rm/the_implementation_of_standard_i_o treating-text-io-files-as-streams}@anchor{266}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id10}@anchor{29f}@anchor{gnat_rm/the_implementation_of_standard_i_o treating-text-io-files-as-streams}@anchor{2a0}
@subsection Treating Text_IO Files as Streams
@@ -21143,7 +21331,7 @@ skipped and the effect is similar to that described above for
@cite{Get_Immediate}.
@node Text_IO Extensions,Text_IO Facilities for Unbounded Strings,Treating Text_IO Files as Streams,Text_IO
-@anchor{gnat_rm/the_implementation_of_standard_i_o id11}@anchor{267}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-extensions}@anchor{268}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id11}@anchor{2a1}@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-extensions}@anchor{2a2}
@subsection Text_IO Extensions
@@ -21171,7 +21359,7 @@ the string is to be read.
@end itemize
@node Text_IO Facilities for Unbounded Strings,,Text_IO Extensions,Text_IO
-@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-facilities-for-unbounded-strings}@anchor{269}@anchor{gnat_rm/the_implementation_of_standard_i_o id12}@anchor{26a}
+@anchor{gnat_rm/the_implementation_of_standard_i_o text-io-facilities-for-unbounded-strings}@anchor{2a3}@anchor{gnat_rm/the_implementation_of_standard_i_o id12}@anchor{2a4}
@subsection Text_IO Facilities for Unbounded Strings
@@ -21219,7 +21407,7 @@ files @code{a-szuzti.ads} and @code{a-szuzti.adb} provides similar extended
@cite{Wide_Wide_Text_IO} functionality for unbounded wide wide strings.
@node Wide_Text_IO,Wide_Wide_Text_IO,Text_IO,The Implementation of Standard I/O
-@anchor{gnat_rm/the_implementation_of_standard_i_o wide-text-io}@anchor{26b}@anchor{gnat_rm/the_implementation_of_standard_i_o id13}@anchor{26c}
+@anchor{gnat_rm/the_implementation_of_standard_i_o wide-text-io}@anchor{2a5}@anchor{gnat_rm/the_implementation_of_standard_i_o id13}@anchor{2a6}
@section Wide_Text_IO
@@ -21466,12 +21654,12 @@ input also causes Constraint_Error to be raised.
@end menu
@node Stream Pointer Positioning<2>,Reading and Writing Non-Regular Files<2>,,Wide_Text_IO
-@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-1}@anchor{26d}@anchor{gnat_rm/the_implementation_of_standard_i_o id14}@anchor{26e}
+@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-1}@anchor{2a7}@anchor{gnat_rm/the_implementation_of_standard_i_o id14}@anchor{2a8}
@subsection Stream Pointer Positioning
@cite{Ada.Wide_Text_IO} is similar to @cite{Ada.Text_IO} in its handling
-of stream pointer positioning (@ref{25e,,Text_IO}). There is one additional
+of stream pointer positioning (@ref{298,,Text_IO}). There is one additional
case:
If @cite{Ada.Wide_Text_IO.Look_Ahead} reads a character outside the
@@ -21490,7 +21678,7 @@ to a normal program using @cite{Wide_Text_IO}. However, this discrepancy
can be observed if the wide text file shares a stream with another file.
@node Reading and Writing Non-Regular Files<2>,,Stream Pointer Positioning<2>,Wide_Text_IO
-@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-1}@anchor{26f}@anchor{gnat_rm/the_implementation_of_standard_i_o id15}@anchor{270}
+@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-1}@anchor{2a9}@anchor{gnat_rm/the_implementation_of_standard_i_o id15}@anchor{2aa}
@subsection Reading and Writing Non-Regular Files
@@ -21501,7 +21689,7 @@ treated as data characters), and @cite{End_Of_Page} always returns
it is possible to read beyond an end of file.
@node Wide_Wide_Text_IO,Stream_IO,Wide_Text_IO,The Implementation of Standard I/O
-@anchor{gnat_rm/the_implementation_of_standard_i_o id16}@anchor{271}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-wide-text-io}@anchor{272}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id16}@anchor{2ab}@anchor{gnat_rm/the_implementation_of_standard_i_o wide-wide-text-io}@anchor{2ac}
@section Wide_Wide_Text_IO
@@ -21670,12 +21858,12 @@ input also causes Constraint_Error to be raised.
@end menu
@node Stream Pointer Positioning<3>,Reading and Writing Non-Regular Files<3>,,Wide_Wide_Text_IO
-@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-2}@anchor{273}@anchor{gnat_rm/the_implementation_of_standard_i_o id17}@anchor{274}
+@anchor{gnat_rm/the_implementation_of_standard_i_o stream-pointer-positioning-2}@anchor{2ad}@anchor{gnat_rm/the_implementation_of_standard_i_o id17}@anchor{2ae}
@subsection Stream Pointer Positioning
@cite{Ada.Wide_Wide_Text_IO} is similar to @cite{Ada.Text_IO} in its handling
-of stream pointer positioning (@ref{25e,,Text_IO}). There is one additional
+of stream pointer positioning (@ref{298,,Text_IO}). There is one additional
case:
If @cite{Ada.Wide_Wide_Text_IO.Look_Ahead} reads a character outside the
@@ -21694,7 +21882,7 @@ to a normal program using @cite{Wide_Wide_Text_IO}. However, this discrepancy
can be observed if the wide text file shares a stream with another file.
@node Reading and Writing Non-Regular Files<3>,,Stream Pointer Positioning<3>,Wide_Wide_Text_IO
-@anchor{gnat_rm/the_implementation_of_standard_i_o id18}@anchor{275}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-2}@anchor{276}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id18}@anchor{2af}@anchor{gnat_rm/the_implementation_of_standard_i_o reading-and-writing-non-regular-files-2}@anchor{2b0}
@subsection Reading and Writing Non-Regular Files
@@ -21705,7 +21893,7 @@ treated as data characters), and @cite{End_Of_Page} always returns
it is possible to read beyond an end of file.
@node Stream_IO,Text Translation,Wide_Wide_Text_IO,The Implementation of Standard I/O
-@anchor{gnat_rm/the_implementation_of_standard_i_o id19}@anchor{277}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-io}@anchor{278}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id19}@anchor{2b1}@anchor{gnat_rm/the_implementation_of_standard_i_o stream-io}@anchor{2b2}
@section Stream_IO
@@ -21727,7 +21915,7 @@ manner described for stream attributes.
@end itemize
@node Text Translation,Shared Files,Stream_IO,The Implementation of Standard I/O
-@anchor{gnat_rm/the_implementation_of_standard_i_o id20}@anchor{279}@anchor{gnat_rm/the_implementation_of_standard_i_o text-translation}@anchor{27a}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id20}@anchor{2b3}@anchor{gnat_rm/the_implementation_of_standard_i_o text-translation}@anchor{2b4}
@section Text Translation
@@ -21761,7 +21949,7 @@ mode. (corresponds to_O_U16TEXT).
@end itemize
@node Shared Files,Filenames encoding,Text Translation,The Implementation of Standard I/O
-@anchor{gnat_rm/the_implementation_of_standard_i_o id21}@anchor{27b}@anchor{gnat_rm/the_implementation_of_standard_i_o shared-files}@anchor{27c}
+@anchor{gnat_rm/the_implementation_of_standard_i_o id21}@anchor{2b5}@anchor{gnat_rm/the_implementation_of_standard_i_o shared-files}@anchor{2b6}
@section Shared Files
@@ -21824,7 +22012,7 @@ heterogeneous input-output. Although this approach will work in GNAT if
for this purpose (using the stream attributes)
@node Filenames encoding,File content encoding,Shared Files,The Implementation of Standard I/O
-@anchor{gnat_rm/the_implementation_of_standard_i_o filenames-encoding}@anchor{27d}@anchor{gnat_rm/the_implementation_of_standard_i_o id22}@anchor{27e}
+@anchor{gnat_rm/the_implementation_of_standard_i_o filenames-encoding}@anchor{2b7}@anchor{gnat_rm/the_implementation_of_standard_i_o id22}@anchor{2b8}
@section Filenames encoding
@@ -21864,7 +22052,7 @@ platform. On the other Operating Systems the run-time is supporting
UTF-8 natively.
@node File content encoding,Open Modes,Filenames encoding,The Implementation of Standard I/O
-@anchor{gnat_rm/the_implementation_of_standard_i_o file-content-encoding}@anchor{27f}@anchor{gnat_rm/the_implementation_of_standard_i_o id23}@anchor{280}
+@anchor{gnat_rm/the_implementation_of_standard_i_o file-content-encoding}@anchor{2b9}@anchor{gnat_rm/the_implementation_of_standard_i_o id23}@anchor{2ba}
@section File content encoding
@@ -21897,7 +22085,7 @@ Unicode 8-bit encoding
This encoding is only supported on the Windows platform.
@node Open Modes,Operations on C Streams,File content encoding,The Implementation of Standard I/O
-@anchor{gnat_rm/the_implementation_of_standard_i_o open-modes}@anchor{281}@anchor{gnat_rm/the_implementation_of_standard_i_o id24}@anchor{282}
+@anchor{gnat_rm/the_implementation_of_standard_i_o open-modes}@anchor{2bb}@anchor{gnat_rm/the_implementation_of_standard_i_o id24}@anchor{2bc}
@section Open Modes
@@ -22000,7 +22188,7 @@ subsequently requires switching from reading to writing or vice-versa,
then the file is reopened in @code{r+} mode to permit the required operation.
@node Operations on C Streams,Interfacing to C Streams,Open Modes,The Implementation of Standard I/O
-@anchor{gnat_rm/the_implementation_of_standard_i_o operations-on-c-streams}@anchor{283}@anchor{gnat_rm/the_implementation_of_standard_i_o id25}@anchor{284}
+@anchor{gnat_rm/the_implementation_of_standard_i_o operations-on-c-streams}@anchor{2bd}@anchor{gnat_rm/the_implementation_of_standard_i_o id25}@anchor{2be}
@section Operations on C Streams
@@ -22160,7 +22348,7 @@ end Interfaces.C_Streams;
@end example
@node Interfacing to C Streams,,Operations on C Streams,The Implementation of Standard I/O
-@anchor{gnat_rm/the_implementation_of_standard_i_o interfacing-to-c-streams}@anchor{285}@anchor{gnat_rm/the_implementation_of_standard_i_o id26}@anchor{286}
+@anchor{gnat_rm/the_implementation_of_standard_i_o interfacing-to-c-streams}@anchor{2bf}@anchor{gnat_rm/the_implementation_of_standard_i_o id26}@anchor{2c0}
@section Interfacing to C Streams
@@ -22253,7 +22441,7 @@ imported from a C program, allowing an Ada file to operate on an
existing C file.
@node The GNAT Library,Interfacing to Other Languages,The Implementation of Standard I/O,Top
-@anchor{gnat_rm/the_gnat_library the-gnat-library}@anchor{10}@anchor{gnat_rm/the_gnat_library doc}@anchor{287}@anchor{gnat_rm/the_gnat_library id1}@anchor{288}
+@anchor{gnat_rm/the_gnat_library the-gnat-library}@anchor{10}@anchor{gnat_rm/the_gnat_library doc}@anchor{2c1}@anchor{gnat_rm/the_gnat_library id1}@anchor{2c2}
@chapter The GNAT Library
@@ -22402,6 +22590,7 @@ of GNAT, and will generate a warning message.
* GNAT.Spitbol.Table_VString (g-sptavs.ads): GNAT Spitbol Table_VString g-sptavs ads.
* GNAT.SSE (g-sse.ads): GNAT SSE g-sse ads.
* GNAT.SSE.Vector_Types (g-ssvety.ads): GNAT SSE Vector_Types g-ssvety ads.
+* GNAT.String_Hash (g-strhas.ads): GNAT String_Hash g-strhas ads.
* GNAT.Strings (g-string.ads): GNAT Strings g-string ads.
* GNAT.String_Split (g-strspl.ads): GNAT String_Split g-strspl ads.
* GNAT.Table (g-table.ads): GNAT Table g-table ads.
@@ -22420,6 +22609,7 @@ of GNAT, and will generate a warning message.
* Interfaces.C.Streams (i-cstrea.ads): Interfaces C Streams i-cstrea ads.
* Interfaces.Packed_Decimal (i-pacdec.ads): Interfaces Packed_Decimal i-pacdec ads.
* Interfaces.VxWorks (i-vxwork.ads): Interfaces VxWorks i-vxwork ads.
+* Interfaces.VxWorks.Int_Connection (i-vxinco.ads): Interfaces VxWorks Int_Connection i-vxinco ads.
* Interfaces.VxWorks.IO (i-vxwoio.ads): Interfaces VxWorks IO i-vxwoio ads.
* System.Address_Image (s-addima.ads): System Address_Image s-addima ads.
* System.Assertions (s-assert.ads): System Assertions s-assert ads.
@@ -22440,7 +22630,7 @@ of GNAT, and will generate a warning message.
@end menu
@node Ada Characters Latin_9 a-chlat9 ads,Ada Characters Wide_Latin_1 a-cwila1 ads,,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id2}@anchor{289}@anchor{gnat_rm/the_gnat_library ada-characters-latin-9-a-chlat9-ads}@anchor{28a}
+@anchor{gnat_rm/the_gnat_library id2}@anchor{2c3}@anchor{gnat_rm/the_gnat_library ada-characters-latin-9-a-chlat9-ads}@anchor{2c4}
@section @cite{Ada.Characters.Latin_9} (@code{a-chlat9.ads})
@@ -22457,7 +22647,7 @@ is specifically authorized by the Ada Reference Manual
(RM A.3.3(27)).
@node Ada Characters Wide_Latin_1 a-cwila1 ads,Ada Characters Wide_Latin_9 a-cwila1 ads,Ada Characters Latin_9 a-chlat9 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-1-a-cwila1-ads}@anchor{28b}@anchor{gnat_rm/the_gnat_library id3}@anchor{28c}
+@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-1-a-cwila1-ads}@anchor{2c5}@anchor{gnat_rm/the_gnat_library id3}@anchor{2c6}
@section @cite{Ada.Characters.Wide_Latin_1} (@code{a-cwila1.ads})
@@ -22474,7 +22664,7 @@ is specifically authorized by the Ada Reference Manual
(RM A.3.3(27)).
@node Ada Characters Wide_Latin_9 a-cwila1 ads,Ada Characters Wide_Wide_Latin_1 a-chzla1 ads,Ada Characters Wide_Latin_1 a-cwila1 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id4}@anchor{28d}@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-9-a-cwila1-ads}@anchor{28e}
+@anchor{gnat_rm/the_gnat_library id4}@anchor{2c7}@anchor{gnat_rm/the_gnat_library ada-characters-wide-latin-9-a-cwila1-ads}@anchor{2c8}
@section @cite{Ada.Characters.Wide_Latin_9} (@code{a-cwila1.ads})
@@ -22491,7 +22681,7 @@ is specifically authorized by the Ada Reference Manual
(RM A.3.3(27)).
@node Ada Characters Wide_Wide_Latin_1 a-chzla1 ads,Ada Characters Wide_Wide_Latin_9 a-chzla9 ads,Ada Characters Wide_Latin_9 a-cwila1 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-1-a-chzla1-ads}@anchor{28f}@anchor{gnat_rm/the_gnat_library id5}@anchor{290}
+@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-1-a-chzla1-ads}@anchor{2c9}@anchor{gnat_rm/the_gnat_library id5}@anchor{2ca}
@section @cite{Ada.Characters.Wide_Wide_Latin_1} (@code{a-chzla1.ads})
@@ -22508,7 +22698,7 @@ is specifically authorized by the Ada Reference Manual
(RM A.3.3(27)).
@node Ada Characters Wide_Wide_Latin_9 a-chzla9 ads,Ada Containers Formal_Doubly_Linked_Lists a-cfdlli ads,Ada Characters Wide_Wide_Latin_1 a-chzla1 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-9-a-chzla9-ads}@anchor{291}@anchor{gnat_rm/the_gnat_library id6}@anchor{292}
+@anchor{gnat_rm/the_gnat_library ada-characters-wide-wide-latin-9-a-chzla9-ads}@anchor{2cb}@anchor{gnat_rm/the_gnat_library id6}@anchor{2cc}
@section @cite{Ada.Characters.Wide_Wide_Latin_9} (@code{a-chzla9.ads})
@@ -22525,7 +22715,7 @@ is specifically authorized by the Ada Reference Manual
(RM A.3.3(27)).
@node Ada Containers Formal_Doubly_Linked_Lists a-cfdlli ads,Ada Containers Formal_Hashed_Maps a-cfhama ads,Ada Characters Wide_Wide_Latin_9 a-chzla9 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id7}@anchor{293}@anchor{gnat_rm/the_gnat_library ada-containers-formal-doubly-linked-lists-a-cfdlli-ads}@anchor{294}
+@anchor{gnat_rm/the_gnat_library id7}@anchor{2cd}@anchor{gnat_rm/the_gnat_library ada-containers-formal-doubly-linked-lists-a-cfdlli-ads}@anchor{2ce}
@section @cite{Ada.Containers.Formal_Doubly_Linked_Lists} (@code{a-cfdlli.ads})
@@ -22544,7 +22734,7 @@ efficient version than the one defined in the standard. In particular it
does not have the complex overhead required to detect cursor tampering.
@node Ada Containers Formal_Hashed_Maps a-cfhama ads,Ada Containers Formal_Hashed_Sets a-cfhase ads,Ada Containers Formal_Doubly_Linked_Lists a-cfdlli ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id8}@anchor{295}@anchor{gnat_rm/the_gnat_library ada-containers-formal-hashed-maps-a-cfhama-ads}@anchor{296}
+@anchor{gnat_rm/the_gnat_library id8}@anchor{2cf}@anchor{gnat_rm/the_gnat_library ada-containers-formal-hashed-maps-a-cfhama-ads}@anchor{2d0}
@section @cite{Ada.Containers.Formal_Hashed_Maps} (@code{a-cfhama.ads})
@@ -22563,7 +22753,7 @@ efficient version than the one defined in the standard. In particular it
does not have the complex overhead required to detect cursor tampering.
@node Ada Containers Formal_Hashed_Sets a-cfhase ads,Ada Containers Formal_Ordered_Maps a-cforma ads,Ada Containers Formal_Hashed_Maps a-cfhama ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id9}@anchor{297}@anchor{gnat_rm/the_gnat_library ada-containers-formal-hashed-sets-a-cfhase-ads}@anchor{298}
+@anchor{gnat_rm/the_gnat_library id9}@anchor{2d1}@anchor{gnat_rm/the_gnat_library ada-containers-formal-hashed-sets-a-cfhase-ads}@anchor{2d2}
@section @cite{Ada.Containers.Formal_Hashed_Sets} (@code{a-cfhase.ads})
@@ -22582,7 +22772,7 @@ efficient version than the one defined in the standard. In particular it
does not have the complex overhead required to detect cursor tampering.
@node Ada Containers Formal_Ordered_Maps a-cforma ads,Ada Containers Formal_Ordered_Sets a-cforse ads,Ada Containers Formal_Hashed_Sets a-cfhase ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id10}@anchor{299}@anchor{gnat_rm/the_gnat_library ada-containers-formal-ordered-maps-a-cforma-ads}@anchor{29a}
+@anchor{gnat_rm/the_gnat_library id10}@anchor{2d3}@anchor{gnat_rm/the_gnat_library ada-containers-formal-ordered-maps-a-cforma-ads}@anchor{2d4}
@section @cite{Ada.Containers.Formal_Ordered_Maps} (@code{a-cforma.ads})
@@ -22601,7 +22791,7 @@ efficient version than the one defined in the standard. In particular it
does not have the complex overhead required to detect cursor tampering.
@node Ada Containers Formal_Ordered_Sets a-cforse ads,Ada Containers Formal_Vectors a-cofove ads,Ada Containers Formal_Ordered_Maps a-cforma ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-containers-formal-ordered-sets-a-cforse-ads}@anchor{29b}@anchor{gnat_rm/the_gnat_library id11}@anchor{29c}
+@anchor{gnat_rm/the_gnat_library ada-containers-formal-ordered-sets-a-cforse-ads}@anchor{2d5}@anchor{gnat_rm/the_gnat_library id11}@anchor{2d6}
@section @cite{Ada.Containers.Formal_Ordered_Sets} (@code{a-cforse.ads})
@@ -22620,7 +22810,7 @@ efficient version than the one defined in the standard. In particular it
does not have the complex overhead required to detect cursor tampering.
@node Ada Containers Formal_Vectors a-cofove ads,Ada Containers Formal_Indefinite_Vectors a-cfinve ads,Ada Containers Formal_Ordered_Sets a-cforse ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id12}@anchor{29d}@anchor{gnat_rm/the_gnat_library ada-containers-formal-vectors-a-cofove-ads}@anchor{29e}
+@anchor{gnat_rm/the_gnat_library id12}@anchor{2d7}@anchor{gnat_rm/the_gnat_library ada-containers-formal-vectors-a-cofove-ads}@anchor{2d8}
@section @cite{Ada.Containers.Formal_Vectors} (@code{a-cofove.ads})
@@ -22639,7 +22829,7 @@ efficient version than the one defined in the standard. In particular it
does not have the complex overhead required to detect cursor tampering.
@node Ada Containers Formal_Indefinite_Vectors a-cfinve ads,Ada Containers Bounded_Holders a-coboho ads,Ada Containers Formal_Vectors a-cofove ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id13}@anchor{29f}@anchor{gnat_rm/the_gnat_library ada-containers-formal-indefinite-vectors-a-cfinve-ads}@anchor{2a0}
+@anchor{gnat_rm/the_gnat_library id13}@anchor{2d9}@anchor{gnat_rm/the_gnat_library ada-containers-formal-indefinite-vectors-a-cfinve-ads}@anchor{2da}
@section @cite{Ada.Containers.Formal_Indefinite_Vectors} (@code{a-cfinve.ads})
@@ -22658,7 +22848,7 @@ efficient version than the one defined in the standard. In particular it
does not have the complex overhead required to detect cursor tampering.
@node Ada Containers Bounded_Holders a-coboho ads,Ada Command_Line Environment a-colien ads,Ada Containers Formal_Indefinite_Vectors a-cfinve ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id14}@anchor{2a1}@anchor{gnat_rm/the_gnat_library ada-containers-bounded-holders-a-coboho-ads}@anchor{2a2}
+@anchor{gnat_rm/the_gnat_library id14}@anchor{2db}@anchor{gnat_rm/the_gnat_library ada-containers-bounded-holders-a-coboho-ads}@anchor{2dc}
@section @cite{Ada.Containers.Bounded_Holders} (@code{a-coboho.ads})
@@ -22670,7 +22860,7 @@ This child of @cite{Ada.Containers} defines a modified version of
Indefinite_Holders that avoids heap allocation.
@node Ada Command_Line Environment a-colien ads,Ada Command_Line Remove a-colire ads,Ada Containers Bounded_Holders a-coboho ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-command-line-environment-a-colien-ads}@anchor{2a3}@anchor{gnat_rm/the_gnat_library id15}@anchor{2a4}
+@anchor{gnat_rm/the_gnat_library ada-command-line-environment-a-colien-ads}@anchor{2dd}@anchor{gnat_rm/the_gnat_library id15}@anchor{2de}
@section @cite{Ada.Command_Line.Environment} (@code{a-colien.ads})
@@ -22683,7 +22873,7 @@ provides a mechanism for obtaining environment values on systems
where this concept makes sense.
@node Ada Command_Line Remove a-colire ads,Ada Command_Line Response_File a-clrefi ads,Ada Command_Line Environment a-colien ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id16}@anchor{2a5}@anchor{gnat_rm/the_gnat_library ada-command-line-remove-a-colire-ads}@anchor{2a6}
+@anchor{gnat_rm/the_gnat_library id16}@anchor{2df}@anchor{gnat_rm/the_gnat_library ada-command-line-remove-a-colire-ads}@anchor{2e0}
@section @cite{Ada.Command_Line.Remove} (@code{a-colire.ads})
@@ -22701,7 +22891,7 @@ to further calls on the subprograms in @cite{Ada.Command_Line} will not
see the removed argument.
@node Ada Command_Line Response_File a-clrefi ads,Ada Direct_IO C_Streams a-diocst ads,Ada Command_Line Remove a-colire ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-command-line-response-file-a-clrefi-ads}@anchor{2a7}@anchor{gnat_rm/the_gnat_library id17}@anchor{2a8}
+@anchor{gnat_rm/the_gnat_library ada-command-line-response-file-a-clrefi-ads}@anchor{2e1}@anchor{gnat_rm/the_gnat_library id17}@anchor{2e2}
@section @cite{Ada.Command_Line.Response_File} (@code{a-clrefi.ads})
@@ -22721,7 +22911,7 @@ Using a response file allow passing a set of arguments to an executable longer
than the maximum allowed by the system on the command line.
@node Ada Direct_IO C_Streams a-diocst ads,Ada Exceptions Is_Null_Occurrence a-einuoc ads,Ada Command_Line Response_File a-clrefi ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id18}@anchor{2a9}@anchor{gnat_rm/the_gnat_library ada-direct-io-c-streams-a-diocst-ads}@anchor{2aa}
+@anchor{gnat_rm/the_gnat_library id18}@anchor{2e3}@anchor{gnat_rm/the_gnat_library ada-direct-io-c-streams-a-diocst-ads}@anchor{2e4}
@section @cite{Ada.Direct_IO.C_Streams} (@code{a-diocst.ads})
@@ -22736,7 +22926,7 @@ extracted from a file opened on the Ada side, and an Ada file
can be constructed from a stream opened on the C side.
@node Ada Exceptions Is_Null_Occurrence a-einuoc ads,Ada Exceptions Last_Chance_Handler a-elchha ads,Ada Direct_IO C_Streams a-diocst ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id19}@anchor{2ab}@anchor{gnat_rm/the_gnat_library ada-exceptions-is-null-occurrence-a-einuoc-ads}@anchor{2ac}
+@anchor{gnat_rm/the_gnat_library id19}@anchor{2e5}@anchor{gnat_rm/the_gnat_library ada-exceptions-is-null-occurrence-a-einuoc-ads}@anchor{2e6}
@section @cite{Ada.Exceptions.Is_Null_Occurrence} (@code{a-einuoc.ads})
@@ -22750,7 +22940,7 @@ exception occurrence (@cite{Null_Occurrence}) without raising
an exception.
@node Ada Exceptions Last_Chance_Handler a-elchha ads,Ada Exceptions Traceback a-exctra ads,Ada Exceptions Is_Null_Occurrence a-einuoc ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id20}@anchor{2ad}@anchor{gnat_rm/the_gnat_library ada-exceptions-last-chance-handler-a-elchha-ads}@anchor{2ae}
+@anchor{gnat_rm/the_gnat_library id20}@anchor{2e7}@anchor{gnat_rm/the_gnat_library ada-exceptions-last-chance-handler-a-elchha-ads}@anchor{2e8}
@section @cite{Ada.Exceptions.Last_Chance_Handler} (@code{a-elchha.ads})
@@ -22764,7 +22954,7 @@ exceptions (hence the name last chance), and perform clean ups before
terminating the program. Note that this subprogram never returns.
@node Ada Exceptions Traceback a-exctra ads,Ada Sequential_IO C_Streams a-siocst ads,Ada Exceptions Last_Chance_Handler a-elchha ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-exceptions-traceback-a-exctra-ads}@anchor{2af}@anchor{gnat_rm/the_gnat_library id21}@anchor{2b0}
+@anchor{gnat_rm/the_gnat_library ada-exceptions-traceback-a-exctra-ads}@anchor{2e9}@anchor{gnat_rm/the_gnat_library id21}@anchor{2ea}
@section @cite{Ada.Exceptions.Traceback} (@code{a-exctra.ads})
@@ -22777,7 +22967,7 @@ give a traceback array of addresses based on an exception
occurrence.
@node Ada Sequential_IO C_Streams a-siocst ads,Ada Streams Stream_IO C_Streams a-ssicst ads,Ada Exceptions Traceback a-exctra ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-sequential-io-c-streams-a-siocst-ads}@anchor{2b1}@anchor{gnat_rm/the_gnat_library id22}@anchor{2b2}
+@anchor{gnat_rm/the_gnat_library ada-sequential-io-c-streams-a-siocst-ads}@anchor{2eb}@anchor{gnat_rm/the_gnat_library id22}@anchor{2ec}
@section @cite{Ada.Sequential_IO.C_Streams} (@code{a-siocst.ads})
@@ -22792,7 +22982,7 @@ extracted from a file opened on the Ada side, and an Ada file
can be constructed from a stream opened on the C side.
@node Ada Streams Stream_IO C_Streams a-ssicst ads,Ada Strings Unbounded Text_IO a-suteio ads,Ada Sequential_IO C_Streams a-siocst ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id23}@anchor{2b3}@anchor{gnat_rm/the_gnat_library ada-streams-stream-io-c-streams-a-ssicst-ads}@anchor{2b4}
+@anchor{gnat_rm/the_gnat_library id23}@anchor{2ed}@anchor{gnat_rm/the_gnat_library ada-streams-stream-io-c-streams-a-ssicst-ads}@anchor{2ee}
@section @cite{Ada.Streams.Stream_IO.C_Streams} (@code{a-ssicst.ads})
@@ -22807,7 +22997,7 @@ extracted from a file opened on the Ada side, and an Ada file
can be constructed from a stream opened on the C side.
@node Ada Strings Unbounded Text_IO a-suteio ads,Ada Strings Wide_Unbounded Wide_Text_IO a-swuwti ads,Ada Streams Stream_IO C_Streams a-ssicst ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-strings-unbounded-text-io-a-suteio-ads}@anchor{2b5}@anchor{gnat_rm/the_gnat_library id24}@anchor{2b6}
+@anchor{gnat_rm/the_gnat_library ada-strings-unbounded-text-io-a-suteio-ads}@anchor{2ef}@anchor{gnat_rm/the_gnat_library id24}@anchor{2f0}
@section @cite{Ada.Strings.Unbounded.Text_IO} (@code{a-suteio.ads})
@@ -22824,7 +23014,7 @@ strings, avoiding the necessity for an intermediate operation
with ordinary strings.
@node Ada Strings Wide_Unbounded Wide_Text_IO a-swuwti ads,Ada Strings Wide_Wide_Unbounded Wide_Wide_Text_IO a-szuzti ads,Ada Strings Unbounded Text_IO a-suteio ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id25}@anchor{2b7}@anchor{gnat_rm/the_gnat_library ada-strings-wide-unbounded-wide-text-io-a-swuwti-ads}@anchor{2b8}
+@anchor{gnat_rm/the_gnat_library id25}@anchor{2f1}@anchor{gnat_rm/the_gnat_library ada-strings-wide-unbounded-wide-text-io-a-swuwti-ads}@anchor{2f2}
@section @cite{Ada.Strings.Wide_Unbounded.Wide_Text_IO} (@code{a-swuwti.ads})
@@ -22841,7 +23031,7 @@ wide strings, avoiding the necessity for an intermediate operation
with ordinary wide strings.
@node Ada Strings Wide_Wide_Unbounded Wide_Wide_Text_IO a-szuzti ads,Ada Text_IO C_Streams a-tiocst ads,Ada Strings Wide_Unbounded Wide_Text_IO a-swuwti ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-strings-wide-wide-unbounded-wide-wide-text-io-a-szuzti-ads}@anchor{2b9}@anchor{gnat_rm/the_gnat_library id26}@anchor{2ba}
+@anchor{gnat_rm/the_gnat_library ada-strings-wide-wide-unbounded-wide-wide-text-io-a-szuzti-ads}@anchor{2f3}@anchor{gnat_rm/the_gnat_library id26}@anchor{2f4}
@section @cite{Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO} (@code{a-szuzti.ads})
@@ -22858,7 +23048,7 @@ wide wide strings, avoiding the necessity for an intermediate operation
with ordinary wide wide strings.
@node Ada Text_IO C_Streams a-tiocst ads,Ada Text_IO Reset_Standard_Files a-tirsfi ads,Ada Strings Wide_Wide_Unbounded Wide_Wide_Text_IO a-szuzti ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-text-io-c-streams-a-tiocst-ads}@anchor{2bb}@anchor{gnat_rm/the_gnat_library id27}@anchor{2bc}
+@anchor{gnat_rm/the_gnat_library ada-text-io-c-streams-a-tiocst-ads}@anchor{2f5}@anchor{gnat_rm/the_gnat_library id27}@anchor{2f6}
@section @cite{Ada.Text_IO.C_Streams} (@code{a-tiocst.ads})
@@ -22873,7 +23063,7 @@ extracted from a file opened on the Ada side, and an Ada file
can be constructed from a stream opened on the C side.
@node Ada Text_IO Reset_Standard_Files a-tirsfi ads,Ada Wide_Characters Unicode a-wichun ads,Ada Text_IO C_Streams a-tiocst ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id28}@anchor{2bd}@anchor{gnat_rm/the_gnat_library ada-text-io-reset-standard-files-a-tirsfi-ads}@anchor{2be}
+@anchor{gnat_rm/the_gnat_library id28}@anchor{2f7}@anchor{gnat_rm/the_gnat_library ada-text-io-reset-standard-files-a-tirsfi-ads}@anchor{2f8}
@section @cite{Ada.Text_IO.Reset_Standard_Files} (@code{a-tirsfi.ads})
@@ -22888,7 +23078,7 @@ execution (for example a standard input file may be redefined to be
interactive).
@node Ada Wide_Characters Unicode a-wichun ads,Ada Wide_Text_IO C_Streams a-wtcstr ads,Ada Text_IO Reset_Standard_Files a-tirsfi ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id29}@anchor{2bf}@anchor{gnat_rm/the_gnat_library ada-wide-characters-unicode-a-wichun-ads}@anchor{2c0}
+@anchor{gnat_rm/the_gnat_library id29}@anchor{2f9}@anchor{gnat_rm/the_gnat_library ada-wide-characters-unicode-a-wichun-ads}@anchor{2fa}
@section @cite{Ada.Wide_Characters.Unicode} (@code{a-wichun.ads})
@@ -22901,7 +23091,7 @@ This package provides subprograms that allow categorization of
Wide_Character values according to Unicode categories.
@node Ada Wide_Text_IO C_Streams a-wtcstr ads,Ada Wide_Text_IO Reset_Standard_Files a-wrstfi ads,Ada Wide_Characters Unicode a-wichun ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-wide-text-io-c-streams-a-wtcstr-ads}@anchor{2c1}@anchor{gnat_rm/the_gnat_library id30}@anchor{2c2}
+@anchor{gnat_rm/the_gnat_library ada-wide-text-io-c-streams-a-wtcstr-ads}@anchor{2fb}@anchor{gnat_rm/the_gnat_library id30}@anchor{2fc}
@section @cite{Ada.Wide_Text_IO.C_Streams} (@code{a-wtcstr.ads})
@@ -22916,7 +23106,7 @@ extracted from a file opened on the Ada side, and an Ada file
can be constructed from a stream opened on the C side.
@node Ada Wide_Text_IO Reset_Standard_Files a-wrstfi ads,Ada Wide_Wide_Characters Unicode a-zchuni ads,Ada Wide_Text_IO C_Streams a-wtcstr ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library ada-wide-text-io-reset-standard-files-a-wrstfi-ads}@anchor{2c3}@anchor{gnat_rm/the_gnat_library id31}@anchor{2c4}
+@anchor{gnat_rm/the_gnat_library ada-wide-text-io-reset-standard-files-a-wrstfi-ads}@anchor{2fd}@anchor{gnat_rm/the_gnat_library id31}@anchor{2fe}
@section @cite{Ada.Wide_Text_IO.Reset_Standard_Files} (@code{a-wrstfi.ads})
@@ -22931,7 +23121,7 @@ execution (for example a standard input file may be redefined to be
interactive).
@node Ada Wide_Wide_Characters Unicode a-zchuni ads,Ada Wide_Wide_Text_IO C_Streams a-ztcstr ads,Ada Wide_Text_IO Reset_Standard_Files a-wrstfi ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id32}@anchor{2c5}@anchor{gnat_rm/the_gnat_library ada-wide-wide-characters-unicode-a-zchuni-ads}@anchor{2c6}
+@anchor{gnat_rm/the_gnat_library id32}@anchor{2ff}@anchor{gnat_rm/the_gnat_library ada-wide-wide-characters-unicode-a-zchuni-ads}@anchor{300}
@section @cite{Ada.Wide_Wide_Characters.Unicode} (@code{a-zchuni.ads})
@@ -22944,7 +23134,7 @@ This package provides subprograms that allow categorization of
Wide_Wide_Character values according to Unicode categories.
@node Ada Wide_Wide_Text_IO C_Streams a-ztcstr ads,Ada Wide_Wide_Text_IO Reset_Standard_Files a-zrstfi ads,Ada Wide_Wide_Characters Unicode a-zchuni ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id33}@anchor{2c7}@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-c-streams-a-ztcstr-ads}@anchor{2c8}
+@anchor{gnat_rm/the_gnat_library id33}@anchor{301}@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-c-streams-a-ztcstr-ads}@anchor{302}
@section @cite{Ada.Wide_Wide_Text_IO.C_Streams} (@code{a-ztcstr.ads})
@@ -22959,7 +23149,7 @@ extracted from a file opened on the Ada side, and an Ada file
can be constructed from a stream opened on the C side.
@node Ada Wide_Wide_Text_IO Reset_Standard_Files a-zrstfi ads,GNAT Altivec g-altive ads,Ada Wide_Wide_Text_IO C_Streams a-ztcstr ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id34}@anchor{2c9}@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-reset-standard-files-a-zrstfi-ads}@anchor{2ca}
+@anchor{gnat_rm/the_gnat_library id34}@anchor{303}@anchor{gnat_rm/the_gnat_library ada-wide-wide-text-io-reset-standard-files-a-zrstfi-ads}@anchor{304}
@section @cite{Ada.Wide_Wide_Text_IO.Reset_Standard_Files} (@code{a-zrstfi.ads})
@@ -22974,7 +23164,7 @@ change during execution (for example a standard input file may be
redefined to be interactive).
@node GNAT Altivec g-altive ads,GNAT Altivec Conversions g-altcon ads,Ada Wide_Wide_Text_IO Reset_Standard_Files a-zrstfi ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-altivec-g-altive-ads}@anchor{2cb}@anchor{gnat_rm/the_gnat_library id35}@anchor{2cc}
+@anchor{gnat_rm/the_gnat_library gnat-altivec-g-altive-ads}@anchor{305}@anchor{gnat_rm/the_gnat_library id35}@anchor{306}
@section @cite{GNAT.Altivec} (@code{g-altive.ads})
@@ -22987,7 +23177,7 @@ definitions of constants and types common to all the versions of the
binding.
@node GNAT Altivec Conversions g-altcon ads,GNAT Altivec Vector_Operations g-alveop ads,GNAT Altivec g-altive ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id36}@anchor{2cd}@anchor{gnat_rm/the_gnat_library gnat-altivec-conversions-g-altcon-ads}@anchor{2ce}
+@anchor{gnat_rm/the_gnat_library id36}@anchor{307}@anchor{gnat_rm/the_gnat_library gnat-altivec-conversions-g-altcon-ads}@anchor{308}
@section @cite{GNAT.Altivec.Conversions} (@code{g-altcon.ads})
@@ -22998,7 +23188,7 @@ binding.
This package provides the Vector/View conversion routines.
@node GNAT Altivec Vector_Operations g-alveop ads,GNAT Altivec Vector_Types g-alvety ads,GNAT Altivec Conversions g-altcon ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id37}@anchor{2cf}@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-operations-g-alveop-ads}@anchor{2d0}
+@anchor{gnat_rm/the_gnat_library id37}@anchor{309}@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-operations-g-alveop-ads}@anchor{30a}
@section @cite{GNAT.Altivec.Vector_Operations} (@code{g-alveop.ads})
@@ -23012,7 +23202,7 @@ library. The hard binding is provided as a separate package. This unit
is common to both bindings.
@node GNAT Altivec Vector_Types g-alvety ads,GNAT Altivec Vector_Views g-alvevi ads,GNAT Altivec Vector_Operations g-alveop ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-types-g-alvety-ads}@anchor{2d1}@anchor{gnat_rm/the_gnat_library id38}@anchor{2d2}
+@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-types-g-alvety-ads}@anchor{30b}@anchor{gnat_rm/the_gnat_library id38}@anchor{30c}
@section @cite{GNAT.Altivec.Vector_Types} (@code{g-alvety.ads})
@@ -23024,7 +23214,7 @@ This package exposes the various vector types part of the Ada binding
to AltiVec facilities.
@node GNAT Altivec Vector_Views g-alvevi ads,GNAT Array_Split g-arrspl ads,GNAT Altivec Vector_Types g-alvety ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-views-g-alvevi-ads}@anchor{2d3}@anchor{gnat_rm/the_gnat_library id39}@anchor{2d4}
+@anchor{gnat_rm/the_gnat_library gnat-altivec-vector-views-g-alvevi-ads}@anchor{30d}@anchor{gnat_rm/the_gnat_library id39}@anchor{30e}
@section @cite{GNAT.Altivec.Vector_Views} (@code{g-alvevi.ads})
@@ -23039,7 +23229,7 @@ vector elements and provides a simple way to initialize vector
objects.
@node GNAT Array_Split g-arrspl ads,GNAT AWK g-awk ads,GNAT Altivec Vector_Views g-alvevi ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-array-split-g-arrspl-ads}@anchor{2d5}@anchor{gnat_rm/the_gnat_library id40}@anchor{2d6}
+@anchor{gnat_rm/the_gnat_library gnat-array-split-g-arrspl-ads}@anchor{30f}@anchor{gnat_rm/the_gnat_library id40}@anchor{310}
@section @cite{GNAT.Array_Split} (@code{g-arrspl.ads})
@@ -23052,7 +23242,7 @@ an array wherever the separators appear, and provide direct access
to the resulting slices.
@node GNAT AWK g-awk ads,GNAT Bind_Environment g-binenv ads,GNAT Array_Split g-arrspl ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id41}@anchor{2d7}@anchor{gnat_rm/the_gnat_library gnat-awk-g-awk-ads}@anchor{2d8}
+@anchor{gnat_rm/the_gnat_library id41}@anchor{311}@anchor{gnat_rm/the_gnat_library gnat-awk-g-awk-ads}@anchor{312}
@section @cite{GNAT.AWK} (@code{g-awk.ads})
@@ -23067,7 +23257,7 @@ or more files containing formatted data. The file is viewed as a database
where each record is a line and a field is a data element in this line.
@node GNAT Bind_Environment g-binenv ads,GNAT Bounded_Buffers g-boubuf ads,GNAT AWK g-awk ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-bind-environment-g-binenv-ads}@anchor{2d9}@anchor{gnat_rm/the_gnat_library id42}@anchor{2da}
+@anchor{gnat_rm/the_gnat_library gnat-bind-environment-g-binenv-ads}@anchor{313}@anchor{gnat_rm/the_gnat_library id42}@anchor{314}
@section @cite{GNAT.Bind_Environment} (@code{g-binenv.ads})
@@ -23080,7 +23270,7 @@ These associations can be specified using the @cite{-V} binder command
line switch.
@node GNAT Bounded_Buffers g-boubuf ads,GNAT Bounded_Mailboxes g-boumai ads,GNAT Bind_Environment g-binenv ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-bounded-buffers-g-boubuf-ads}@anchor{2db}@anchor{gnat_rm/the_gnat_library id43}@anchor{2dc}
+@anchor{gnat_rm/the_gnat_library gnat-bounded-buffers-g-boubuf-ads}@anchor{315}@anchor{gnat_rm/the_gnat_library id43}@anchor{316}
@section @cite{GNAT.Bounded_Buffers} (@code{g-boubuf.ads})
@@ -23095,7 +23285,7 @@ useful directly or as parts of the implementations of other abstractions,
such as mailboxes.
@node GNAT Bounded_Mailboxes g-boumai ads,GNAT Bubble_Sort g-bubsor ads,GNAT Bounded_Buffers g-boubuf ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id44}@anchor{2dd}@anchor{gnat_rm/the_gnat_library gnat-bounded-mailboxes-g-boumai-ads}@anchor{2de}
+@anchor{gnat_rm/the_gnat_library id44}@anchor{317}@anchor{gnat_rm/the_gnat_library gnat-bounded-mailboxes-g-boumai-ads}@anchor{318}
@section @cite{GNAT.Bounded_Mailboxes} (@code{g-boumai.ads})
@@ -23108,7 +23298,7 @@ such as mailboxes.
Provides a thread-safe asynchronous intertask mailbox communication facility.
@node GNAT Bubble_Sort g-bubsor ads,GNAT Bubble_Sort_A g-busora ads,GNAT Bounded_Mailboxes g-boumai ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-bubsor-ads}@anchor{2df}@anchor{gnat_rm/the_gnat_library id45}@anchor{2e0}
+@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-bubsor-ads}@anchor{319}@anchor{gnat_rm/the_gnat_library id45}@anchor{31a}
@section @cite{GNAT.Bubble_Sort} (@code{g-bubsor.ads})
@@ -23123,7 +23313,7 @@ data items. Exchange and comparison procedures are provided by passing
access-to-procedure values.
@node GNAT Bubble_Sort_A g-busora ads,GNAT Bubble_Sort_G g-busorg ads,GNAT Bubble_Sort g-bubsor ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id46}@anchor{2e1}@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-a-g-busora-ads}@anchor{2e2}
+@anchor{gnat_rm/the_gnat_library id46}@anchor{31b}@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-a-g-busora-ads}@anchor{31c}
@section @cite{GNAT.Bubble_Sort_A} (@code{g-busora.ads})
@@ -23139,7 +23329,7 @@ access-to-procedure values. This is an older version, retained for
compatibility. Usually @cite{GNAT.Bubble_Sort} will be preferable.
@node GNAT Bubble_Sort_G g-busorg ads,GNAT Byte_Order_Mark g-byorma ads,GNAT Bubble_Sort_A g-busora ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id47}@anchor{2e3}@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-g-busorg-ads}@anchor{2e4}
+@anchor{gnat_rm/the_gnat_library id47}@anchor{31d}@anchor{gnat_rm/the_gnat_library gnat-bubble-sort-g-g-busorg-ads}@anchor{31e}
@section @cite{GNAT.Bubble_Sort_G} (@code{g-busorg.ads})
@@ -23155,7 +23345,7 @@ if the procedures can be inlined, at the expense of duplicating code for
multiple instantiations.
@node GNAT Byte_Order_Mark g-byorma ads,GNAT Byte_Swapping g-bytswa ads,GNAT Bubble_Sort_G g-busorg ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-byte-order-mark-g-byorma-ads}@anchor{2e5}@anchor{gnat_rm/the_gnat_library id48}@anchor{2e6}
+@anchor{gnat_rm/the_gnat_library gnat-byte-order-mark-g-byorma-ads}@anchor{31f}@anchor{gnat_rm/the_gnat_library id48}@anchor{320}
@section @cite{GNAT.Byte_Order_Mark} (@code{g-byorma.ads})
@@ -23171,7 +23361,7 @@ the encoding of the string. The routine includes detection of special XML
sequences for various UCS input formats.
@node GNAT Byte_Swapping g-bytswa ads,GNAT Calendar g-calend ads,GNAT Byte_Order_Mark g-byorma ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-byte-swapping-g-bytswa-ads}@anchor{2e7}@anchor{gnat_rm/the_gnat_library id49}@anchor{2e8}
+@anchor{gnat_rm/the_gnat_library gnat-byte-swapping-g-bytswa-ads}@anchor{321}@anchor{gnat_rm/the_gnat_library id49}@anchor{322}
@section @cite{GNAT.Byte_Swapping} (@code{g-bytswa.ads})
@@ -23185,7 +23375,7 @@ General routines for swapping the bytes in 2-, 4-, and 8-byte quantities.
Machine-specific implementations are available in some cases.
@node GNAT Calendar g-calend ads,GNAT Calendar Time_IO g-catiio ads,GNAT Byte_Swapping g-bytswa ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id50}@anchor{2e9}@anchor{gnat_rm/the_gnat_library gnat-calendar-g-calend-ads}@anchor{2ea}
+@anchor{gnat_rm/the_gnat_library id50}@anchor{323}@anchor{gnat_rm/the_gnat_library gnat-calendar-g-calend-ads}@anchor{324}
@section @cite{GNAT.Calendar} (@code{g-calend.ads})
@@ -23199,7 +23389,7 @@ Also provides conversion of @cite{Ada.Calendar.Time} values to and from the
C @cite{timeval} format.
@node GNAT Calendar Time_IO g-catiio ads,GNAT CRC32 g-crc32 ads,GNAT Calendar g-calend ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-calendar-time-io-g-catiio-ads}@anchor{2eb}@anchor{gnat_rm/the_gnat_library id51}@anchor{2ec}
+@anchor{gnat_rm/the_gnat_library gnat-calendar-time-io-g-catiio-ads}@anchor{325}@anchor{gnat_rm/the_gnat_library id51}@anchor{326}
@section @cite{GNAT.Calendar.Time_IO} (@code{g-catiio.ads})
@@ -23210,7 +23400,7 @@ C @cite{timeval} format.
@geindex GNAT.Calendar.Time_IO (g-catiio.ads)
@node GNAT CRC32 g-crc32 ads,GNAT Case_Util g-casuti ads,GNAT Calendar Time_IO g-catiio ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id52}@anchor{2ed}@anchor{gnat_rm/the_gnat_library gnat-crc32-g-crc32-ads}@anchor{2ee}
+@anchor{gnat_rm/the_gnat_library id52}@anchor{327}@anchor{gnat_rm/the_gnat_library gnat-crc32-g-crc32-ads}@anchor{328}
@section @cite{GNAT.CRC32} (@code{g-crc32.ads})
@@ -23227,7 +23417,7 @@ of this algorithm see
Aug. 1988. Sarwate, D.V.
@node GNAT Case_Util g-casuti ads,GNAT CGI g-cgi ads,GNAT CRC32 g-crc32 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-case-util-g-casuti-ads}@anchor{2ef}@anchor{gnat_rm/the_gnat_library id53}@anchor{2f0}
+@anchor{gnat_rm/the_gnat_library gnat-case-util-g-casuti-ads}@anchor{329}@anchor{gnat_rm/the_gnat_library id53}@anchor{32a}
@section @cite{GNAT.Case_Util} (@code{g-casuti.ads})
@@ -23242,7 +23432,7 @@ without the overhead of the full casing tables
in @cite{Ada.Characters.Handling}.
@node GNAT CGI g-cgi ads,GNAT CGI Cookie g-cgicoo ads,GNAT Case_Util g-casuti ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id54}@anchor{2f1}@anchor{gnat_rm/the_gnat_library gnat-cgi-g-cgi-ads}@anchor{2f2}
+@anchor{gnat_rm/the_gnat_library id54}@anchor{32b}@anchor{gnat_rm/the_gnat_library gnat-cgi-g-cgi-ads}@anchor{32c}
@section @cite{GNAT.CGI} (@code{g-cgi.ads})
@@ -23257,7 +23447,7 @@ builds a table whose index is the key and provides some services to deal
with this table.
@node GNAT CGI Cookie g-cgicoo ads,GNAT CGI Debug g-cgideb ads,GNAT CGI g-cgi ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-cgi-cookie-g-cgicoo-ads}@anchor{2f3}@anchor{gnat_rm/the_gnat_library id55}@anchor{2f4}
+@anchor{gnat_rm/the_gnat_library gnat-cgi-cookie-g-cgicoo-ads}@anchor{32d}@anchor{gnat_rm/the_gnat_library id55}@anchor{32e}
@section @cite{GNAT.CGI.Cookie} (@code{g-cgicoo.ads})
@@ -23272,7 +23462,7 @@ Common Gateway Interface (CGI). It exports services to deal with Web
cookies (piece of information kept in the Web client software).
@node GNAT CGI Debug g-cgideb ads,GNAT Command_Line g-comlin ads,GNAT CGI Cookie g-cgicoo ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-cgi-debug-g-cgideb-ads}@anchor{2f5}@anchor{gnat_rm/the_gnat_library id56}@anchor{2f6}
+@anchor{gnat_rm/the_gnat_library gnat-cgi-debug-g-cgideb-ads}@anchor{32f}@anchor{gnat_rm/the_gnat_library id56}@anchor{330}
@section @cite{GNAT.CGI.Debug} (@code{g-cgideb.ads})
@@ -23284,7 +23474,7 @@ This is a package to help debugging CGI (Common Gateway Interface)
programs written in Ada.
@node GNAT Command_Line g-comlin ads,GNAT Compiler_Version g-comver ads,GNAT CGI Debug g-cgideb ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id57}@anchor{2f7}@anchor{gnat_rm/the_gnat_library gnat-command-line-g-comlin-ads}@anchor{2f8}
+@anchor{gnat_rm/the_gnat_library id57}@anchor{331}@anchor{gnat_rm/the_gnat_library gnat-command-line-g-comlin-ads}@anchor{332}
@section @cite{GNAT.Command_Line} (@code{g-comlin.ads})
@@ -23297,7 +23487,7 @@ including the ability to scan for named switches with optional parameters
and expand file names using wild card notations.
@node GNAT Compiler_Version g-comver ads,GNAT Ctrl_C g-ctrl_c ads,GNAT Command_Line g-comlin ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-compiler-version-g-comver-ads}@anchor{2f9}@anchor{gnat_rm/the_gnat_library id58}@anchor{2fa}
+@anchor{gnat_rm/the_gnat_library gnat-compiler-version-g-comver-ads}@anchor{333}@anchor{gnat_rm/the_gnat_library id58}@anchor{334}
@section @cite{GNAT.Compiler_Version} (@code{g-comver.ads})
@@ -23315,7 +23505,7 @@ of the compiler if a consistent tool set is used to compile all units
of a partition).
@node GNAT Ctrl_C g-ctrl_c ads,GNAT Current_Exception g-curexc ads,GNAT Compiler_Version g-comver ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-ctrl-c-g-ctrl-c-ads}@anchor{2fb}@anchor{gnat_rm/the_gnat_library id59}@anchor{2fc}
+@anchor{gnat_rm/the_gnat_library gnat-ctrl-c-g-ctrl-c-ads}@anchor{335}@anchor{gnat_rm/the_gnat_library id59}@anchor{336}
@section @cite{GNAT.Ctrl_C} (@code{g-ctrl_c.ads})
@@ -23326,7 +23516,7 @@ of a partition).
Provides a simple interface to handle Ctrl-C keyboard events.
@node GNAT Current_Exception g-curexc ads,GNAT Debug_Pools g-debpoo ads,GNAT Ctrl_C g-ctrl_c ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id60}@anchor{2fd}@anchor{gnat_rm/the_gnat_library gnat-current-exception-g-curexc-ads}@anchor{2fe}
+@anchor{gnat_rm/the_gnat_library id60}@anchor{337}@anchor{gnat_rm/the_gnat_library gnat-current-exception-g-curexc-ads}@anchor{338}
@section @cite{GNAT.Current_Exception} (@code{g-curexc.ads})
@@ -23343,7 +23533,7 @@ This is particularly useful in simulating typical facilities for
obtaining information about exceptions provided by Ada 83 compilers.
@node GNAT Debug_Pools g-debpoo ads,GNAT Debug_Utilities g-debuti ads,GNAT Current_Exception g-curexc ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-debug-pools-g-debpoo-ads}@anchor{2ff}@anchor{gnat_rm/the_gnat_library id61}@anchor{300}
+@anchor{gnat_rm/the_gnat_library gnat-debug-pools-g-debpoo-ads}@anchor{339}@anchor{gnat_rm/the_gnat_library id61}@anchor{33a}
@section @cite{GNAT.Debug_Pools} (@code{g-debpoo.ads})
@@ -23360,7 +23550,7 @@ problems.
See @cite{The GNAT Debug_Pool Facility} section in the @cite{GNAT User's Guide}.
@node GNAT Debug_Utilities g-debuti ads,GNAT Decode_String g-decstr ads,GNAT Debug_Pools g-debpoo ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-debug-utilities-g-debuti-ads}@anchor{301}@anchor{gnat_rm/the_gnat_library id62}@anchor{302}
+@anchor{gnat_rm/the_gnat_library gnat-debug-utilities-g-debuti-ads}@anchor{33b}@anchor{gnat_rm/the_gnat_library id62}@anchor{33c}
@section @cite{GNAT.Debug_Utilities} (@code{g-debuti.ads})
@@ -23373,7 +23563,7 @@ to and from string images of address values. Supports both C and Ada formats
for hexadecimal literals.
@node GNAT Decode_String g-decstr ads,GNAT Decode_UTF8_String g-deutst ads,GNAT Debug_Utilities g-debuti ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-decode-string-g-decstr-ads}@anchor{303}@anchor{gnat_rm/the_gnat_library id63}@anchor{304}
+@anchor{gnat_rm/the_gnat_library gnat-decode-string-g-decstr-ads}@anchor{33d}@anchor{gnat_rm/the_gnat_library id63}@anchor{33e}
@section @cite{GNAT.Decode_String} (@code{g-decstr.ads})
@@ -23397,7 +23587,7 @@ Useful in conjunction with Unicode character coding. Note there is a
preinstantiation for UTF-8. See next entry.
@node GNAT Decode_UTF8_String g-deutst ads,GNAT Directory_Operations g-dirope ads,GNAT Decode_String g-decstr ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-decode-utf8-string-g-deutst-ads}@anchor{305}@anchor{gnat_rm/the_gnat_library id64}@anchor{306}
+@anchor{gnat_rm/the_gnat_library gnat-decode-utf8-string-g-deutst-ads}@anchor{33f}@anchor{gnat_rm/the_gnat_library id64}@anchor{340}
@section @cite{GNAT.Decode_UTF8_String} (@code{g-deutst.ads})
@@ -23418,7 +23608,7 @@ preinstantiation for UTF-8. See next entry.
A preinstantiation of GNAT.Decode_Strings for UTF-8 encoding.
@node GNAT Directory_Operations g-dirope ads,GNAT Directory_Operations Iteration g-diopit ads,GNAT Decode_UTF8_String g-deutst ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id65}@anchor{307}@anchor{gnat_rm/the_gnat_library gnat-directory-operations-g-dirope-ads}@anchor{308}
+@anchor{gnat_rm/the_gnat_library id65}@anchor{341}@anchor{gnat_rm/the_gnat_library gnat-directory-operations-g-dirope-ads}@anchor{342}
@section @cite{GNAT.Directory_Operations} (@code{g-dirope.ads})
@@ -23431,7 +23621,7 @@ the current directory, making new directories, and scanning the files in a
directory.
@node GNAT Directory_Operations Iteration g-diopit ads,GNAT Dynamic_HTables g-dynhta ads,GNAT Directory_Operations g-dirope ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id66}@anchor{309}@anchor{gnat_rm/the_gnat_library gnat-directory-operations-iteration-g-diopit-ads}@anchor{30a}
+@anchor{gnat_rm/the_gnat_library id66}@anchor{343}@anchor{gnat_rm/the_gnat_library gnat-directory-operations-iteration-g-diopit-ads}@anchor{344}
@section @cite{GNAT.Directory_Operations.Iteration} (@code{g-diopit.ads})
@@ -23443,7 +23633,7 @@ A child unit of GNAT.Directory_Operations providing additional operations
for iterating through directories.
@node GNAT Dynamic_HTables g-dynhta ads,GNAT Dynamic_Tables g-dyntab ads,GNAT Directory_Operations Iteration g-diopit ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id67}@anchor{30b}@anchor{gnat_rm/the_gnat_library gnat-dynamic-htables-g-dynhta-ads}@anchor{30c}
+@anchor{gnat_rm/the_gnat_library id67}@anchor{345}@anchor{gnat_rm/the_gnat_library gnat-dynamic-htables-g-dynhta-ads}@anchor{346}
@section @cite{GNAT.Dynamic_HTables} (@code{g-dynhta.ads})
@@ -23461,7 +23651,7 @@ dynamic instances of the hash table, while an instantiation of
@cite{GNAT.HTable} creates a single instance of the hash table.
@node GNAT Dynamic_Tables g-dyntab ads,GNAT Encode_String g-encstr ads,GNAT Dynamic_HTables g-dynhta ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-dynamic-tables-g-dyntab-ads}@anchor{30d}@anchor{gnat_rm/the_gnat_library id68}@anchor{30e}
+@anchor{gnat_rm/the_gnat_library gnat-dynamic-tables-g-dyntab-ads}@anchor{347}@anchor{gnat_rm/the_gnat_library id68}@anchor{348}
@section @cite{GNAT.Dynamic_Tables} (@code{g-dyntab.ads})
@@ -23481,7 +23671,7 @@ dynamic instances of the table, while an instantiation of
@cite{GNAT.Table} creates a single instance of the table type.
@node GNAT Encode_String g-encstr ads,GNAT Encode_UTF8_String g-enutst ads,GNAT Dynamic_Tables g-dyntab ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id69}@anchor{30f}@anchor{gnat_rm/the_gnat_library gnat-encode-string-g-encstr-ads}@anchor{310}
+@anchor{gnat_rm/the_gnat_library id69}@anchor{349}@anchor{gnat_rm/the_gnat_library gnat-encode-string-g-encstr-ads}@anchor{34a}
@section @cite{GNAT.Encode_String} (@code{g-encstr.ads})
@@ -23503,7 +23693,7 @@ encoding method. Useful in conjunction with Unicode character coding.
Note there is a preinstantiation for UTF-8. See next entry.
@node GNAT Encode_UTF8_String g-enutst ads,GNAT Exception_Actions g-excact ads,GNAT Encode_String g-encstr ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-encode-utf8-string-g-enutst-ads}@anchor{311}@anchor{gnat_rm/the_gnat_library id70}@anchor{312}
+@anchor{gnat_rm/the_gnat_library gnat-encode-utf8-string-g-enutst-ads}@anchor{34b}@anchor{gnat_rm/the_gnat_library id70}@anchor{34c}
@section @cite{GNAT.Encode_UTF8_String} (@code{g-enutst.ads})
@@ -23524,7 +23714,7 @@ Note there is a preinstantiation for UTF-8. See next entry.
A preinstantiation of GNAT.Encode_Strings for UTF-8 encoding.
@node GNAT Exception_Actions g-excact ads,GNAT Exception_Traces g-exctra ads,GNAT Encode_UTF8_String g-enutst ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id71}@anchor{313}@anchor{gnat_rm/the_gnat_library gnat-exception-actions-g-excact-ads}@anchor{314}
+@anchor{gnat_rm/the_gnat_library id71}@anchor{34d}@anchor{gnat_rm/the_gnat_library gnat-exception-actions-g-excact-ads}@anchor{34e}
@section @cite{GNAT.Exception_Actions} (@code{g-excact.ads})
@@ -23537,7 +23727,7 @@ for specific exceptions, or when any exception is raised. This
can be used for instance to force a core dump to ease debugging.
@node GNAT Exception_Traces g-exctra ads,GNAT Exceptions g-expect ads,GNAT Exception_Actions g-excact ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id72}@anchor{315}@anchor{gnat_rm/the_gnat_library gnat-exception-traces-g-exctra-ads}@anchor{316}
+@anchor{gnat_rm/the_gnat_library id72}@anchor{34f}@anchor{gnat_rm/the_gnat_library gnat-exception-traces-g-exctra-ads}@anchor{350}
@section @cite{GNAT.Exception_Traces} (@code{g-exctra.ads})
@@ -23551,7 +23741,7 @@ Provides an interface allowing to control automatic output upon exception
occurrences.
@node GNAT Exceptions g-expect ads,GNAT Expect g-expect ads,GNAT Exception_Traces g-exctra ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id73}@anchor{317}@anchor{gnat_rm/the_gnat_library gnat-exceptions-g-expect-ads}@anchor{318}
+@anchor{gnat_rm/the_gnat_library id73}@anchor{351}@anchor{gnat_rm/the_gnat_library gnat-exceptions-g-expect-ads}@anchor{352}
@section @cite{GNAT.Exceptions} (@code{g-expect.ads})
@@ -23572,7 +23762,7 @@ predefined exceptions, and for example allow raising
@cite{Constraint_Error} with a message from a pure subprogram.
@node GNAT Expect g-expect ads,GNAT Expect TTY g-exptty ads,GNAT Exceptions g-expect ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-expect-g-expect-ads}@anchor{319}@anchor{gnat_rm/the_gnat_library id74}@anchor{31a}
+@anchor{gnat_rm/the_gnat_library gnat-expect-g-expect-ads}@anchor{353}@anchor{gnat_rm/the_gnat_library id74}@anchor{354}
@section @cite{GNAT.Expect} (@code{g-expect.ads})
@@ -23588,7 +23778,7 @@ It is not implemented for cross ports, and in particular is not
implemented for VxWorks or LynxOS.
@node GNAT Expect TTY g-exptty ads,GNAT Float_Control g-flocon ads,GNAT Expect g-expect ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-expect-tty-g-exptty-ads}@anchor{31b}@anchor{gnat_rm/the_gnat_library id75}@anchor{31c}
+@anchor{gnat_rm/the_gnat_library gnat-expect-tty-g-exptty-ads}@anchor{355}@anchor{gnat_rm/the_gnat_library id75}@anchor{356}
@section @cite{GNAT.Expect.TTY} (@code{g-exptty.ads})
@@ -23600,7 +23790,7 @@ ports. It is not implemented for cross ports, and
in particular is not implemented for VxWorks or LynxOS.
@node GNAT Float_Control g-flocon ads,GNAT Formatted_String g-forstr ads,GNAT Expect TTY g-exptty ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id76}@anchor{31d}@anchor{gnat_rm/the_gnat_library gnat-float-control-g-flocon-ads}@anchor{31e}
+@anchor{gnat_rm/the_gnat_library id76}@anchor{357}@anchor{gnat_rm/the_gnat_library gnat-float-control-g-flocon-ads}@anchor{358}
@section @cite{GNAT.Float_Control} (@code{g-flocon.ads})
@@ -23614,7 +23804,7 @@ library calls may cause this mode to be modified, and the Reset procedure
in this package can be used to reestablish the required mode.
@node GNAT Formatted_String g-forstr ads,GNAT Heap_Sort g-heasor ads,GNAT Float_Control g-flocon ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-formatted-string-g-forstr-ads}@anchor{31f}@anchor{gnat_rm/the_gnat_library id77}@anchor{320}
+@anchor{gnat_rm/the_gnat_library gnat-formatted-string-g-forstr-ads}@anchor{359}@anchor{gnat_rm/the_gnat_library id77}@anchor{35a}
@section @cite{GNAT.Formatted_String} (@code{g-forstr.ads})
@@ -23629,7 +23819,7 @@ derived from Integer, Float or enumerations as values for the
formatted string.
@node GNAT Heap_Sort g-heasor ads,GNAT Heap_Sort_A g-hesora ads,GNAT Formatted_String g-forstr ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-heasor-ads}@anchor{321}@anchor{gnat_rm/the_gnat_library id78}@anchor{322}
+@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-heasor-ads}@anchor{35b}@anchor{gnat_rm/the_gnat_library id78}@anchor{35c}
@section @cite{GNAT.Heap_Sort} (@code{g-heasor.ads})
@@ -23643,7 +23833,7 @@ access-to-procedure values. The algorithm used is a modified heap sort
that performs approximately N*log(N) comparisons in the worst case.
@node GNAT Heap_Sort_A g-hesora ads,GNAT Heap_Sort_G g-hesorg ads,GNAT Heap_Sort g-heasor ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id79}@anchor{323}@anchor{gnat_rm/the_gnat_library gnat-heap-sort-a-g-hesora-ads}@anchor{324}
+@anchor{gnat_rm/the_gnat_library id79}@anchor{35d}@anchor{gnat_rm/the_gnat_library gnat-heap-sort-a-g-hesora-ads}@anchor{35e}
@section @cite{GNAT.Heap_Sort_A} (@code{g-hesora.ads})
@@ -23659,7 +23849,7 @@ This differs from @cite{GNAT.Heap_Sort} in having a less convenient
interface, but may be slightly more efficient.
@node GNAT Heap_Sort_G g-hesorg ads,GNAT HTable g-htable ads,GNAT Heap_Sort_A g-hesora ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id80}@anchor{325}@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-g-hesorg-ads}@anchor{326}
+@anchor{gnat_rm/the_gnat_library id80}@anchor{35f}@anchor{gnat_rm/the_gnat_library gnat-heap-sort-g-g-hesorg-ads}@anchor{360}
@section @cite{GNAT.Heap_Sort_G} (@code{g-hesorg.ads})
@@ -23673,7 +23863,7 @@ if the procedures can be inlined, at the expense of duplicating code for
multiple instantiations.
@node GNAT HTable g-htable ads,GNAT IO g-io ads,GNAT Heap_Sort_G g-hesorg ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id81}@anchor{327}@anchor{gnat_rm/the_gnat_library gnat-htable-g-htable-ads}@anchor{328}
+@anchor{gnat_rm/the_gnat_library id81}@anchor{361}@anchor{gnat_rm/the_gnat_library gnat-htable-g-htable-ads}@anchor{362}
@section @cite{GNAT.HTable} (@code{g-htable.ads})
@@ -23686,7 +23876,7 @@ data. Provides two approaches, one a simple static approach, and the other
allowing arbitrary dynamic hash tables.
@node GNAT IO g-io ads,GNAT IO_Aux g-io_aux ads,GNAT HTable g-htable ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id82}@anchor{329}@anchor{gnat_rm/the_gnat_library gnat-io-g-io-ads}@anchor{32a}
+@anchor{gnat_rm/the_gnat_library id82}@anchor{363}@anchor{gnat_rm/the_gnat_library gnat-io-g-io-ads}@anchor{364}
@section @cite{GNAT.IO} (@code{g-io.ads})
@@ -23702,7 +23892,7 @@ Standard_Input, and writing characters, strings and integers to either
Standard_Output or Standard_Error.
@node GNAT IO_Aux g-io_aux ads,GNAT Lock_Files g-locfil ads,GNAT IO g-io ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id83}@anchor{32b}@anchor{gnat_rm/the_gnat_library gnat-io-aux-g-io-aux-ads}@anchor{32c}
+@anchor{gnat_rm/the_gnat_library id83}@anchor{365}@anchor{gnat_rm/the_gnat_library gnat-io-aux-g-io-aux-ads}@anchor{366}
@section @cite{GNAT.IO_Aux} (@code{g-io_aux.ads})
@@ -23716,7 +23906,7 @@ Provides some auxiliary functions for use with Text_IO, including a test
for whether a file exists, and functions for reading a line of text.
@node GNAT Lock_Files g-locfil ads,GNAT MBBS_Discrete_Random g-mbdira ads,GNAT IO_Aux g-io_aux ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-lock-files-g-locfil-ads}@anchor{32d}@anchor{gnat_rm/the_gnat_library id84}@anchor{32e}
+@anchor{gnat_rm/the_gnat_library gnat-lock-files-g-locfil-ads}@anchor{367}@anchor{gnat_rm/the_gnat_library id84}@anchor{368}
@section @cite{GNAT.Lock_Files} (@code{g-locfil.ads})
@@ -23730,7 +23920,7 @@ Provides a general interface for using files as locks. Can be used for
providing program level synchronization.
@node GNAT MBBS_Discrete_Random g-mbdira ads,GNAT MBBS_Float_Random g-mbflra ads,GNAT Lock_Files g-locfil ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id85}@anchor{32f}@anchor{gnat_rm/the_gnat_library gnat-mbbs-discrete-random-g-mbdira-ads}@anchor{330}
+@anchor{gnat_rm/the_gnat_library id85}@anchor{369}@anchor{gnat_rm/the_gnat_library gnat-mbbs-discrete-random-g-mbdira-ads}@anchor{36a}
@section @cite{GNAT.MBBS_Discrete_Random} (@code{g-mbdira.ads})
@@ -23742,7 +23932,7 @@ The original implementation of @cite{Ada.Numerics.Discrete_Random}. Uses
a modified version of the Blum-Blum-Shub generator.
@node GNAT MBBS_Float_Random g-mbflra ads,GNAT MD5 g-md5 ads,GNAT MBBS_Discrete_Random g-mbdira ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id86}@anchor{331}@anchor{gnat_rm/the_gnat_library gnat-mbbs-float-random-g-mbflra-ads}@anchor{332}
+@anchor{gnat_rm/the_gnat_library id86}@anchor{36b}@anchor{gnat_rm/the_gnat_library gnat-mbbs-float-random-g-mbflra-ads}@anchor{36c}
@section @cite{GNAT.MBBS_Float_Random} (@code{g-mbflra.ads})
@@ -23754,7 +23944,7 @@ The original implementation of @cite{Ada.Numerics.Float_Random}. Uses
a modified version of the Blum-Blum-Shub generator.
@node GNAT MD5 g-md5 ads,GNAT Memory_Dump g-memdum ads,GNAT MBBS_Float_Random g-mbflra ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id87}@anchor{333}@anchor{gnat_rm/the_gnat_library gnat-md5-g-md5-ads}@anchor{334}
+@anchor{gnat_rm/the_gnat_library id87}@anchor{36d}@anchor{gnat_rm/the_gnat_library gnat-md5-g-md5-ads}@anchor{36e}
@section @cite{GNAT.MD5} (@code{g-md5.ads})
@@ -23767,7 +23957,7 @@ the HMAC-MD5 message authentication function as described in RFC 2104 and
FIPS PUB 198.
@node GNAT Memory_Dump g-memdum ads,GNAT Most_Recent_Exception g-moreex ads,GNAT MD5 g-md5 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id88}@anchor{335}@anchor{gnat_rm/the_gnat_library gnat-memory-dump-g-memdum-ads}@anchor{336}
+@anchor{gnat_rm/the_gnat_library id88}@anchor{36f}@anchor{gnat_rm/the_gnat_library gnat-memory-dump-g-memdum-ads}@anchor{370}
@section @cite{GNAT.Memory_Dump} (@code{g-memdum.ads})
@@ -23780,7 +23970,7 @@ standard output or standard error files. Uses GNAT.IO for actual
output.
@node GNAT Most_Recent_Exception g-moreex ads,GNAT OS_Lib g-os_lib ads,GNAT Memory_Dump g-memdum ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id89}@anchor{337}@anchor{gnat_rm/the_gnat_library gnat-most-recent-exception-g-moreex-ads}@anchor{338}
+@anchor{gnat_rm/the_gnat_library id89}@anchor{371}@anchor{gnat_rm/the_gnat_library gnat-most-recent-exception-g-moreex-ads}@anchor{372}
@section @cite{GNAT.Most_Recent_Exception} (@code{g-moreex.ads})
@@ -23794,7 +23984,7 @@ various logging purposes, including duplicating functionality of some
Ada 83 implementation dependent extensions.
@node GNAT OS_Lib g-os_lib ads,GNAT Perfect_Hash_Generators g-pehage ads,GNAT Most_Recent_Exception g-moreex ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id90}@anchor{339}@anchor{gnat_rm/the_gnat_library gnat-os-lib-g-os-lib-ads}@anchor{33a}
+@anchor{gnat_rm/the_gnat_library id90}@anchor{373}@anchor{gnat_rm/the_gnat_library gnat-os-lib-g-os-lib-ads}@anchor{374}
@section @cite{GNAT.OS_Lib} (@code{g-os_lib.ads})
@@ -23810,7 +24000,7 @@ including a portable spawn procedure, and access to environment variables
and error return codes.
@node GNAT Perfect_Hash_Generators g-pehage ads,GNAT Random_Numbers g-rannum ads,GNAT OS_Lib g-os_lib ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-perfect-hash-generators-g-pehage-ads}@anchor{33b}@anchor{gnat_rm/the_gnat_library id91}@anchor{33c}
+@anchor{gnat_rm/the_gnat_library gnat-perfect-hash-generators-g-pehage-ads}@anchor{375}@anchor{gnat_rm/the_gnat_library id91}@anchor{376}
@section @cite{GNAT.Perfect_Hash_Generators} (@code{g-pehage.ads})
@@ -23828,7 +24018,7 @@ hashcode are in the same order. These hashing functions are very
convenient for use with realtime applications.
@node GNAT Random_Numbers g-rannum ads,GNAT Regexp g-regexp ads,GNAT Perfect_Hash_Generators g-pehage ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-random-numbers-g-rannum-ads}@anchor{33d}@anchor{gnat_rm/the_gnat_library id92}@anchor{33e}
+@anchor{gnat_rm/the_gnat_library gnat-random-numbers-g-rannum-ads}@anchor{377}@anchor{gnat_rm/the_gnat_library id92}@anchor{378}
@section @cite{GNAT.Random_Numbers} (@code{g-rannum.ads})
@@ -23840,7 +24030,7 @@ Provides random number capabilities which extend those available in the
standard Ada library and are more convenient to use.
@node GNAT Regexp g-regexp ads,GNAT Registry g-regist ads,GNAT Random_Numbers g-rannum ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-regexp-g-regexp-ads}@anchor{210}@anchor{gnat_rm/the_gnat_library id93}@anchor{33f}
+@anchor{gnat_rm/the_gnat_library gnat-regexp-g-regexp-ads}@anchor{24a}@anchor{gnat_rm/the_gnat_library id93}@anchor{379}
@section @cite{GNAT.Regexp} (@code{g-regexp.ads})
@@ -23856,7 +24046,7 @@ simplest of the three pattern matching packages provided, and is particularly
suitable for 'file globbing' applications.
@node GNAT Registry g-regist ads,GNAT Regpat g-regpat ads,GNAT Regexp g-regexp ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id94}@anchor{340}@anchor{gnat_rm/the_gnat_library gnat-registry-g-regist-ads}@anchor{341}
+@anchor{gnat_rm/the_gnat_library id94}@anchor{37a}@anchor{gnat_rm/the_gnat_library gnat-registry-g-regist-ads}@anchor{37b}
@section @cite{GNAT.Registry} (@code{g-regist.ads})
@@ -23870,7 +24060,7 @@ registry API, but at a lower level of abstraction, refer to the Win32.Winreg
package provided with the Win32Ada binding
@node GNAT Regpat g-regpat ads,GNAT Rewrite_Data g-rewdat ads,GNAT Registry g-regist ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-regpat-g-regpat-ads}@anchor{342}@anchor{gnat_rm/the_gnat_library id95}@anchor{343}
+@anchor{gnat_rm/the_gnat_library gnat-regpat-g-regpat-ads}@anchor{37c}@anchor{gnat_rm/the_gnat_library id95}@anchor{37d}
@section @cite{GNAT.Regpat} (@code{g-regpat.ads})
@@ -23885,7 +24075,7 @@ from the original V7 style regular expression library written in C by
Henry Spencer (and binary compatible with this C library).
@node GNAT Rewrite_Data g-rewdat ads,GNAT Secondary_Stack_Info g-sestin ads,GNAT Regpat g-regpat ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id96}@anchor{344}@anchor{gnat_rm/the_gnat_library gnat-rewrite-data-g-rewdat-ads}@anchor{345}
+@anchor{gnat_rm/the_gnat_library id96}@anchor{37e}@anchor{gnat_rm/the_gnat_library gnat-rewrite-data-g-rewdat-ads}@anchor{37f}
@section @cite{GNAT.Rewrite_Data} (@code{g-rewdat.ads})
@@ -23899,7 +24089,7 @@ full content to be processed is not loaded into memory all at once. This makes
this interface usable for large files or socket streams.
@node GNAT Secondary_Stack_Info g-sestin ads,GNAT Semaphores g-semaph ads,GNAT Rewrite_Data g-rewdat ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-secondary-stack-info-g-sestin-ads}@anchor{346}@anchor{gnat_rm/the_gnat_library id97}@anchor{347}
+@anchor{gnat_rm/the_gnat_library gnat-secondary-stack-info-g-sestin-ads}@anchor{380}@anchor{gnat_rm/the_gnat_library id97}@anchor{381}
@section @cite{GNAT.Secondary_Stack_Info} (@code{g-sestin.ads})
@@ -23911,7 +24101,7 @@ Provide the capability to query the high water mark of the current task's
secondary stack.
@node GNAT Semaphores g-semaph ads,GNAT Serial_Communications g-sercom ads,GNAT Secondary_Stack_Info g-sestin ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id98}@anchor{348}@anchor{gnat_rm/the_gnat_library gnat-semaphores-g-semaph-ads}@anchor{349}
+@anchor{gnat_rm/the_gnat_library id98}@anchor{382}@anchor{gnat_rm/the_gnat_library gnat-semaphores-g-semaph-ads}@anchor{383}
@section @cite{GNAT.Semaphores} (@code{g-semaph.ads})
@@ -23922,7 +24112,7 @@ secondary stack.
Provides classic counting and binary semaphores using protected types.
@node GNAT Serial_Communications g-sercom ads,GNAT SHA1 g-sha1 ads,GNAT Semaphores g-semaph ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-serial-communications-g-sercom-ads}@anchor{34a}@anchor{gnat_rm/the_gnat_library id99}@anchor{34b}
+@anchor{gnat_rm/the_gnat_library gnat-serial-communications-g-sercom-ads}@anchor{384}@anchor{gnat_rm/the_gnat_library id99}@anchor{385}
@section @cite{GNAT.Serial_Communications} (@code{g-sercom.ads})
@@ -23934,7 +24124,7 @@ Provides a simple interface to send and receive data over a serial
port. This is only supported on GNU/Linux and Windows.
@node GNAT SHA1 g-sha1 ads,GNAT SHA224 g-sha224 ads,GNAT Serial_Communications g-sercom ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-sha1-g-sha1-ads}@anchor{34c}@anchor{gnat_rm/the_gnat_library id100}@anchor{34d}
+@anchor{gnat_rm/the_gnat_library gnat-sha1-g-sha1-ads}@anchor{386}@anchor{gnat_rm/the_gnat_library id100}@anchor{387}
@section @cite{GNAT.SHA1} (@code{g-sha1.ads})
@@ -23947,7 +24137,7 @@ and RFC 3174, and the HMAC-SHA1 message authentication function as described
in RFC 2104 and FIPS PUB 198.
@node GNAT SHA224 g-sha224 ads,GNAT SHA256 g-sha256 ads,GNAT SHA1 g-sha1 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id101}@anchor{34e}@anchor{gnat_rm/the_gnat_library gnat-sha224-g-sha224-ads}@anchor{34f}
+@anchor{gnat_rm/the_gnat_library id101}@anchor{388}@anchor{gnat_rm/the_gnat_library gnat-sha224-g-sha224-ads}@anchor{389}
@section @cite{GNAT.SHA224} (@code{g-sha224.ads})
@@ -23960,7 +24150,7 @@ and the HMAC-SHA224 message authentication function as described
in RFC 2104 and FIPS PUB 198.
@node GNAT SHA256 g-sha256 ads,GNAT SHA384 g-sha384 ads,GNAT SHA224 g-sha224 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id102}@anchor{350}@anchor{gnat_rm/the_gnat_library gnat-sha256-g-sha256-ads}@anchor{351}
+@anchor{gnat_rm/the_gnat_library id102}@anchor{38a}@anchor{gnat_rm/the_gnat_library gnat-sha256-g-sha256-ads}@anchor{38b}
@section @cite{GNAT.SHA256} (@code{g-sha256.ads})
@@ -23973,7 +24163,7 @@ and the HMAC-SHA256 message authentication function as described
in RFC 2104 and FIPS PUB 198.
@node GNAT SHA384 g-sha384 ads,GNAT SHA512 g-sha512 ads,GNAT SHA256 g-sha256 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id103}@anchor{352}@anchor{gnat_rm/the_gnat_library gnat-sha384-g-sha384-ads}@anchor{353}
+@anchor{gnat_rm/the_gnat_library id103}@anchor{38c}@anchor{gnat_rm/the_gnat_library gnat-sha384-g-sha384-ads}@anchor{38d}
@section @cite{GNAT.SHA384} (@code{g-sha384.ads})
@@ -23986,7 +24176,7 @@ and the HMAC-SHA384 message authentication function as described
in RFC 2104 and FIPS PUB 198.
@node GNAT SHA512 g-sha512 ads,GNAT Signals g-signal ads,GNAT SHA384 g-sha384 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-sha512-g-sha512-ads}@anchor{354}@anchor{gnat_rm/the_gnat_library id104}@anchor{355}
+@anchor{gnat_rm/the_gnat_library gnat-sha512-g-sha512-ads}@anchor{38e}@anchor{gnat_rm/the_gnat_library id104}@anchor{38f}
@section @cite{GNAT.SHA512} (@code{g-sha512.ads})
@@ -23999,7 +24189,7 @@ and the HMAC-SHA512 message authentication function as described
in RFC 2104 and FIPS PUB 198.
@node GNAT Signals g-signal ads,GNAT Sockets g-socket ads,GNAT SHA512 g-sha512 ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-signals-g-signal-ads}@anchor{356}@anchor{gnat_rm/the_gnat_library id105}@anchor{357}
+@anchor{gnat_rm/the_gnat_library gnat-signals-g-signal-ads}@anchor{390}@anchor{gnat_rm/the_gnat_library id105}@anchor{391}
@section @cite{GNAT.Signals} (@code{g-signal.ads})
@@ -24011,7 +24201,7 @@ Provides the ability to manipulate the blocked status of signals on supported
targets.
@node GNAT Sockets g-socket ads,GNAT Source_Info g-souinf ads,GNAT Signals g-signal ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-sockets-g-socket-ads}@anchor{358}@anchor{gnat_rm/the_gnat_library id106}@anchor{359}
+@anchor{gnat_rm/the_gnat_library gnat-sockets-g-socket-ads}@anchor{392}@anchor{gnat_rm/the_gnat_library id106}@anchor{393}
@section @cite{GNAT.Sockets} (@code{g-socket.ads})
@@ -24026,7 +24216,7 @@ on all native GNAT ports and on VxWorks cross prots. It is not implemented for
the LynxOS cross port.
@node GNAT Source_Info g-souinf ads,GNAT Spelling_Checker g-speche ads,GNAT Sockets g-socket ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-source-info-g-souinf-ads}@anchor{35a}@anchor{gnat_rm/the_gnat_library id107}@anchor{35b}
+@anchor{gnat_rm/the_gnat_library gnat-source-info-g-souinf-ads}@anchor{394}@anchor{gnat_rm/the_gnat_library id107}@anchor{395}
@section @cite{GNAT.Source_Info} (@code{g-souinf.ads})
@@ -24040,7 +24230,7 @@ subprograms yielding the date and time of the current compilation (like the
C macros @cite{__DATE__} and @cite{__TIME__})
@node GNAT Spelling_Checker g-speche ads,GNAT Spelling_Checker_Generic g-spchge ads,GNAT Source_Info g-souinf ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-g-speche-ads}@anchor{35c}@anchor{gnat_rm/the_gnat_library id108}@anchor{35d}
+@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-g-speche-ads}@anchor{396}@anchor{gnat_rm/the_gnat_library id108}@anchor{397}
@section @cite{GNAT.Spelling_Checker} (@code{g-speche.ads})
@@ -24052,7 +24242,7 @@ Provides a function for determining whether one string is a plausible
near misspelling of another string.
@node GNAT Spelling_Checker_Generic g-spchge ads,GNAT Spitbol Patterns g-spipat ads,GNAT Spelling_Checker g-speche ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id109}@anchor{35e}@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-generic-g-spchge-ads}@anchor{35f}
+@anchor{gnat_rm/the_gnat_library id109}@anchor{398}@anchor{gnat_rm/the_gnat_library gnat-spelling-checker-generic-g-spchge-ads}@anchor{399}
@section @cite{GNAT.Spelling_Checker_Generic} (@code{g-spchge.ads})
@@ -24065,7 +24255,7 @@ determining whether one string is a plausible near misspelling of another
string.
@node GNAT Spitbol Patterns g-spipat ads,GNAT Spitbol g-spitbo ads,GNAT Spelling_Checker_Generic g-spchge ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id110}@anchor{360}@anchor{gnat_rm/the_gnat_library gnat-spitbol-patterns-g-spipat-ads}@anchor{361}
+@anchor{gnat_rm/the_gnat_library id110}@anchor{39a}@anchor{gnat_rm/the_gnat_library gnat-spitbol-patterns-g-spipat-ads}@anchor{39b}
@section @cite{GNAT.Spitbol.Patterns} (@code{g-spipat.ads})
@@ -24081,7 +24271,7 @@ the SNOBOL4 dynamic pattern construction and matching capabilities, using the
efficient algorithm developed by Robert Dewar for the SPITBOL system.
@node GNAT Spitbol g-spitbo ads,GNAT Spitbol Table_Boolean g-sptabo ads,GNAT Spitbol Patterns g-spipat ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id111}@anchor{362}@anchor{gnat_rm/the_gnat_library gnat-spitbol-g-spitbo-ads}@anchor{363}
+@anchor{gnat_rm/the_gnat_library id111}@anchor{39c}@anchor{gnat_rm/the_gnat_library gnat-spitbol-g-spitbo-ads}@anchor{39d}
@section @cite{GNAT.Spitbol} (@code{g-spitbo.ads})
@@ -24096,7 +24286,7 @@ useful for constructing arbitrary mappings from strings in the style of
the SNOBOL4 TABLE function.
@node GNAT Spitbol Table_Boolean g-sptabo ads,GNAT Spitbol Table_Integer g-sptain ads,GNAT Spitbol g-spitbo ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id112}@anchor{364}@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-boolean-g-sptabo-ads}@anchor{365}
+@anchor{gnat_rm/the_gnat_library id112}@anchor{39e}@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-boolean-g-sptabo-ads}@anchor{39f}
@section @cite{GNAT.Spitbol.Table_Boolean} (@code{g-sptabo.ads})
@@ -24111,7 +24301,7 @@ for type @cite{Standard.Boolean}, giving an implementation of sets of
string values.
@node GNAT Spitbol Table_Integer g-sptain ads,GNAT Spitbol Table_VString g-sptavs ads,GNAT Spitbol Table_Boolean g-sptabo ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id113}@anchor{366}@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-integer-g-sptain-ads}@anchor{367}
+@anchor{gnat_rm/the_gnat_library id113}@anchor{3a0}@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-integer-g-sptain-ads}@anchor{3a1}
@section @cite{GNAT.Spitbol.Table_Integer} (@code{g-sptain.ads})
@@ -24128,7 +24318,7 @@ for type @cite{Standard.Integer}, giving an implementation of maps
from string to integer values.
@node GNAT Spitbol Table_VString g-sptavs ads,GNAT SSE g-sse ads,GNAT Spitbol Table_Integer g-sptain ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id114}@anchor{368}@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-vstring-g-sptavs-ads}@anchor{369}
+@anchor{gnat_rm/the_gnat_library id114}@anchor{3a2}@anchor{gnat_rm/the_gnat_library gnat-spitbol-table-vstring-g-sptavs-ads}@anchor{3a3}
@section @cite{GNAT.Spitbol.Table_VString} (@code{g-sptavs.ads})
@@ -24145,7 +24335,7 @@ a variable length string type, giving an implementation of general
maps from strings to strings.
@node GNAT SSE g-sse ads,GNAT SSE Vector_Types g-ssvety ads,GNAT Spitbol Table_VString g-sptavs ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id115}@anchor{36a}@anchor{gnat_rm/the_gnat_library gnat-sse-g-sse-ads}@anchor{36b}
+@anchor{gnat_rm/the_gnat_library id115}@anchor{3a4}@anchor{gnat_rm/the_gnat_library gnat-sse-g-sse-ads}@anchor{3a5}
@section @cite{GNAT.SSE} (@code{g-sse.ads})
@@ -24156,8 +24346,8 @@ the Intel(r) Streaming SIMD Extensions with GNAT on the x86 family of
targets. It exposes vector component types together with a general
introduction to the binding contents and use.
-@node GNAT SSE Vector_Types g-ssvety ads,GNAT Strings g-string ads,GNAT SSE g-sse ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-sse-vector-types-g-ssvety-ads}@anchor{36c}@anchor{gnat_rm/the_gnat_library id116}@anchor{36d}
+@node GNAT SSE Vector_Types g-ssvety ads,GNAT String_Hash g-strhas ads,GNAT SSE g-sse ads,The GNAT Library
+@anchor{gnat_rm/the_gnat_library gnat-sse-vector-types-g-ssvety-ads}@anchor{3a6}@anchor{gnat_rm/the_gnat_library id116}@anchor{3a7}
@section @cite{GNAT.SSE.Vector_Types} (@code{g-ssvety.ads})
@@ -24165,8 +24355,20 @@ introduction to the binding contents and use.
SSE vector types for use with SSE related intrinsics.
-@node GNAT Strings g-string ads,GNAT String_Split g-strspl ads,GNAT SSE Vector_Types g-ssvety ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-strings-g-string-ads}@anchor{36e}@anchor{gnat_rm/the_gnat_library id117}@anchor{36f}
+@node GNAT String_Hash g-strhas ads,GNAT Strings g-string ads,GNAT SSE Vector_Types g-ssvety ads,The GNAT Library
+@anchor{gnat_rm/the_gnat_library gnat-string-hash-g-strhas-ads}@anchor{3a8}@anchor{gnat_rm/the_gnat_library id117}@anchor{3a9}
+@section @cite{GNAT.String_Hash} (@code{g-strhas.ads})
+
+
+@geindex GNAT.String_Hash (g-strhas.ads)
+
+@geindex Hash functions
+
+Provides a generic hash function working on arrays of scalars. Both the scalar
+type and the hash result type are parameters.
+
+@node GNAT Strings g-string ads,GNAT String_Split g-strspl ads,GNAT String_Hash g-strhas ads,The GNAT Library
+@anchor{gnat_rm/the_gnat_library id118}@anchor{3aa}@anchor{gnat_rm/the_gnat_library gnat-strings-g-string-ads}@anchor{3ab}
@section @cite{GNAT.Strings} (@code{g-string.ads})
@@ -24176,7 +24378,7 @@ Common String access types and related subprograms. Basically it
defines a string access and an array of string access types.
@node GNAT String_Split g-strspl ads,GNAT Table g-table ads,GNAT Strings g-string ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-string-split-g-strspl-ads}@anchor{370}@anchor{gnat_rm/the_gnat_library id118}@anchor{371}
+@anchor{gnat_rm/the_gnat_library gnat-string-split-g-strspl-ads}@anchor{3ac}@anchor{gnat_rm/the_gnat_library id119}@anchor{3ad}
@section @cite{GNAT.String_Split} (@code{g-strspl.ads})
@@ -24190,7 +24392,7 @@ to the resulting slices. This package is instantiated from
@cite{GNAT.Array_Split}.
@node GNAT Table g-table ads,GNAT Task_Lock g-tasloc ads,GNAT String_Split g-strspl ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-table-g-table-ads}@anchor{372}@anchor{gnat_rm/the_gnat_library id119}@anchor{373}
+@anchor{gnat_rm/the_gnat_library gnat-table-g-table-ads}@anchor{3ae}@anchor{gnat_rm/the_gnat_library id120}@anchor{3af}
@section @cite{GNAT.Table} (@code{g-table.ads})
@@ -24210,7 +24412,7 @@ while an instantiation of @cite{GNAT.Dynamic_Tables} creates a type that can be
used to define dynamic instances of the table.
@node GNAT Task_Lock g-tasloc ads,GNAT Time_Stamp g-timsta ads,GNAT Table g-table ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-task-lock-g-tasloc-ads}@anchor{374}@anchor{gnat_rm/the_gnat_library id120}@anchor{375}
+@anchor{gnat_rm/the_gnat_library gnat-task-lock-g-tasloc-ads}@anchor{3b0}@anchor{gnat_rm/the_gnat_library id121}@anchor{3b1}
@section @cite{GNAT.Task_Lock} (@code{g-tasloc.ads})
@@ -24227,7 +24429,7 @@ single global task lock. Appropriate for use in situations where contention
between tasks is very rarely expected.
@node GNAT Time_Stamp g-timsta ads,GNAT Threads g-thread ads,GNAT Task_Lock g-tasloc ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-time-stamp-g-timsta-ads}@anchor{376}@anchor{gnat_rm/the_gnat_library id121}@anchor{377}
+@anchor{gnat_rm/the_gnat_library gnat-time-stamp-g-timsta-ads}@anchor{3b2}@anchor{gnat_rm/the_gnat_library id122}@anchor{3b3}
@section @cite{GNAT.Time_Stamp} (@code{g-timsta.ads})
@@ -24242,7 +24444,7 @@ represents the current date and time in ISO 8601 format. This is a very simple
routine with minimal code and there are no dependencies on any other unit.
@node GNAT Threads g-thread ads,GNAT Traceback g-traceb ads,GNAT Time_Stamp g-timsta ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-threads-g-thread-ads}@anchor{378}@anchor{gnat_rm/the_gnat_library id122}@anchor{379}
+@anchor{gnat_rm/the_gnat_library gnat-threads-g-thread-ads}@anchor{3b4}@anchor{gnat_rm/the_gnat_library id123}@anchor{3b5}
@section @cite{GNAT.Threads} (@code{g-thread.ads})
@@ -24259,7 +24461,7 @@ further details if your program has threads that are created by a non-Ada
environment which then accesses Ada code.
@node GNAT Traceback g-traceb ads,GNAT Traceback Symbolic g-trasym ads,GNAT Threads g-thread ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id123}@anchor{37a}@anchor{gnat_rm/the_gnat_library gnat-traceback-g-traceb-ads}@anchor{37b}
+@anchor{gnat_rm/the_gnat_library id124}@anchor{3b6}@anchor{gnat_rm/the_gnat_library gnat-traceback-g-traceb-ads}@anchor{3b7}
@section @cite{GNAT.Traceback} (@code{g-traceb.ads})
@@ -24271,7 +24473,7 @@ Provides a facility for obtaining non-symbolic traceback information, useful
in various debugging situations.
@node GNAT Traceback Symbolic g-trasym ads,GNAT UTF_32 g-table ads,GNAT Traceback g-traceb ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-traceback-symbolic-g-trasym-ads}@anchor{37c}@anchor{gnat_rm/the_gnat_library id124}@anchor{37d}
+@anchor{gnat_rm/the_gnat_library gnat-traceback-symbolic-g-trasym-ads}@anchor{3b8}@anchor{gnat_rm/the_gnat_library id125}@anchor{3b9}
@section @cite{GNAT.Traceback.Symbolic} (@code{g-trasym.ads})
@@ -24280,7 +24482,7 @@ in various debugging situations.
@geindex Trace back facilities
@node GNAT UTF_32 g-table ads,GNAT Wide_Spelling_Checker g-u3spch ads,GNAT Traceback Symbolic g-trasym ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id125}@anchor{37e}@anchor{gnat_rm/the_gnat_library gnat-utf-32-g-table-ads}@anchor{37f}
+@anchor{gnat_rm/the_gnat_library id126}@anchor{3ba}@anchor{gnat_rm/the_gnat_library gnat-utf-32-g-table-ads}@anchor{3bb}
@section @cite{GNAT.UTF_32} (@code{g-table.ads})
@@ -24299,7 +24501,7 @@ lower case to upper case fold routine corresponding to
the Ada 2005 rules for identifier equivalence.
@node GNAT Wide_Spelling_Checker g-u3spch ads,GNAT Wide_Spelling_Checker g-wispch ads,GNAT UTF_32 g-table ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-u3spch-ads}@anchor{380}@anchor{gnat_rm/the_gnat_library id126}@anchor{381}
+@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-u3spch-ads}@anchor{3bc}@anchor{gnat_rm/the_gnat_library id127}@anchor{3bd}
@section @cite{GNAT.Wide_Spelling_Checker} (@code{g-u3spch.ads})
@@ -24312,7 +24514,7 @@ near misspelling of another wide wide string, where the strings are represented
using the UTF_32_String type defined in System.Wch_Cnv.
@node GNAT Wide_Spelling_Checker g-wispch ads,GNAT Wide_String_Split g-wistsp ads,GNAT Wide_Spelling_Checker g-u3spch ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-wispch-ads}@anchor{382}@anchor{gnat_rm/the_gnat_library id127}@anchor{383}
+@anchor{gnat_rm/the_gnat_library gnat-wide-spelling-checker-g-wispch-ads}@anchor{3be}@anchor{gnat_rm/the_gnat_library id128}@anchor{3bf}
@section @cite{GNAT.Wide_Spelling_Checker} (@code{g-wispch.ads})
@@ -24324,7 +24526,7 @@ Provides a function for determining whether one wide string is a plausible
near misspelling of another wide string.
@node GNAT Wide_String_Split g-wistsp ads,GNAT Wide_Wide_Spelling_Checker g-zspche ads,GNAT Wide_Spelling_Checker g-wispch ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-wide-string-split-g-wistsp-ads}@anchor{384}@anchor{gnat_rm/the_gnat_library id128}@anchor{385}
+@anchor{gnat_rm/the_gnat_library gnat-wide-string-split-g-wistsp-ads}@anchor{3c0}@anchor{gnat_rm/the_gnat_library id129}@anchor{3c1}
@section @cite{GNAT.Wide_String_Split} (@code{g-wistsp.ads})
@@ -24338,7 +24540,7 @@ to the resulting slices. This package is instantiated from
@cite{GNAT.Array_Split}.
@node GNAT Wide_Wide_Spelling_Checker g-zspche ads,GNAT Wide_Wide_String_Split g-zistsp ads,GNAT Wide_String_Split g-wistsp ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-wide-wide-spelling-checker-g-zspche-ads}@anchor{386}@anchor{gnat_rm/the_gnat_library id129}@anchor{387}
+@anchor{gnat_rm/the_gnat_library gnat-wide-wide-spelling-checker-g-zspche-ads}@anchor{3c2}@anchor{gnat_rm/the_gnat_library id130}@anchor{3c3}
@section @cite{GNAT.Wide_Wide_Spelling_Checker} (@code{g-zspche.ads})
@@ -24350,7 +24552,7 @@ Provides a function for determining whether one wide wide string is a plausible
near misspelling of another wide wide string.
@node GNAT Wide_Wide_String_Split g-zistsp ads,Interfaces C Extensions i-cexten ads,GNAT Wide_Wide_Spelling_Checker g-zspche ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library gnat-wide-wide-string-split-g-zistsp-ads}@anchor{388}@anchor{gnat_rm/the_gnat_library id130}@anchor{389}
+@anchor{gnat_rm/the_gnat_library gnat-wide-wide-string-split-g-zistsp-ads}@anchor{3c4}@anchor{gnat_rm/the_gnat_library id131}@anchor{3c5}
@section @cite{GNAT.Wide_Wide_String_Split} (@code{g-zistsp.ads})
@@ -24364,7 +24566,7 @@ to the resulting slices. This package is instantiated from
@cite{GNAT.Array_Split}.
@node Interfaces C Extensions i-cexten ads,Interfaces C Streams i-cstrea ads,GNAT Wide_Wide_String_Split g-zistsp ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id131}@anchor{38a}@anchor{gnat_rm/the_gnat_library interfaces-c-extensions-i-cexten-ads}@anchor{38b}
+@anchor{gnat_rm/the_gnat_library interfaces-c-extensions-i-cexten-ads}@anchor{3c6}@anchor{gnat_rm/the_gnat_library id132}@anchor{3c7}
@section @cite{Interfaces.C.Extensions} (@code{i-cexten.ads})
@@ -24375,7 +24577,7 @@ for use with either manually or automatically generated bindings
to C libraries.
@node Interfaces C Streams i-cstrea ads,Interfaces Packed_Decimal i-pacdec ads,Interfaces C Extensions i-cexten ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id132}@anchor{38c}@anchor{gnat_rm/the_gnat_library interfaces-c-streams-i-cstrea-ads}@anchor{38d}
+@anchor{gnat_rm/the_gnat_library id133}@anchor{3c8}@anchor{gnat_rm/the_gnat_library interfaces-c-streams-i-cstrea-ads}@anchor{3c9}
@section @cite{Interfaces.C.Streams} (@code{i-cstrea.ads})
@@ -24388,7 +24590,7 @@ This package is a binding for the most commonly used operations
on C streams.
@node Interfaces Packed_Decimal i-pacdec ads,Interfaces VxWorks i-vxwork ads,Interfaces C Streams i-cstrea ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library interfaces-packed-decimal-i-pacdec-ads}@anchor{38e}@anchor{gnat_rm/the_gnat_library id133}@anchor{38f}
+@anchor{gnat_rm/the_gnat_library interfaces-packed-decimal-i-pacdec-ads}@anchor{3ca}@anchor{gnat_rm/the_gnat_library id134}@anchor{3cb}
@section @cite{Interfaces.Packed_Decimal} (@code{i-pacdec.ads})
@@ -24402,8 +24604,8 @@ This package provides a set of routines for conversions to and
from a packed decimal format compatible with that used on IBM
mainframes.
-@node Interfaces VxWorks i-vxwork ads,Interfaces VxWorks IO i-vxwoio ads,Interfaces Packed_Decimal i-pacdec ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id134}@anchor{390}@anchor{gnat_rm/the_gnat_library interfaces-vxworks-i-vxwork-ads}@anchor{391}
+@node Interfaces VxWorks i-vxwork ads,Interfaces VxWorks Int_Connection i-vxinco ads,Interfaces Packed_Decimal i-pacdec ads,The GNAT Library
+@anchor{gnat_rm/the_gnat_library interfaces-vxworks-i-vxwork-ads}@anchor{3cc}@anchor{gnat_rm/the_gnat_library id135}@anchor{3cd}
@section @cite{Interfaces.VxWorks} (@code{i-vxwork.ads})
@@ -24418,8 +24620,24 @@ This package provides a limited binding to the VxWorks API.
In particular, it interfaces with the
VxWorks hardware interrupt facilities.
-@node Interfaces VxWorks IO i-vxwoio ads,System Address_Image s-addima ads,Interfaces VxWorks i-vxwork ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library interfaces-vxworks-io-i-vxwoio-ads}@anchor{392}@anchor{gnat_rm/the_gnat_library id135}@anchor{393}
+@node Interfaces VxWorks Int_Connection i-vxinco ads,Interfaces VxWorks IO i-vxwoio ads,Interfaces VxWorks i-vxwork ads,The GNAT Library
+@anchor{gnat_rm/the_gnat_library interfaces-vxworks-int-connection-i-vxinco-ads}@anchor{3ce}@anchor{gnat_rm/the_gnat_library id136}@anchor{3cf}
+@section @cite{Interfaces.VxWorks.Int_Connection} (@code{i-vxinco.ads})
+
+
+@geindex Interfaces.VxWorks.Int_Connection (i-vxinco.ads)
+
+@geindex Interfacing to VxWorks
+
+@geindex VxWorks
+@geindex interfacing
+
+This package provides a way for users to replace the use of
+intConnect() with a custom routine for installing interrupt
+handlers.
+
+@node Interfaces VxWorks IO i-vxwoio ads,System Address_Image s-addima ads,Interfaces VxWorks Int_Connection i-vxinco ads,The GNAT Library
+@anchor{gnat_rm/the_gnat_library interfaces-vxworks-io-i-vxwoio-ads}@anchor{3d0}@anchor{gnat_rm/the_gnat_library id137}@anchor{3d1}
@section @cite{Interfaces.VxWorks.IO} (@code{i-vxwoio.ads})
@@ -24442,7 +24660,7 @@ function codes. A particular use of this package is
to enable the use of Get_Immediate under VxWorks.
@node System Address_Image s-addima ads,System Assertions s-assert ads,Interfaces VxWorks IO i-vxwoio ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library system-address-image-s-addima-ads}@anchor{394}@anchor{gnat_rm/the_gnat_library id136}@anchor{395}
+@anchor{gnat_rm/the_gnat_library id138}@anchor{3d2}@anchor{gnat_rm/the_gnat_library system-address-image-s-addima-ads}@anchor{3d3}
@section @cite{System.Address_Image} (@code{s-addima.ads})
@@ -24458,7 +24676,7 @@ function that gives an (implementation dependent)
string which identifies an address.
@node System Assertions s-assert ads,System Atomic_Counters s-atocou ads,System Address_Image s-addima ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library system-assertions-s-assert-ads}@anchor{396}@anchor{gnat_rm/the_gnat_library id137}@anchor{397}
+@anchor{gnat_rm/the_gnat_library id139}@anchor{3d4}@anchor{gnat_rm/the_gnat_library system-assertions-s-assert-ads}@anchor{3d5}
@section @cite{System.Assertions} (@code{s-assert.ads})
@@ -24474,7 +24692,7 @@ by an run-time assertion failure, as well as the routine that
is used internally to raise this assertion.
@node System Atomic_Counters s-atocou ads,System Memory s-memory ads,System Assertions s-assert ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id138}@anchor{398}@anchor{gnat_rm/the_gnat_library system-atomic-counters-s-atocou-ads}@anchor{399}
+@anchor{gnat_rm/the_gnat_library id140}@anchor{3d6}@anchor{gnat_rm/the_gnat_library system-atomic-counters-s-atocou-ads}@anchor{3d7}
@section @cite{System.Atomic_Counters} (@code{s-atocou.ads})
@@ -24488,7 +24706,7 @@ on most targets, including all Alpha, ia64, PowerPC, SPARC V9,
x86, and x86_64 platforms.
@node System Memory s-memory ads,System Multiprocessors s-multip ads,System Atomic_Counters s-atocou ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library system-memory-s-memory-ads}@anchor{39a}@anchor{gnat_rm/the_gnat_library id139}@anchor{39b}
+@anchor{gnat_rm/the_gnat_library system-memory-s-memory-ads}@anchor{3d8}@anchor{gnat_rm/the_gnat_library id141}@anchor{3d9}
@section @cite{System.Memory} (@code{s-memory.ads})
@@ -24506,7 +24724,7 @@ calls to this unit may be made for low level allocation uses (for
example see the body of @cite{GNAT.Tables}).
@node System Multiprocessors s-multip ads,System Multiprocessors Dispatching_Domains s-mudido ads,System Memory s-memory ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id140}@anchor{39c}@anchor{gnat_rm/the_gnat_library system-multiprocessors-s-multip-ads}@anchor{39d}
+@anchor{gnat_rm/the_gnat_library system-multiprocessors-s-multip-ads}@anchor{3da}@anchor{gnat_rm/the_gnat_library id142}@anchor{3db}
@section @cite{System.Multiprocessors} (@code{s-multip.ads})
@@ -24519,7 +24737,7 @@ in GNAT we also make it available in Ada 95 and Ada 2005 (where it is
technically an implementation-defined addition).
@node System Multiprocessors Dispatching_Domains s-mudido ads,System Partition_Interface s-parint ads,System Multiprocessors s-multip ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library system-multiprocessors-dispatching-domains-s-mudido-ads}@anchor{39e}@anchor{gnat_rm/the_gnat_library id141}@anchor{39f}
+@anchor{gnat_rm/the_gnat_library system-multiprocessors-dispatching-domains-s-mudido-ads}@anchor{3dc}@anchor{gnat_rm/the_gnat_library id143}@anchor{3dd}
@section @cite{System.Multiprocessors.Dispatching_Domains} (@code{s-mudido.ads})
@@ -24532,7 +24750,7 @@ in GNAT we also make it available in Ada 95 and Ada 2005 (where it is
technically an implementation-defined addition).
@node System Partition_Interface s-parint ads,System Pool_Global s-pooglo ads,System Multiprocessors Dispatching_Domains s-mudido ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id142}@anchor{3a0}@anchor{gnat_rm/the_gnat_library system-partition-interface-s-parint-ads}@anchor{3a1}
+@anchor{gnat_rm/the_gnat_library id144}@anchor{3de}@anchor{gnat_rm/the_gnat_library system-partition-interface-s-parint-ads}@anchor{3df}
@section @cite{System.Partition_Interface} (@code{s-parint.ads})
@@ -24545,7 +24763,7 @@ is used primarily in a distribution context when using Annex E
with @cite{GLADE}.
@node System Pool_Global s-pooglo ads,System Pool_Local s-pooloc ads,System Partition_Interface s-parint ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id143}@anchor{3a2}@anchor{gnat_rm/the_gnat_library system-pool-global-s-pooglo-ads}@anchor{3a3}
+@anchor{gnat_rm/the_gnat_library id145}@anchor{3e0}@anchor{gnat_rm/the_gnat_library system-pool-global-s-pooglo-ads}@anchor{3e1}
@section @cite{System.Pool_Global} (@code{s-pooglo.ads})
@@ -24562,7 +24780,7 @@ declared. It uses malloc/free to allocate/free and does not attempt to
do any automatic reclamation.
@node System Pool_Local s-pooloc ads,System Restrictions s-restri ads,System Pool_Global s-pooglo ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id144}@anchor{3a4}@anchor{gnat_rm/the_gnat_library system-pool-local-s-pooloc-ads}@anchor{3a5}
+@anchor{gnat_rm/the_gnat_library system-pool-local-s-pooloc-ads}@anchor{3e2}@anchor{gnat_rm/the_gnat_library id146}@anchor{3e3}
@section @cite{System.Pool_Local} (@code{s-pooloc.ads})
@@ -24579,7 +24797,7 @@ a list of allocated blocks, so that all storage allocated for the pool can
be freed automatically when the pool is finalized.
@node System Restrictions s-restri ads,System Rident s-rident ads,System Pool_Local s-pooloc ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id145}@anchor{3a6}@anchor{gnat_rm/the_gnat_library system-restrictions-s-restri-ads}@anchor{3a7}
+@anchor{gnat_rm/the_gnat_library id147}@anchor{3e4}@anchor{gnat_rm/the_gnat_library system-restrictions-s-restri-ads}@anchor{3e5}
@section @cite{System.Restrictions} (@code{s-restri.ads})
@@ -24595,7 +24813,7 @@ compiler determined information on which restrictions
are violated by one or more packages in the partition.
@node System Rident s-rident ads,System Strings Stream_Ops s-ststop ads,System Restrictions s-restri ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library system-rident-s-rident-ads}@anchor{3a8}@anchor{gnat_rm/the_gnat_library id146}@anchor{3a9}
+@anchor{gnat_rm/the_gnat_library system-rident-s-rident-ads}@anchor{3e6}@anchor{gnat_rm/the_gnat_library id148}@anchor{3e7}
@section @cite{System.Rident} (@code{s-rident.ads})
@@ -24611,7 +24829,7 @@ since the necessary instantiation is included in
package System.Restrictions.
@node System Strings Stream_Ops s-ststop ads,System Unsigned_Types s-unstyp ads,System Rident s-rident ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library id147}@anchor{3aa}@anchor{gnat_rm/the_gnat_library system-strings-stream-ops-s-ststop-ads}@anchor{3ab}
+@anchor{gnat_rm/the_gnat_library id149}@anchor{3e8}@anchor{gnat_rm/the_gnat_library system-strings-stream-ops-s-ststop-ads}@anchor{3e9}
@section @cite{System.Strings.Stream_Ops} (@code{s-ststop.ads})
@@ -24627,7 +24845,7 @@ stream attributes are applied to string types, but the subprograms in this
package can be used directly by application programs.
@node System Unsigned_Types s-unstyp ads,System Wch_Cnv s-wchcnv ads,System Strings Stream_Ops s-ststop ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library system-unsigned-types-s-unstyp-ads}@anchor{3ac}@anchor{gnat_rm/the_gnat_library id148}@anchor{3ad}
+@anchor{gnat_rm/the_gnat_library system-unsigned-types-s-unstyp-ads}@anchor{3ea}@anchor{gnat_rm/the_gnat_library id150}@anchor{3eb}
@section @cite{System.Unsigned_Types} (@code{s-unstyp.ads})
@@ -24640,7 +24858,7 @@ also contains some related definitions for other specialized types
used by the compiler in connection with packed array types.
@node System Wch_Cnv s-wchcnv ads,System Wch_Con s-wchcon ads,System Unsigned_Types s-unstyp ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library system-wch-cnv-s-wchcnv-ads}@anchor{3ae}@anchor{gnat_rm/the_gnat_library id149}@anchor{3af}
+@anchor{gnat_rm/the_gnat_library system-wch-cnv-s-wchcnv-ads}@anchor{3ec}@anchor{gnat_rm/the_gnat_library id151}@anchor{3ed}
@section @cite{System.Wch_Cnv} (@code{s-wchcnv.ads})
@@ -24661,7 +24879,7 @@ encoding method. It uses definitions in
package @cite{System.Wch_Con}.
@node System Wch_Con s-wchcon ads,,System Wch_Cnv s-wchcnv ads,The GNAT Library
-@anchor{gnat_rm/the_gnat_library system-wch-con-s-wchcon-ads}@anchor{3b0}@anchor{gnat_rm/the_gnat_library id150}@anchor{3b1}
+@anchor{gnat_rm/the_gnat_library system-wch-con-s-wchcon-ads}@anchor{3ee}@anchor{gnat_rm/the_gnat_library id152}@anchor{3ef}
@section @cite{System.Wch_Con} (@code{s-wchcon.ads})
@@ -24673,7 +24891,7 @@ in ordinary strings. These definitions are used by
the package @cite{System.Wch_Cnv}.
@node Interfacing to Other Languages,Specialized Needs Annexes,The GNAT Library,Top
-@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-other-languages}@anchor{11}@anchor{gnat_rm/interfacing_to_other_languages doc}@anchor{3b2}@anchor{gnat_rm/interfacing_to_other_languages id1}@anchor{3b3}
+@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-other-languages}@anchor{11}@anchor{gnat_rm/interfacing_to_other_languages doc}@anchor{3f0}@anchor{gnat_rm/interfacing_to_other_languages id1}@anchor{3f1}
@chapter Interfacing to Other Languages
@@ -24691,7 +24909,7 @@ provided.
@end menu
@node Interfacing to C,Interfacing to C++,,Interfacing to Other Languages
-@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-c}@anchor{3b4}@anchor{gnat_rm/interfacing_to_other_languages id2}@anchor{3b5}
+@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-c}@anchor{3f2}@anchor{gnat_rm/interfacing_to_other_languages id2}@anchor{3f3}
@section Interfacing to C
@@ -24829,7 +25047,7 @@ of the length corresponding to the @code{type'Size} value in Ada.
@end itemize
@node Interfacing to C++,Interfacing to COBOL,Interfacing to C,Interfacing to Other Languages
-@anchor{gnat_rm/interfacing_to_other_languages id4}@anchor{3b6}@anchor{gnat_rm/interfacing_to_other_languages id3}@anchor{3f}
+@anchor{gnat_rm/interfacing_to_other_languages id4}@anchor{3f4}@anchor{gnat_rm/interfacing_to_other_languages id3}@anchor{45}
@section Interfacing to C++
@@ -24886,7 +25104,7 @@ The @cite{External_Name} is the name of the C++ RTTI symbol. You can then
cover a specific C++ exception in an exception handler.
@node Interfacing to COBOL,Interfacing to Fortran,Interfacing to C++,Interfacing to Other Languages
-@anchor{gnat_rm/interfacing_to_other_languages id5}@anchor{3b7}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-cobol}@anchor{3b8}
+@anchor{gnat_rm/interfacing_to_other_languages id5}@anchor{3f5}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-cobol}@anchor{3f6}
@section Interfacing to COBOL
@@ -24894,7 +25112,7 @@ Interfacing to COBOL is achieved as described in section B.4 of
the Ada Reference Manual.
@node Interfacing to Fortran,Interfacing to non-GNAT Ada code,Interfacing to COBOL,Interfacing to Other Languages
-@anchor{gnat_rm/interfacing_to_other_languages id6}@anchor{3b9}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-fortran}@anchor{3ba}
+@anchor{gnat_rm/interfacing_to_other_languages id6}@anchor{3f7}@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-fortran}@anchor{3f8}
@section Interfacing to Fortran
@@ -24904,7 +25122,7 @@ multi-dimensional array causes the array to be stored in column-major
order as required for convenient interface to Fortran.
@node Interfacing to non-GNAT Ada code,,Interfacing to Fortran,Interfacing to Other Languages
-@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-non-gnat-ada-code}@anchor{3bb}@anchor{gnat_rm/interfacing_to_other_languages id7}@anchor{3bc}
+@anchor{gnat_rm/interfacing_to_other_languages interfacing-to-non-gnat-ada-code}@anchor{3f9}@anchor{gnat_rm/interfacing_to_other_languages id7}@anchor{3fa}
@section Interfacing to non-GNAT Ada code
@@ -24928,7 +25146,7 @@ values or simple record types without variants, or simple array
types with fixed bounds.
@node Specialized Needs Annexes,Implementation of Specific Ada Features,Interfacing to Other Languages,Top
-@anchor{gnat_rm/specialized_needs_annexes specialized-needs-annexes}@anchor{12}@anchor{gnat_rm/specialized_needs_annexes doc}@anchor{3bd}@anchor{gnat_rm/specialized_needs_annexes id1}@anchor{3be}
+@anchor{gnat_rm/specialized_needs_annexes specialized-needs-annexes}@anchor{12}@anchor{gnat_rm/specialized_needs_annexes doc}@anchor{3fb}@anchor{gnat_rm/specialized_needs_annexes id1}@anchor{3fc}
@chapter Specialized Needs Annexes
@@ -24969,7 +25187,7 @@ in Ada 2005) is fully implemented.
@end table
@node Implementation of Specific Ada Features,Implementation of Ada 2012 Features,Specialized Needs Annexes,Top
-@anchor{gnat_rm/implementation_of_specific_ada_features implementation-of-specific-ada-features}@anchor{13}@anchor{gnat_rm/implementation_of_specific_ada_features doc}@anchor{3bf}@anchor{gnat_rm/implementation_of_specific_ada_features id1}@anchor{3c0}
+@anchor{gnat_rm/implementation_of_specific_ada_features implementation-of-specific-ada-features}@anchor{13}@anchor{gnat_rm/implementation_of_specific_ada_features doc}@anchor{3fd}@anchor{gnat_rm/implementation_of_specific_ada_features id1}@anchor{3fe}
@chapter Implementation of Specific Ada Features
@@ -24987,7 +25205,7 @@ facilities.
@end menu
@node Machine Code Insertions,GNAT Implementation of Tasking,,Implementation of Specific Ada Features
-@anchor{gnat_rm/implementation_of_specific_ada_features machine-code-insertions}@anchor{125}@anchor{gnat_rm/implementation_of_specific_ada_features id2}@anchor{3c1}
+@anchor{gnat_rm/implementation_of_specific_ada_features machine-code-insertions}@anchor{15e}@anchor{gnat_rm/implementation_of_specific_ada_features id2}@anchor{3ff}
@section Machine Code Insertions
@@ -25155,7 +25373,7 @@ according to normal visibility rules. In particular if there is no
qualification is required.
@node GNAT Implementation of Tasking,GNAT Implementation of Shared Passive Packages,Machine Code Insertions,Implementation of Specific Ada Features
-@anchor{gnat_rm/implementation_of_specific_ada_features id3}@anchor{3c2}@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-tasking}@anchor{3c3}
+@anchor{gnat_rm/implementation_of_specific_ada_features id3}@anchor{400}@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-tasking}@anchor{401}
@section GNAT Implementation of Tasking
@@ -25170,7 +25388,7 @@ to compliance with the Real-Time Systems Annex.
@end menu
@node Mapping Ada Tasks onto the Underlying Kernel Threads,Ensuring Compliance with the Real-Time Annex,,GNAT Implementation of Tasking
-@anchor{gnat_rm/implementation_of_specific_ada_features mapping-ada-tasks-onto-the-underlying-kernel-threads}@anchor{3c4}@anchor{gnat_rm/implementation_of_specific_ada_features id4}@anchor{3c5}
+@anchor{gnat_rm/implementation_of_specific_ada_features mapping-ada-tasks-onto-the-underlying-kernel-threads}@anchor{402}@anchor{gnat_rm/implementation_of_specific_ada_features id4}@anchor{403}
@subsection Mapping Ada Tasks onto the Underlying Kernel Threads
@@ -25239,7 +25457,7 @@ support this functionality when the parent contains more than one task.
@geindex Forking a new process
@node Ensuring Compliance with the Real-Time Annex,,Mapping Ada Tasks onto the Underlying Kernel Threads,GNAT Implementation of Tasking
-@anchor{gnat_rm/implementation_of_specific_ada_features id5}@anchor{3c6}@anchor{gnat_rm/implementation_of_specific_ada_features ensuring-compliance-with-the-real-time-annex}@anchor{3c7}
+@anchor{gnat_rm/implementation_of_specific_ada_features id5}@anchor{404}@anchor{gnat_rm/implementation_of_specific_ada_features ensuring-compliance-with-the-real-time-annex}@anchor{405}
@subsection Ensuring Compliance with the Real-Time Annex
@@ -25288,7 +25506,7 @@ that were ready to execute in the priority queue where R has been
placed at the end.
@node GNAT Implementation of Shared Passive Packages,Code Generation for Array Aggregates,GNAT Implementation of Tasking,Implementation of Specific Ada Features
-@anchor{gnat_rm/implementation_of_specific_ada_features id6}@anchor{3c8}@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-shared-passive-packages}@anchor{3c9}
+@anchor{gnat_rm/implementation_of_specific_ada_features id6}@anchor{406}@anchor{gnat_rm/implementation_of_specific_ada_features gnat-implementation-of-shared-passive-packages}@anchor{407}
@section GNAT Implementation of Shared Passive Packages
@@ -25389,7 +25607,7 @@ GNAT supports shared passive packages on all platforms
except for OpenVMS.
@node Code Generation for Array Aggregates,The Size of Discriminated Records with Default Discriminants,GNAT Implementation of Shared Passive Packages,Implementation of Specific Ada Features
-@anchor{gnat_rm/implementation_of_specific_ada_features code-generation-for-array-aggregates}@anchor{3ca}@anchor{gnat_rm/implementation_of_specific_ada_features id7}@anchor{3cb}
+@anchor{gnat_rm/implementation_of_specific_ada_features code-generation-for-array-aggregates}@anchor{408}@anchor{gnat_rm/implementation_of_specific_ada_features id7}@anchor{409}
@section Code Generation for Array Aggregates
@@ -25420,7 +25638,7 @@ component values and static subtypes also lead to simpler code.
@end menu
@node Static constant aggregates with static bounds,Constant aggregates with unconstrained nominal types,,Code Generation for Array Aggregates
-@anchor{gnat_rm/implementation_of_specific_ada_features static-constant-aggregates-with-static-bounds}@anchor{3cc}@anchor{gnat_rm/implementation_of_specific_ada_features id8}@anchor{3cd}
+@anchor{gnat_rm/implementation_of_specific_ada_features static-constant-aggregates-with-static-bounds}@anchor{40a}@anchor{gnat_rm/implementation_of_specific_ada_features id8}@anchor{40b}
@subsection Static constant aggregates with static bounds
@@ -25467,7 +25685,7 @@ Zero2: constant two_dim := (others => (others => 0));
@end example
@node Constant aggregates with unconstrained nominal types,Aggregates with static bounds,Static constant aggregates with static bounds,Code Generation for Array Aggregates
-@anchor{gnat_rm/implementation_of_specific_ada_features constant-aggregates-with-unconstrained-nominal-types}@anchor{3ce}@anchor{gnat_rm/implementation_of_specific_ada_features id9}@anchor{3cf}
+@anchor{gnat_rm/implementation_of_specific_ada_features constant-aggregates-with-unconstrained-nominal-types}@anchor{40c}@anchor{gnat_rm/implementation_of_specific_ada_features id9}@anchor{40d}
@subsection Constant aggregates with unconstrained nominal types
@@ -25482,7 +25700,7 @@ Cr_Unc : constant One_Unc := (12,24,36);
@end example
@node Aggregates with static bounds,Aggregates with nonstatic bounds,Constant aggregates with unconstrained nominal types,Code Generation for Array Aggregates
-@anchor{gnat_rm/implementation_of_specific_ada_features id10}@anchor{3d0}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-static-bounds}@anchor{3d1}
+@anchor{gnat_rm/implementation_of_specific_ada_features id10}@anchor{40e}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-static-bounds}@anchor{40f}
@subsection Aggregates with static bounds
@@ -25510,7 +25728,7 @@ end loop;
@end example
@node Aggregates with nonstatic bounds,Aggregates in assignment statements,Aggregates with static bounds,Code Generation for Array Aggregates
-@anchor{gnat_rm/implementation_of_specific_ada_features id11}@anchor{3d2}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-nonstatic-bounds}@anchor{3d3}
+@anchor{gnat_rm/implementation_of_specific_ada_features id11}@anchor{410}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-with-nonstatic-bounds}@anchor{411}
@subsection Aggregates with nonstatic bounds
@@ -25521,7 +25739,7 @@ have to be applied to sub-arrays individually, if they do not have statically
compatible subtypes.
@node Aggregates in assignment statements,,Aggregates with nonstatic bounds,Code Generation for Array Aggregates
-@anchor{gnat_rm/implementation_of_specific_ada_features id12}@anchor{3d4}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-in-assignment-statements}@anchor{3d5}
+@anchor{gnat_rm/implementation_of_specific_ada_features id12}@anchor{412}@anchor{gnat_rm/implementation_of_specific_ada_features aggregates-in-assignment-statements}@anchor{413}
@subsection Aggregates in assignment statements
@@ -25563,7 +25781,7 @@ a temporary (created either by the front-end or the code generator) and then
that temporary will be copied onto the target.
@node The Size of Discriminated Records with Default Discriminants,Strict Conformance to the Ada Reference Manual,Code Generation for Array Aggregates,Implementation of Specific Ada Features
-@anchor{gnat_rm/implementation_of_specific_ada_features id13}@anchor{3d6}@anchor{gnat_rm/implementation_of_specific_ada_features the-size-of-discriminated-records-with-default-discriminants}@anchor{3d7}
+@anchor{gnat_rm/implementation_of_specific_ada_features id13}@anchor{414}@anchor{gnat_rm/implementation_of_specific_ada_features the-size-of-discriminated-records-with-default-discriminants}@anchor{415}
@section The Size of Discriminated Records with Default Discriminants
@@ -25643,7 +25861,7 @@ say) must be consistent, so it is imperative that the object, once created,
remain invariant.
@node Strict Conformance to the Ada Reference Manual,,The Size of Discriminated Records with Default Discriminants,Implementation of Specific Ada Features
-@anchor{gnat_rm/implementation_of_specific_ada_features strict-conformance-to-the-ada-reference-manual}@anchor{3d8}@anchor{gnat_rm/implementation_of_specific_ada_features id14}@anchor{3d9}
+@anchor{gnat_rm/implementation_of_specific_ada_features strict-conformance-to-the-ada-reference-manual}@anchor{416}@anchor{gnat_rm/implementation_of_specific_ada_features id14}@anchor{417}
@section Strict Conformance to the Ada Reference Manual
@@ -25670,7 +25888,7 @@ behavior (although at the cost of a significant performance penalty), so
infinite and NaN values are properly generated.
@node Implementation of Ada 2012 Features,Obsolescent Features,Implementation of Specific Ada Features,Top
-@anchor{gnat_rm/implementation_of_ada_2012_features doc}@anchor{3da}@anchor{gnat_rm/implementation_of_ada_2012_features implementation-of-ada-2012-features}@anchor{14}@anchor{gnat_rm/implementation_of_ada_2012_features id1}@anchor{3db}
+@anchor{gnat_rm/implementation_of_ada_2012_features doc}@anchor{418}@anchor{gnat_rm/implementation_of_ada_2012_features implementation-of-ada-2012-features}@anchor{14}@anchor{gnat_rm/implementation_of_ada_2012_features id1}@anchor{419}
@chapter Implementation of Ada 2012 Features
@@ -27836,7 +28054,7 @@ RM References: H.04 (8/1)
@end itemize
@node Obsolescent Features,Compatibility and Porting Guide,Implementation of Ada 2012 Features,Top
-@anchor{gnat_rm/obsolescent_features id1}@anchor{3dc}@anchor{gnat_rm/obsolescent_features doc}@anchor{3dd}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{15}
+@anchor{gnat_rm/obsolescent_features id1}@anchor{41a}@anchor{gnat_rm/obsolescent_features doc}@anchor{41b}@anchor{gnat_rm/obsolescent_features obsolescent-features}@anchor{15}
@chapter Obsolescent Features
@@ -27855,7 +28073,7 @@ compatibility purposes.
@end menu
@node pragma No_Run_Time,pragma Ravenscar,,Obsolescent Features
-@anchor{gnat_rm/obsolescent_features id2}@anchor{3de}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{3df}
+@anchor{gnat_rm/obsolescent_features id2}@anchor{41c}@anchor{gnat_rm/obsolescent_features pragma-no-run-time}@anchor{41d}
@section pragma No_Run_Time
@@ -27868,7 +28086,7 @@ preferred usage is to use an appropriately configured run-time that
includes just those features that are to be made accessible.
@node pragma Ravenscar,pragma Restricted_Run_Time,pragma No_Run_Time,Obsolescent Features
-@anchor{gnat_rm/obsolescent_features id3}@anchor{3e0}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{3e1}
+@anchor{gnat_rm/obsolescent_features id3}@anchor{41e}@anchor{gnat_rm/obsolescent_features pragma-ravenscar}@anchor{41f}
@section pragma Ravenscar
@@ -27877,7 +28095,7 @@ The pragma @cite{Ravenscar} has exactly the same effect as pragma
is part of the new Ada 2005 standard.
@node pragma Restricted_Run_Time,pragma Task_Info,pragma Ravenscar,Obsolescent Features
-@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{3e2}@anchor{gnat_rm/obsolescent_features id4}@anchor{3e3}
+@anchor{gnat_rm/obsolescent_features pragma-restricted-run-time}@anchor{420}@anchor{gnat_rm/obsolescent_features id4}@anchor{421}
@section pragma Restricted_Run_Time
@@ -27887,7 +28105,7 @@ preferred since the Ada 2005 pragma @cite{Profile} is intended for
this kind of implementation dependent addition.
@node pragma Task_Info,package System Task_Info s-tasinf ads,pragma Restricted_Run_Time,Obsolescent Features
-@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{3e4}@anchor{gnat_rm/obsolescent_features id5}@anchor{3e5}
+@anchor{gnat_rm/obsolescent_features pragma-task-info}@anchor{422}@anchor{gnat_rm/obsolescent_features id5}@anchor{423}
@section pragma Task_Info
@@ -27913,7 +28131,7 @@ in the spec of package System.Task_Info in the runtime
library.
@node package System Task_Info s-tasinf ads,,pragma Task_Info,Obsolescent Features
-@anchor{gnat_rm/obsolescent_features package-system-task-info}@anchor{3e6}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{3e7}
+@anchor{gnat_rm/obsolescent_features package-system-task-info}@anchor{424}@anchor{gnat_rm/obsolescent_features package-system-task-info-s-tasinf-ads}@anchor{425}
@section package System.Task_Info (@code{s-tasinf.ads})
@@ -27923,7 +28141,7 @@ to support the @cite{Task_Info} pragma. The predefined Ada package
standard replacement for GNAT's @cite{Task_Info} functionality.
@node Compatibility and Porting Guide,GNU Free Documentation License,Obsolescent Features,Top
-@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{16}@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{3e8}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{3e9}
+@anchor{gnat_rm/compatibility_and_porting_guide compatibility-and-porting-guide}@anchor{16}@anchor{gnat_rm/compatibility_and_porting_guide doc}@anchor{426}@anchor{gnat_rm/compatibility_and_porting_guide id1}@anchor{427}
@chapter Compatibility and Porting Guide
@@ -27945,7 +28163,7 @@ applications developed in other Ada environments.
@end menu
@node Writing Portable Fixed-Point Declarations,Compatibility with Ada 83,,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide id2}@anchor{3ea}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{3eb}
+@anchor{gnat_rm/compatibility_and_porting_guide id2}@anchor{428}@anchor{gnat_rm/compatibility_and_porting_guide writing-portable-fixed-point-declarations}@anchor{429}
@section Writing Portable Fixed-Point Declarations
@@ -28067,7 +28285,7 @@ If you follow this scheme you will be guaranteed that your fixed-point
types will be portable.
@node Compatibility with Ada 83,Compatibility between Ada 95 and Ada 2005,Writing Portable Fixed-Point Declarations,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{3ec}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{3ed}
+@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-ada-83}@anchor{42a}@anchor{gnat_rm/compatibility_and_porting_guide id3}@anchor{42b}
@section Compatibility with Ada 83
@@ -28095,7 +28313,7 @@ following subsections treat the most likely issues to be encountered.
@end menu
@node Legal Ada 83 programs that are illegal in Ada 95,More deterministic semantics,,Compatibility with Ada 83
-@anchor{gnat_rm/compatibility_and_porting_guide id4}@anchor{3ee}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{3ef}
+@anchor{gnat_rm/compatibility_and_porting_guide id4}@anchor{42c}@anchor{gnat_rm/compatibility_and_porting_guide legal-ada-83-programs-that-are-illegal-in-ada-95}@anchor{42d}
@subsection Legal Ada 83 programs that are illegal in Ada 95
@@ -28195,7 +28413,7 @@ the fix is usually simply to add the @cite{(<>)} to the generic declaration.
@end itemize
@node More deterministic semantics,Changed semantics,Legal Ada 83 programs that are illegal in Ada 95,Compatibility with Ada 83
-@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{3f0}@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{3f1}
+@anchor{gnat_rm/compatibility_and_porting_guide more-deterministic-semantics}@anchor{42e}@anchor{gnat_rm/compatibility_and_porting_guide id5}@anchor{42f}
@subsection More deterministic semantics
@@ -28223,7 +28441,7 @@ which open select branches are executed.
@end itemize
@node Changed semantics,Other language compatibility issues,More deterministic semantics,Compatibility with Ada 83
-@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{3f2}@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{3f3}
+@anchor{gnat_rm/compatibility_and_porting_guide id6}@anchor{430}@anchor{gnat_rm/compatibility_and_porting_guide changed-semantics}@anchor{431}
@subsection Changed semantics
@@ -28265,7 +28483,7 @@ covers only the restricted range.
@end itemize
@node Other language compatibility issues,,Changed semantics,Compatibility with Ada 83
-@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{3f4}@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{3f5}
+@anchor{gnat_rm/compatibility_and_porting_guide other-language-compatibility-issues}@anchor{432}@anchor{gnat_rm/compatibility_and_porting_guide id7}@anchor{433}
@subsection Other language compatibility issues
@@ -28298,7 +28516,7 @@ include @cite{pragma Interface} and the floating point type attributes
@end itemize
@node Compatibility between Ada 95 and Ada 2005,Implementation-dependent characteristics,Compatibility with Ada 83,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide compatibility-between-ada-95-and-ada-2005}@anchor{3f6}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{3f7}
+@anchor{gnat_rm/compatibility_and_porting_guide compatibility-between-ada-95-and-ada-2005}@anchor{434}@anchor{gnat_rm/compatibility_and_porting_guide id8}@anchor{435}
@section Compatibility between Ada 95 and Ada 2005
@@ -28370,7 +28588,7 @@ can declare a function returning a value from an anonymous access type.
@end itemize
@node Implementation-dependent characteristics,Compatibility with Other Ada Systems,Compatibility between Ada 95 and Ada 2005,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{3f8}@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{3f9}
+@anchor{gnat_rm/compatibility_and_porting_guide implementation-dependent-characteristics}@anchor{436}@anchor{gnat_rm/compatibility_and_porting_guide id9}@anchor{437}
@section Implementation-dependent characteristics
@@ -28393,7 +28611,7 @@ transition from certain Ada 83 compilers.
@end menu
@node Implementation-defined pragmas,Implementation-defined attributes,,Implementation-dependent characteristics
-@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{3fa}@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{3fb}
+@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-pragmas}@anchor{438}@anchor{gnat_rm/compatibility_and_porting_guide id10}@anchor{439}
@subsection Implementation-defined pragmas
@@ -28415,7 +28633,7 @@ avoiding compiler rejection of units that contain such pragmas; they are not
relevant in a GNAT context and hence are not otherwise implemented.
@node Implementation-defined attributes,Libraries,Implementation-defined pragmas,Implementation-dependent characteristics
-@anchor{gnat_rm/compatibility_and_porting_guide id11}@anchor{3fc}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{3fd}
+@anchor{gnat_rm/compatibility_and_porting_guide id11}@anchor{43a}@anchor{gnat_rm/compatibility_and_porting_guide implementation-defined-attributes}@anchor{43b}
@subsection Implementation-defined attributes
@@ -28429,7 +28647,7 @@ Ada 83, GNAT supplies the attributes @cite{Bit}, @cite{Machine_Size} and
@cite{Type_Class}.
@node Libraries,Elaboration order,Implementation-defined attributes,Implementation-dependent characteristics
-@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{3fe}@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{3ff}
+@anchor{gnat_rm/compatibility_and_porting_guide libraries}@anchor{43c}@anchor{gnat_rm/compatibility_and_porting_guide id12}@anchor{43d}
@subsection Libraries
@@ -28458,7 +28676,7 @@ be preferable to retrofit the application using modular types.
@end itemize
@node Elaboration order,Target-specific aspects,Libraries,Implementation-dependent characteristics
-@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{400}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{401}
+@anchor{gnat_rm/compatibility_and_porting_guide elaboration-order}@anchor{43e}@anchor{gnat_rm/compatibility_and_porting_guide id13}@anchor{43f}
@subsection Elaboration order
@@ -28494,7 +28712,7 @@ pragmas either globally (as an effect of the @emph{-gnatE} switch) or locally
@end itemize
@node Target-specific aspects,,Elaboration order,Implementation-dependent characteristics
-@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{402}@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{403}
+@anchor{gnat_rm/compatibility_and_porting_guide target-specific-aspects}@anchor{440}@anchor{gnat_rm/compatibility_and_porting_guide id14}@anchor{441}
@subsection Target-specific aspects
@@ -28507,10 +28725,10 @@ on the robustness of the original design. Moreover, Ada 95 (and thus
Ada 2005 and Ada 2012) are sometimes
incompatible with typical Ada 83 compiler practices regarding implicit
packing, the meaning of the Size attribute, and the size of access values.
-GNAT's approach to these issues is described in @ref{404,,Representation Clauses}.
+GNAT's approach to these issues is described in @ref{442,,Representation Clauses}.
@node Compatibility with Other Ada Systems,Representation Clauses,Implementation-dependent characteristics,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{405}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{406}
+@anchor{gnat_rm/compatibility_and_porting_guide id15}@anchor{443}@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-other-ada-systems}@anchor{444}
@section Compatibility with Other Ada Systems
@@ -28553,7 +28771,7 @@ far beyond this minimal set, as described in the next section.
@end itemize
@node Representation Clauses,Compatibility with HP Ada 83,Compatibility with Other Ada Systems,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{404}@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{407}
+@anchor{gnat_rm/compatibility_and_porting_guide representation-clauses}@anchor{442}@anchor{gnat_rm/compatibility_and_porting_guide id16}@anchor{445}
@section Representation Clauses
@@ -28646,7 +28864,7 @@ with thin pointers.
@end itemize
@node Compatibility with HP Ada 83,,Representation Clauses,Compatibility and Porting Guide
-@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-hp-ada-83}@anchor{408}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{409}
+@anchor{gnat_rm/compatibility_and_porting_guide compatibility-with-hp-ada-83}@anchor{446}@anchor{gnat_rm/compatibility_and_porting_guide id17}@anchor{447}
@section Compatibility with HP Ada 83
@@ -28676,7 +28894,7 @@ extension of package System.
@end itemize
@node GNU Free Documentation License,Index,Compatibility and Porting Guide,Top
-@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license doc}@anchor{40a}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{40b}
+@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license doc}@anchor{448}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{449}
@chapter GNU Free Documentation License
diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi
index a771687fa1..1916d1efc5 100644
--- a/gcc/ada/gnat_ugn.texi
+++ b/gcc/ada/gnat_ugn.texi
@@ -21,11 +21,11 @@
@copying
@quotation
-GNAT User's Guide for Native Platforms , November 18, 2015
+GNAT User's Guide for Native Platforms , January 13, 2017
AdaCore
-Copyright @copyright{} 2008-2016, Free Software Foundation
+Copyright @copyright{} 2008-2017, Free Software Foundation
@end quotation
@end copying
@@ -68,8 +68,6 @@ included in the section entitled @ref{1,,GNU Free Documentation License}.
* Getting Started with GNAT::
* The GNAT Compilation Model::
* Building Executable Programs with GNAT::
-* GNAT Project Manager::
-* Tools Supporting Project Files::
* GNAT Utility Programs::
* GNAT and Program Execution::
* Platform-Specific Information::
@@ -239,6 +237,7 @@ Building Executable Programs with GNAT
* Building with gnatmake::
* Compiling with gcc::
* Compiler Switches::
+* Linker Switches::
* Binding with gnatbind::
* Linking with gnatlink::
* Using the GNU make Utility::
@@ -310,108 +309,6 @@ Using the GNU make Utility
* Generating the Command Line Switches::
* Overcoming Command Line Length Limits::
-GNAT Project Manager
-
-* Introduction::
-* Building With Projects::
-* Organizing Projects into Subsystems::
-* Scenarios in Projects::
-* Library Projects::
-* Project Extension::
-* Aggregate Projects::
-* Aggregate Library Projects::
-* Project File Reference::
-
-Building With Projects
-
-* Source Files and Directories::
-* Duplicate Sources in Projects::
-* Object and Exec Directory::
-* Main Subprograms::
-* Tools Options in Project Files::
-* Compiling with Project Files::
-* Executable File Names::
-* Avoid Duplication With Variables::
-* Naming Schemes::
-* Installation::
-* Distributed support::
-
-Organizing Projects into Subsystems
-
-* Project Dependencies::
-* Cyclic Project Dependencies::
-* Sharing Between Projects::
-* Global Attributes::
-
-Library Projects
-
-* Building Libraries::
-* Using Library Projects::
-* Stand-alone Library Projects::
-* Installing a library with project files::
-
-Project Extension
-
-* Project Hierarchy Extension::
-
-Aggregate Projects
-
-* Building all main programs from a single project tree::
-* Building a set of projects with a single command::
-* Define a build environment::
-* Performance improvements in builder::
-* Syntax of aggregate projects::
-* package Builder in aggregate projects::
-
-Aggregate Library Projects
-
-* Building aggregate library projects::
-* Syntax of aggregate library projects::
-
-Project File Reference
-
-* Project Declaration::
-* Qualified Projects::
-* Declarations::
-* Packages::
-* Expressions::
-* External Values::
-* Typed String Declaration::
-* Variables::
-* Case Constructions::
-* Attributes::
-
-Attributes
-
-* Project Level Attributes::
-* Package Binder Attributes::
-* Package Builder Attributes::
-* Package Clean Attributes::
-* Package Compiler Attributes::
-* Package Cross_Reference Attributes::
-* Package Finder Attributes::
-* Package gnatls Attributes::
-* Package IDE Attributes::
-* Package Install Attributes::
-* Package Linker Attributes::
-* Package Naming Attributes::
-* Package Remote Attributes::
-* Package Stack Attributes::
-* Package Synchronize Attributes::
-
-Tools Supporting Project Files
-
-* gnatmake and Project Files::
-* The GNAT Driver and Project Files::
-
-gnatmake and Project Files
-
-* Switches Related to Project Files::
-* Switches and Project Files::
-* Specifying Configuration Pragmas::
-* Project Files and Main Subprograms::
-* Library Project Files::
-
GNAT Utility Programs
* The File Cleanup Utility gnatclean::
@@ -568,6 +465,7 @@ Microsoft Windows Topics
* Using a network installation of GNAT::
* CONSOLE and WINDOWS subsystems::
* Temporary Files::
+* Disabling Command Line Argument Expansion::
* Mixed-Language Programming on Windows::
* Windows Specific Add-Ons::
@@ -717,19 +615,11 @@ main GNAT tools to build executable programs, and it also gives examples of
using the GNU make utility with GNAT.
@item
-@ref{b,,GNAT Project Manager} describes how to use project files
-to organize large projects.
-
-@item
-@ref{c,,Tools Supporting Project Files} described how to use the project
-facility in conjunction with various GNAT tools.
-
-@item
-@ref{d,,GNAT Utility Programs} explains the various utility programs that
+@ref{b,,GNAT Utility Programs} explains the various utility programs that
are included in the GNAT environment
@item
-@ref{e,,GNAT and Program Execution} covers a number of topics related to
+@ref{c,,GNAT and Program Execution} covers a number of topics related to
running, debugging, and tuning the performace of programs developed
with GNAT
@end itemize
@@ -740,25 +630,25 @@ Appendices cover several additional topics:
@itemize *
@item
-@ref{f,,Platform-Specific Information} describes the different run-time
+@ref{d,,Platform-Specific Information} describes the different run-time
library implementations and also presents information on how to use
GNAT on several specific platforms
@item
-@ref{10,,Example of Binder Output File} shows the source code for the binder
+@ref{e,,Example of Binder Output File} shows the source code for the binder
output file for a sample program.
@item
-@ref{11,,Elaboration Order Handling in GNAT} describes how GNAT helps
+@ref{f,,Elaboration Order Handling in GNAT} describes how GNAT helps
you deal with elaboration order issues.
@item
-@ref{12,,Inline Assembler} shows how to use the inline assembly facility
+@ref{10,,Inline Assembler} shows how to use the inline assembly facility
in an Ada program.
@end itemize
@node What You Should Know before Reading This Guide,Related Information,What This Guide Contains,About This Guide
-@anchor{gnat_ugn/about_this_guide what-you-should-know-before-reading-this-guide}@anchor{13}
+@anchor{gnat_ugn/about_this_guide what-you-should-know-before-reading-this-guide}@anchor{11}
@section What You Should Know before Reading This Guide
@@ -775,7 +665,7 @@ Reference manuals for Ada 95, Ada 2005, and Ada 2012 are included in
the GNAT documentation package.
@node Related Information,A Note to Readers of Previous Versions of the Manual,What You Should Know before Reading This Guide,About This Guide
-@anchor{gnat_ugn/about_this_guide related-information}@anchor{14}
+@anchor{gnat_ugn/about_this_guide related-information}@anchor{12}
@section Related Information
@@ -813,7 +703,7 @@ environment Emacs.
@end itemize
@node A Note to Readers of Previous Versions of the Manual,Conventions,Related Information,About This Guide
-@anchor{gnat_ugn/about_this_guide a-note-to-readers-of-previous-versions-of-the-manual}@anchor{15}
+@anchor{gnat_ugn/about_this_guide a-note-to-readers-of-previous-versions-of-the-manual}@anchor{13}
@section A Note to Readers of Previous Versions of the Manual
@@ -838,20 +728,20 @@ the following material:
The @cite{gnatname}, @cite{gnatkr}, and @cite{gnatchop} tools
@item
-@ref{16,,Configuration Pragmas}
+@ref{14,,Configuration Pragmas}
@item
-@ref{17,,GNAT and Libraries}
+@ref{15,,GNAT and Libraries}
@item
-@ref{18,,Conditional Compilation} including @ref{19,,Preprocessing with gnatprep}
-and @ref{1a,,Integrated Preprocessing}
+@ref{16,,Conditional Compilation} including @ref{17,,Preprocessing with gnatprep}
+and @ref{18,,Integrated Preprocessing}
@item
-@ref{1b,,Generating Ada Bindings for C and C++ headers}
+@ref{19,,Generating Ada Bindings for C and C++ headers}
@item
-@ref{1c,,Using GNAT Files with External Tools}
+@ref{1a,,Using GNAT Files with External Tools}
@end itemize
@item
@@ -862,23 +752,23 @@ the following content:
@itemize -
@item
-@ref{1d,,Building with gnatmake}
+@ref{1b,,Building with gnatmake}
@item
-@ref{1e,,Compiling with gcc}
+@ref{1c,,Compiling with gcc}
@item
-@ref{1f,,Binding with gnatbind}
+@ref{1d,,Binding with gnatbind}
@item
-@ref{20,,Linking with gnatlink}
+@ref{1e,,Linking with gnatlink}
@item
-@ref{21,,Using the GNU make Utility}
+@ref{1f,,Using the GNU make Utility}
@end itemize
@item
-@ref{d,,GNAT Utility Programs} is a new chapter consolidating the information about several
+@ref{b,,GNAT Utility Programs} is a new chapter consolidating the information about several
GNAT tools:
@@ -886,60 +776,60 @@ GNAT tools:
@itemize -
@item
-@ref{22,,The File Cleanup Utility gnatclean}
+@ref{20,,The File Cleanup Utility gnatclean}
@item
-@ref{23,,The GNAT Library Browser gnatls}
+@ref{21,,The GNAT Library Browser gnatls}
@item
-@ref{24,,The Cross-Referencing Tools gnatxref and gnatfind}
+@ref{22,,The Cross-Referencing Tools gnatxref and gnatfind}
@item
-@ref{25,,The Ada to HTML Converter gnathtml}
+@ref{23,,The Ada to HTML Converter gnathtml}
@end itemize
@item
-@ref{e,,GNAT and Program Execution} is a new chapter consolidating the following:
+@ref{c,,GNAT and Program Execution} is a new chapter consolidating the following:
@itemize -
@item
-@ref{26,,Running and Debugging Ada Programs}
+@ref{24,,Running and Debugging Ada Programs}
@item
-@ref{27,,Code Coverage and Profiling}
+@ref{25,,Code Coverage and Profiling}
@item
-@ref{28,,Improving Performance}
+@ref{26,,Improving Performance}
@item
-@ref{29,,Overflow Check Handling in GNAT}
+@ref{27,,Overflow Check Handling in GNAT}
@item
-@ref{2a,,Performing Dimensionality Analysis in GNAT}
+@ref{28,,Performing Dimensionality Analysis in GNAT}
@item
-@ref{2b,,Stack Related Facilities}
+@ref{29,,Stack Related Facilities}
@item
-@ref{2c,,Memory Management Issues}
+@ref{2a,,Memory Management Issues}
@end itemize
@item
-@ref{f,,Platform-Specific Information} is a new appendix consolidating the following:
+@ref{d,,Platform-Specific Information} is a new appendix consolidating the following:
@itemize -
@item
-@ref{2d,,Run-Time Libraries}
+@ref{2b,,Run-Time Libraries}
@item
-@ref{2e,,Microsoft Windows Topics}
+@ref{2c,,Microsoft Windows Topics}
@item
-@ref{2f,,Mac OS Topics}
+@ref{2d,,Mac OS Topics}
@end itemize
@item
@@ -950,7 +840,7 @@ a separate chapter in the @cite{GNAT User's Guide}.
@end itemize
@node Conventions,,A Note to Readers of Previous Versions of the Manual,About This Guide
-@anchor{gnat_ugn/about_this_guide conventions}@anchor{30}
+@anchor{gnat_ugn/about_this_guide conventions}@anchor{2e}
@section Conventions
@@ -1003,7 +893,7 @@ the '\' character should be used instead.
@end itemize
@node Getting Started with GNAT,The GNAT Compilation Model,About This Guide,Top
-@anchor{gnat_ugn/getting_started_with_gnat getting-started-with-gnat}@anchor{8}@anchor{gnat_ugn/getting_started_with_gnat doc}@anchor{31}@anchor{gnat_ugn/getting_started_with_gnat id1}@anchor{32}
+@anchor{gnat_ugn/getting_started_with_gnat getting-started-with-gnat}@anchor{8}@anchor{gnat_ugn/getting_started_with_gnat doc}@anchor{2f}@anchor{gnat_ugn/getting_started_with_gnat id1}@anchor{30}
@chapter Getting Started with GNAT
@@ -1026,7 +916,7 @@ For information on GPS please refer to
@end menu
@node Running GNAT,Running a Simple Ada Program,,Getting Started with GNAT
-@anchor{gnat_ugn/getting_started_with_gnat running-gnat}@anchor{33}@anchor{gnat_ugn/getting_started_with_gnat id2}@anchor{34}
+@anchor{gnat_ugn/getting_started_with_gnat running-gnat}@anchor{31}@anchor{gnat_ugn/getting_started_with_gnat id2}@anchor{32}
@section Running GNAT
@@ -1051,7 +941,7 @@ utility program that, given the name of the main program, automatically
performs the necessary compilation, binding and linking steps.
@node Running a Simple Ada Program,Running a Program with Multiple Units,Running GNAT,Getting Started with GNAT
-@anchor{gnat_ugn/getting_started_with_gnat running-a-simple-ada-program}@anchor{35}@anchor{gnat_ugn/getting_started_with_gnat id3}@anchor{36}
+@anchor{gnat_ugn/getting_started_with_gnat running-a-simple-ada-program}@anchor{33}@anchor{gnat_ugn/getting_started_with_gnat id3}@anchor{34}
@section Running a Simple Ada Program
@@ -1080,12 +970,12 @@ extension is @code{ads} for a
spec and @code{adb} for a body.
You can override this default file naming convention by use of the
special pragma @cite{Source_File_Name} (for further information please
-see @ref{37,,Using Other File Names}).
+see @ref{35,,Using Other File Names}).
Alternatively, if you want to rename your files according to this default
convention, which is probably more convenient if you will be using GNAT
for all your compilations, then the @cite{gnatchop} utility
can be used to generate correctly-named source files
-(see @ref{38,,Renaming Files with gnatchop}).
+(see @ref{36,,Renaming Files with gnatchop}).
You can compile the program using the following command (@cite{$} is used
as the command prompt in the examples in this document):
@@ -1156,7 +1046,7 @@ Hello WORLD!
appear in response to this command.
@node Running a Program with Multiple Units,Using the gnatmake Utility,Running a Simple Ada Program,Getting Started with GNAT
-@anchor{gnat_ugn/getting_started_with_gnat id4}@anchor{39}@anchor{gnat_ugn/getting_started_with_gnat running-a-program-with-multiple-units}@anchor{3a}
+@anchor{gnat_ugn/getting_started_with_gnat id4}@anchor{37}@anchor{gnat_ugn/getting_started_with_gnat running-a-program-with-multiple-units}@anchor{38}
@section Running a Program with Multiple Units
@@ -1245,7 +1135,7 @@ In the next section we discuss the advantages of using @emph{gnatmake} in
more detail.
@node Using the gnatmake Utility,,Running a Program with Multiple Units,Getting Started with GNAT
-@anchor{gnat_ugn/getting_started_with_gnat using-the-gnatmake-utility}@anchor{3b}@anchor{gnat_ugn/getting_started_with_gnat id5}@anchor{3c}
+@anchor{gnat_ugn/getting_started_with_gnat using-the-gnatmake-utility}@anchor{39}@anchor{gnat_ugn/getting_started_with_gnat id5}@anchor{3a}
@section Using the @emph{gnatmake} Utility
@@ -1298,7 +1188,7 @@ dependencies from scratch each time it is run.
@c -- Example: A |withing| unit has a |with| clause, it |withs| a |withed| unit
@node The GNAT Compilation Model,Building Executable Programs with GNAT,Getting Started with GNAT,Top
-@anchor{gnat_ugn/the_gnat_compilation_model doc}@anchor{3d}@anchor{gnat_ugn/the_gnat_compilation_model the-gnat-compilation-model}@anchor{9}@anchor{gnat_ugn/the_gnat_compilation_model id1}@anchor{3e}
+@anchor{gnat_ugn/the_gnat_compilation_model doc}@anchor{3b}@anchor{gnat_ugn/the_gnat_compilation_model the-gnat-compilation-model}@anchor{9}@anchor{gnat_ugn/the_gnat_compilation_model id1}@anchor{3c}
@chapter The GNAT Compilation Model
@@ -1322,44 +1212,44 @@ Topics related to source file makeup and naming
@itemize *
@item
-@ref{3f,,Source Representation}
+@ref{3d,,Source Representation}
@item
-@ref{40,,Foreign Language Representation}
+@ref{3e,,Foreign Language Representation}
@item
-@ref{41,,File Naming Topics and Utilities}
+@ref{3f,,File Naming Topics and Utilities}
@end itemize
@item
-@ref{16,,Configuration Pragmas}
+@ref{14,,Configuration Pragmas}
@item
-@ref{42,,Generating Object Files}
+@ref{40,,Generating Object Files}
@item
-@ref{43,,Source Dependencies}
+@ref{41,,Source Dependencies}
@item
-@ref{44,,The Ada Library Information Files}
+@ref{42,,The Ada Library Information Files}
@item
-@ref{45,,Binding an Ada Program}
+@ref{43,,Binding an Ada Program}
@item
-@ref{17,,GNAT and Libraries}
+@ref{15,,GNAT and Libraries}
@item
-@ref{18,,Conditional Compilation}
+@ref{16,,Conditional Compilation}
@item
-@ref{46,,Mixed Language Programming}
+@ref{44,,Mixed Language Programming}
@item
-@ref{47,,GNAT and Other Compilation Models}
+@ref{45,,GNAT and Other Compilation Models}
@item
-@ref{1c,,Using GNAT Files with External Tools}
+@ref{1a,,Using GNAT Files with External Tools}
@end itemize
@menu
@@ -1380,7 +1270,7 @@ Topics related to source file makeup and naming
@end menu
@node Source Representation,Foreign Language Representation,,The GNAT Compilation Model
-@anchor{gnat_ugn/the_gnat_compilation_model source-representation}@anchor{3f}@anchor{gnat_ugn/the_gnat_compilation_model id2}@anchor{48}
+@anchor{gnat_ugn/the_gnat_compilation_model source-representation}@anchor{3d}@anchor{gnat_ugn/the_gnat_compilation_model id2}@anchor{46}
@section Source Representation
@@ -1395,7 +1285,7 @@ Topics related to source file makeup and naming
Ada source programs are represented in standard text files, using
Latin-1 coding. Latin-1 is an 8-bit code that includes the familiar
7-bit ASCII set, plus additional characters used for
-representing foreign languages (see @ref{40,,Foreign Language Representation}
+representing foreign languages (see @ref{3e,,Foreign Language Representation}
for support of non-USA character sets). The format effector characters
are represented using their standard ASCII encodings, as follows:
@@ -1506,13 +1396,13 @@ compilation units) is represented using a sequence of files. Similarly,
you will place each subunit or child unit in a separate file.
@node Foreign Language Representation,File Naming Topics and Utilities,Source Representation,The GNAT Compilation Model
-@anchor{gnat_ugn/the_gnat_compilation_model foreign-language-representation}@anchor{40}@anchor{gnat_ugn/the_gnat_compilation_model id3}@anchor{49}
+@anchor{gnat_ugn/the_gnat_compilation_model foreign-language-representation}@anchor{3e}@anchor{gnat_ugn/the_gnat_compilation_model id3}@anchor{47}
@section Foreign Language Representation
GNAT supports the standard character sets defined in Ada as well as
several other non-standard character sets for use in localized versions
-of the compiler (@ref{4a,,Character Set Control}).
+of the compiler (@ref{48,,Character Set Control}).
@menu
* Latin-1::
@@ -1523,7 +1413,7 @@ of the compiler (@ref{4a,,Character Set Control}).
@end menu
@node Latin-1,Other 8-Bit Codes,,Foreign Language Representation
-@anchor{gnat_ugn/the_gnat_compilation_model id4}@anchor{4b}@anchor{gnat_ugn/the_gnat_compilation_model latin-1}@anchor{4c}
+@anchor{gnat_ugn/the_gnat_compilation_model id4}@anchor{49}@anchor{gnat_ugn/the_gnat_compilation_model latin-1}@anchor{4a}
@subsection Latin-1
@@ -1546,7 +1436,7 @@ string literals. In addition, the extended characters that represent
letters can be used in identifiers.
@node Other 8-Bit Codes,Wide_Character Encodings,Latin-1,Foreign Language Representation
-@anchor{gnat_ugn/the_gnat_compilation_model other-8-bit-codes}@anchor{4d}@anchor{gnat_ugn/the_gnat_compilation_model id5}@anchor{4e}
+@anchor{gnat_ugn/the_gnat_compilation_model other-8-bit-codes}@anchor{4b}@anchor{gnat_ugn/the_gnat_compilation_model id5}@anchor{4c}
@subsection Other 8-Bit Codes
@@ -1663,7 +1553,7 @@ the GNAT compiler sources. You will need to obtain a full source release
of GNAT to obtain this file.
@node Wide_Character Encodings,Wide_Wide_Character Encodings,Other 8-Bit Codes,Foreign Language Representation
-@anchor{gnat_ugn/the_gnat_compilation_model id6}@anchor{4f}@anchor{gnat_ugn/the_gnat_compilation_model wide-character-encodings}@anchor{50}
+@anchor{gnat_ugn/the_gnat_compilation_model id6}@anchor{4d}@anchor{gnat_ugn/the_gnat_compilation_model wide-character-encodings}@anchor{4e}
@subsection Wide_Character Encodings
@@ -1774,7 +1664,7 @@ use of the upper half of the Latin-1 set.
@end cartouche
@node Wide_Wide_Character Encodings,,Wide_Character Encodings,Foreign Language Representation
-@anchor{gnat_ugn/the_gnat_compilation_model id7}@anchor{51}@anchor{gnat_ugn/the_gnat_compilation_model wide-wide-character-encodings}@anchor{52}
+@anchor{gnat_ugn/the_gnat_compilation_model id7}@anchor{4f}@anchor{gnat_ugn/the_gnat_compilation_model wide-wide-character-encodings}@anchor{50}
@subsection Wide_Wide_Character Encodings
@@ -1826,7 +1716,7 @@ ACATS (Ada Conformity Assessment Test Suite) test suite distributions.
@end table
@node File Naming Topics and Utilities,Configuration Pragmas,Foreign Language Representation,The GNAT Compilation Model
-@anchor{gnat_ugn/the_gnat_compilation_model id8}@anchor{53}@anchor{gnat_ugn/the_gnat_compilation_model file-naming-topics-and-utilities}@anchor{41}
+@anchor{gnat_ugn/the_gnat_compilation_model id8}@anchor{51}@anchor{gnat_ugn/the_gnat_compilation_model file-naming-topics-and-utilities}@anchor{3f}
@section File Naming Topics and Utilities
@@ -1845,7 +1735,7 @@ source files correspond to the Ada compilation units that they contain.
@end menu
@node File Naming Rules,Using Other File Names,,File Naming Topics and Utilities
-@anchor{gnat_ugn/the_gnat_compilation_model file-naming-rules}@anchor{54}@anchor{gnat_ugn/the_gnat_compilation_model id9}@anchor{55}
+@anchor{gnat_ugn/the_gnat_compilation_model file-naming-rules}@anchor{52}@anchor{gnat_ugn/the_gnat_compilation_model id9}@anchor{53}
@subsection File Naming Rules
@@ -1954,7 +1844,7 @@ unit names are long (for example, if child units or subunits are
heavily nested). An option is available to shorten such long file names
(called file name 'krunching'). This may be particularly useful when
programs being developed with GNAT are to be used on operating systems
-with limited file name lengths. @ref{56,,Using gnatkr}.
+with limited file name lengths. @ref{54,,Using gnatkr}.
Of course, no file shortening algorithm can guarantee uniqueness over
all possible unit names; if file name krunching is used, it is your
@@ -1963,7 +1853,7 @@ can specify the exact file names that you want used, as described
in the next section. Finally, if your Ada programs are migrating from a
compiler with a different naming convention, you can use the gnatchop
utility to produce source files that follow the GNAT naming conventions.
-(For details see @ref{38,,Renaming Files with gnatchop}.)
+(For details see @ref{36,,Renaming Files with gnatchop}.)
Note: in the case of Windows or Mac OS operating systems, case is not
significant. So for example on @cite{Windows} if the canonical name is
@@ -1973,7 +1863,7 @@ if you want to use other than canonically cased file names on a Unix system,
you need to follow the procedures described in the next section.
@node Using Other File Names,Alternative File Naming Schemes,File Naming Rules,File Naming Topics and Utilities
-@anchor{gnat_ugn/the_gnat_compilation_model id10}@anchor{57}@anchor{gnat_ugn/the_gnat_compilation_model using-other-file-names}@anchor{37}
+@anchor{gnat_ugn/the_gnat_compilation_model id10}@anchor{55}@anchor{gnat_ugn/the_gnat_compilation_model using-other-file-names}@anchor{35}
@subsection Using Other File Names
@@ -2011,7 +1901,7 @@ normally it will be placed in the @code{gnat.adc}
file used to hold configuration
pragmas that apply to a complete compilation environment.
For more details on how the @code{gnat.adc} file is created and used
-see @ref{58,,Handling of Configuration Pragmas}.
+see @ref{56,,Handling of Configuration Pragmas}.
@geindex gnat.adc
@@ -2033,7 +1923,7 @@ then it must be included in the @cite{gnatmake} command, it may not
be omitted.
@node Alternative File Naming Schemes,Handling Arbitrary File Naming Conventions with gnatname,Using Other File Names,File Naming Topics and Utilities
-@anchor{gnat_ugn/the_gnat_compilation_model id11}@anchor{59}@anchor{gnat_ugn/the_gnat_compilation_model alternative-file-naming-schemes}@anchor{5a}
+@anchor{gnat_ugn/the_gnat_compilation_model id11}@anchor{57}@anchor{gnat_ugn/the_gnat_compilation_model alternative-file-naming-schemes}@anchor{58}
@subsection Alternative File Naming Schemes
@@ -2177,7 +2067,7 @@ pragma Source_File_Name
@geindex gnatname
@node Handling Arbitrary File Naming Conventions with gnatname,File Name Krunching with gnatkr,Alternative File Naming Schemes,File Naming Topics and Utilities
-@anchor{gnat_ugn/the_gnat_compilation_model handling-arbitrary-file-naming-conventions-with-gnatname}@anchor{5b}@anchor{gnat_ugn/the_gnat_compilation_model id12}@anchor{5c}
+@anchor{gnat_ugn/the_gnat_compilation_model handling-arbitrary-file-naming-conventions-with-gnatname}@anchor{59}@anchor{gnat_ugn/the_gnat_compilation_model id12}@anchor{5a}
@subsection Handling Arbitrary File Naming Conventions with @cite{gnatname}
@@ -2192,7 +2082,7 @@ pragma Source_File_Name
@end menu
@node Arbitrary File Naming Conventions,Running gnatname,,Handling Arbitrary File Naming Conventions with gnatname
-@anchor{gnat_ugn/the_gnat_compilation_model arbitrary-file-naming-conventions}@anchor{5d}@anchor{gnat_ugn/the_gnat_compilation_model id13}@anchor{5e}
+@anchor{gnat_ugn/the_gnat_compilation_model arbitrary-file-naming-conventions}@anchor{5b}@anchor{gnat_ugn/the_gnat_compilation_model id13}@anchor{5c}
@subsubsection Arbitrary File Naming Conventions
@@ -2203,11 +2093,11 @@ does not need additional information.
When the source file names do not follow the standard GNAT default file naming
conventions, the GNAT compiler must be given additional information through
-a configuration pragmas file (@ref{16,,Configuration Pragmas})
+a configuration pragmas file (@ref{14,,Configuration Pragmas})
or a project file.
When the non-standard file naming conventions are well-defined,
a small number of pragmas @cite{Source_File_Name} specifying a naming pattern
-(@ref{5a,,Alternative File Naming Schemes}) may be sufficient. However,
+(@ref{58,,Alternative File Naming Schemes}) may be sufficient. However,
if the file naming conventions are irregular or arbitrary, a number
of pragma @cite{Source_File_Name} for individual compilation units
must be defined.
@@ -2217,7 +2107,7 @@ GNAT provides a tool @cite{gnatname} to generate the required pragmas for a
set of files.
@node Running gnatname,Switches for gnatname,Arbitrary File Naming Conventions,Handling Arbitrary File Naming Conventions with gnatname
-@anchor{gnat_ugn/the_gnat_compilation_model running-gnatname}@anchor{5f}@anchor{gnat_ugn/the_gnat_compilation_model id14}@anchor{60}
+@anchor{gnat_ugn/the_gnat_compilation_model running-gnatname}@anchor{5d}@anchor{gnat_ugn/the_gnat_compilation_model id14}@anchor{5e}
@subsubsection Running @cite{gnatname}
@@ -2268,7 +2158,7 @@ with pragmas @cite{Source_File_Name} for each file that contains a valid Ada
unit.
@node Switches for gnatname,Examples of gnatname Usage,Running gnatname,Handling Arbitrary File Naming Conventions with gnatname
-@anchor{gnat_ugn/the_gnat_compilation_model id15}@anchor{61}@anchor{gnat_ugn/the_gnat_compilation_model switches-for-gnatname}@anchor{62}
+@anchor{gnat_ugn/the_gnat_compilation_model id15}@anchor{5f}@anchor{gnat_ugn/the_gnat_compilation_model switches-for-gnatname}@anchor{60}
@subsubsection Switches for @cite{gnatname}
@@ -2451,7 +2341,7 @@ except those whose names end with @code{_nt.ada}.
@end table
@node Examples of gnatname Usage,,Switches for gnatname,Handling Arbitrary File Naming Conventions with gnatname
-@anchor{gnat_ugn/the_gnat_compilation_model examples-of-gnatname-usage}@anchor{63}@anchor{gnat_ugn/the_gnat_compilation_model id16}@anchor{64}
+@anchor{gnat_ugn/the_gnat_compilation_model examples-of-gnatname-usage}@anchor{61}@anchor{gnat_ugn/the_gnat_compilation_model id16}@anchor{62}
@subsubsection Examples of @cite{gnatname} Usage
@@ -2477,13 +2367,13 @@ even in conjunction with one or several switches
are used in this example.
@node File Name Krunching with gnatkr,Renaming Files with gnatchop,Handling Arbitrary File Naming Conventions with gnatname,File Naming Topics and Utilities
-@anchor{gnat_ugn/the_gnat_compilation_model file-name-krunching-with-gnatkr}@anchor{65}@anchor{gnat_ugn/the_gnat_compilation_model id17}@anchor{66}
+@anchor{gnat_ugn/the_gnat_compilation_model file-name-krunching-with-gnatkr}@anchor{63}@anchor{gnat_ugn/the_gnat_compilation_model id17}@anchor{64}
@subsection File Name Krunching with @cite{gnatkr}
@geindex gnatkr
-This chapter discusses the method used by the compiler to shorten
+This section discusses the method used by the compiler to shorten
the default file names chosen for Ada units so that they do not
exceed the maximum length permitted. It also describes the
@cite{gnatkr} utility that can be used to determine the result of
@@ -2498,7 +2388,7 @@ applying this shortening.
@end menu
@node About gnatkr,Using gnatkr,,File Name Krunching with gnatkr
-@anchor{gnat_ugn/the_gnat_compilation_model id18}@anchor{67}@anchor{gnat_ugn/the_gnat_compilation_model about-gnatkr}@anchor{68}
+@anchor{gnat_ugn/the_gnat_compilation_model id18}@anchor{65}@anchor{gnat_ugn/the_gnat_compilation_model about-gnatkr}@anchor{66}
@subsubsection About @cite{gnatkr}
@@ -2536,7 +2426,7 @@ The @cite{gnatkr} utility can be used to determine the krunched name for
a given file, when krunched to a specified maximum length.
@node Using gnatkr,Krunching Method,About gnatkr,File Name Krunching with gnatkr
-@anchor{gnat_ugn/the_gnat_compilation_model id19}@anchor{69}@anchor{gnat_ugn/the_gnat_compilation_model using-gnatkr}@anchor{56}
+@anchor{gnat_ugn/the_gnat_compilation_model id19}@anchor{67}@anchor{gnat_ugn/the_gnat_compilation_model using-gnatkr}@anchor{54}
@subsubsection Using @cite{gnatkr}
@@ -2573,7 +2463,7 @@ The output is the krunched name. The output has an extension only if the
original argument was a file name with an extension.
@node Krunching Method,Examples of gnatkr Usage,Using gnatkr,File Name Krunching with gnatkr
-@anchor{gnat_ugn/the_gnat_compilation_model id20}@anchor{6a}@anchor{gnat_ugn/the_gnat_compilation_model krunching-method}@anchor{6b}
+@anchor{gnat_ugn/the_gnat_compilation_model id20}@anchor{68}@anchor{gnat_ugn/the_gnat_compilation_model krunching-method}@anchor{69}
@subsubsection Krunching Method
@@ -2703,7 +2593,7 @@ program @cite{gnatkr} is supplied for conveniently determining the
krunched name of a file.
@node Examples of gnatkr Usage,,Krunching Method,File Name Krunching with gnatkr
-@anchor{gnat_ugn/the_gnat_compilation_model id21}@anchor{6c}@anchor{gnat_ugn/the_gnat_compilation_model examples-of-gnatkr-usage}@anchor{6d}
+@anchor{gnat_ugn/the_gnat_compilation_model id21}@anchor{6a}@anchor{gnat_ugn/the_gnat_compilation_model examples-of-gnatkr-usage}@anchor{6b}
@subsubsection Examples of @cite{gnatkr} Usage
@@ -2717,13 +2607,13 @@ $ gnatkr very_long_unit_name.ads/count=0 --> very_long_unit_name.ads
@end example
@node Renaming Files with gnatchop,,File Name Krunching with gnatkr,File Naming Topics and Utilities
-@anchor{gnat_ugn/the_gnat_compilation_model id22}@anchor{6e}@anchor{gnat_ugn/the_gnat_compilation_model renaming-files-with-gnatchop}@anchor{38}
+@anchor{gnat_ugn/the_gnat_compilation_model id22}@anchor{6c}@anchor{gnat_ugn/the_gnat_compilation_model renaming-files-with-gnatchop}@anchor{36}
@subsection Renaming Files with @cite{gnatchop}
@geindex gnatchop
-This chapter discusses how to handle files with multiple units by using
+This section discusses how to handle files with multiple units by using
the @cite{gnatchop} utility. This utility is also useful in renaming
files to meet the standard GNAT default file naming conventions.
@@ -2737,7 +2627,7 @@ files to meet the standard GNAT default file naming conventions.
@end menu
@node Handling Files with Multiple Units,Operating gnatchop in Compilation Mode,,Renaming Files with gnatchop
-@anchor{gnat_ugn/the_gnat_compilation_model id23}@anchor{6f}@anchor{gnat_ugn/the_gnat_compilation_model handling-files-with-multiple-units}@anchor{70}
+@anchor{gnat_ugn/the_gnat_compilation_model id23}@anchor{6d}@anchor{gnat_ugn/the_gnat_compilation_model handling-files-with-multiple-units}@anchor{6e}
@subsubsection Handling Files with Multiple Units
@@ -2769,7 +2659,7 @@ will each start with a copy of this BOM, meaning that they can be compiled
automatically in UTF-8 mode without needing to specify an explicit encoding.
@node Operating gnatchop in Compilation Mode,Command Line for gnatchop,Handling Files with Multiple Units,Renaming Files with gnatchop
-@anchor{gnat_ugn/the_gnat_compilation_model operating-gnatchop-in-compilation-mode}@anchor{71}@anchor{gnat_ugn/the_gnat_compilation_model id24}@anchor{72}
+@anchor{gnat_ugn/the_gnat_compilation_model operating-gnatchop-in-compilation-mode}@anchor{6f}@anchor{gnat_ugn/the_gnat_compilation_model id24}@anchor{70}
@subsubsection Operating gnatchop in Compilation Mode
@@ -2802,7 +2692,7 @@ should apply to all subsequent compilations in the same compilation
environment. Using GNAT, the current directory, possibly containing a
@code{gnat.adc} file is the representation
of a compilation environment. For more information on the
-@code{gnat.adc} file, see @ref{58,,Handling of Configuration Pragmas}.
+@code{gnat.adc} file, see @ref{56,,Handling of Configuration Pragmas}.
Second, in compilation mode, if @cite{gnatchop}
is given a file that starts with
@@ -2829,7 +2719,7 @@ switch provides the required behavior, and is for example the mode
in which GNAT processes the ACVC tests.
@node Command Line for gnatchop,Switches for gnatchop,Operating gnatchop in Compilation Mode,Renaming Files with gnatchop
-@anchor{gnat_ugn/the_gnat_compilation_model id25}@anchor{73}@anchor{gnat_ugn/the_gnat_compilation_model command-line-for-gnatchop}@anchor{74}
+@anchor{gnat_ugn/the_gnat_compilation_model id25}@anchor{71}@anchor{gnat_ugn/the_gnat_compilation_model command-line-for-gnatchop}@anchor{72}
@subsubsection Command Line for @cite{gnatchop}
@@ -2903,7 +2793,7 @@ no source files written
@end example
@node Switches for gnatchop,Examples of gnatchop Usage,Command Line for gnatchop,Renaming Files with gnatchop
-@anchor{gnat_ugn/the_gnat_compilation_model switches-for-gnatchop}@anchor{75}@anchor{gnat_ugn/the_gnat_compilation_model id26}@anchor{76}
+@anchor{gnat_ugn/the_gnat_compilation_model switches-for-gnatchop}@anchor{73}@anchor{gnat_ugn/the_gnat_compilation_model id26}@anchor{74}
@subsubsection Switches for @cite{gnatchop}
@@ -3069,7 +2959,7 @@ no attempt is made to add the prefix to the GNAT parser executable.
@end table
@node Examples of gnatchop Usage,,Switches for gnatchop,Renaming Files with gnatchop
-@anchor{gnat_ugn/the_gnat_compilation_model id27}@anchor{77}@anchor{gnat_ugn/the_gnat_compilation_model examples-of-gnatchop-usage}@anchor{78}
+@anchor{gnat_ugn/the_gnat_compilation_model id27}@anchor{75}@anchor{gnat_ugn/the_gnat_compilation_model examples-of-gnatchop-usage}@anchor{76}
@subsubsection Examples of @cite{gnatchop} Usage
@@ -3110,7 +3000,7 @@ be the one that is output, and earlier duplicate occurrences for a given
unit will be skipped.
@node Configuration Pragmas,Generating Object Files,File Naming Topics and Utilities,The GNAT Compilation Model
-@anchor{gnat_ugn/the_gnat_compilation_model id28}@anchor{79}@anchor{gnat_ugn/the_gnat_compilation_model configuration-pragmas}@anchor{16}
+@anchor{gnat_ugn/the_gnat_compilation_model id28}@anchor{77}@anchor{gnat_ugn/the_gnat_compilation_model configuration-pragmas}@anchor{14}
@section Configuration Pragmas
@@ -3179,6 +3069,7 @@ Profile_Warnings
Propagate_Exceptions
Queuing_Policy
Ravenscar
+Rename_Pragma
Restricted_Run_Time
Restrictions
Restrictions_Warnings
@@ -3206,7 +3097,7 @@ Wide_Character_Encoding
@end menu
@node Handling of Configuration Pragmas,The Configuration Pragmas Files,,Configuration Pragmas
-@anchor{gnat_ugn/the_gnat_compilation_model id29}@anchor{7a}@anchor{gnat_ugn/the_gnat_compilation_model handling-of-configuration-pragmas}@anchor{58}
+@anchor{gnat_ugn/the_gnat_compilation_model id29}@anchor{78}@anchor{gnat_ugn/the_gnat_compilation_model handling-of-configuration-pragmas}@anchor{56}
@subsection Handling of Configuration Pragmas
@@ -3217,7 +3108,7 @@ all compilations performed in a given compilation environment.
GNAT also provides the @cite{gnatchop} utility to provide an automatic
way to handle configuration pragmas following the semantics for
compilations (that is, files with multiple units), described in the RM.
-See @ref{71,,Operating gnatchop in Compilation Mode} for details.
+See @ref{6f,,Operating gnatchop in Compilation Mode} for details.
However, for most purposes, it will be more convenient to edit the
@code{gnat.adc} file that contains configuration pragmas directly,
as described in the following section.
@@ -3247,7 +3138,7 @@ relevant units). It can appear on a subunit only if it has previously
appeared in the body of spec.
@node The Configuration Pragmas Files,,Handling of Configuration Pragmas,Configuration Pragmas
-@anchor{gnat_ugn/the_gnat_compilation_model the-configuration-pragmas-files}@anchor{7b}@anchor{gnat_ugn/the_gnat_compilation_model id30}@anchor{7c}
+@anchor{gnat_ugn/the_gnat_compilation_model the-configuration-pragmas-files}@anchor{79}@anchor{gnat_ugn/the_gnat_compilation_model id30}@anchor{7a}
@subsection The Configuration Pragmas Files
@@ -3288,11 +3179,13 @@ depend on a file that no longer exists. Such tools include
@emph{gprbuild}, @emph{gnatmake}, and @emph{gnatcheck}.
If you are using project file, a separate mechanism is provided using
-project attributes, see @ref{7d,,Specifying Configuration Pragmas} for more
-details.
+project attributes.
+
+@c --Comment:
+@c See :ref:`Specifying_Configuration_Pragmas` for more details.
@node Generating Object Files,Source Dependencies,Configuration Pragmas,The GNAT Compilation Model
-@anchor{gnat_ugn/the_gnat_compilation_model generating-object-files}@anchor{42}@anchor{gnat_ugn/the_gnat_compilation_model id31}@anchor{7e}
+@anchor{gnat_ugn/the_gnat_compilation_model generating-object-files}@anchor{40}@anchor{gnat_ugn/the_gnat_compilation_model id31}@anchor{7b}
@section Generating Object Files
@@ -3363,7 +3256,7 @@ part of the process of building a program. To compile a file in this
checking mode, use the @emph{-gnatc} switch.
@node Source Dependencies,The Ada Library Information Files,Generating Object Files,The GNAT Compilation Model
-@anchor{gnat_ugn/the_gnat_compilation_model id32}@anchor{7f}@anchor{gnat_ugn/the_gnat_compilation_model source-dependencies}@anchor{43}
+@anchor{gnat_ugn/the_gnat_compilation_model id32}@anchor{7c}@anchor{gnat_ugn/the_gnat_compilation_model source-dependencies}@anchor{41}
@section Source Dependencies
@@ -3458,7 +3351,7 @@ recompilations is done automatically when one uses @emph{gnatmake}.
@end itemize
@node The Ada Library Information Files,Binding an Ada Program,Source Dependencies,The GNAT Compilation Model
-@anchor{gnat_ugn/the_gnat_compilation_model id33}@anchor{80}@anchor{gnat_ugn/the_gnat_compilation_model the-ada-library-information-files}@anchor{44}
+@anchor{gnat_ugn/the_gnat_compilation_model id33}@anchor{7d}@anchor{gnat_ugn/the_gnat_compilation_model the-ada-library-information-files}@anchor{42}
@section The Ada Library Information Files
@@ -3526,7 +3419,7 @@ see the source of the body of unit @cite{Lib.Writ}, contained in file
@code{lib-writ.adb} in the GNAT compiler sources.
@node Binding an Ada Program,GNAT and Libraries,The Ada Library Information Files,The GNAT Compilation Model
-@anchor{gnat_ugn/the_gnat_compilation_model id34}@anchor{81}@anchor{gnat_ugn/the_gnat_compilation_model binding-an-ada-program}@anchor{45}
+@anchor{gnat_ugn/the_gnat_compilation_model id34}@anchor{7e}@anchor{gnat_ugn/the_gnat_compilation_model binding-an-ada-program}@anchor{43}
@section Binding an Ada Program
@@ -3562,16 +3455,16 @@ using the object from the main program from the bind step as well as the
object files for the Ada units of the program.
@node GNAT and Libraries,Conditional Compilation,Binding an Ada Program,The GNAT Compilation Model
-@anchor{gnat_ugn/the_gnat_compilation_model gnat-and-libraries}@anchor{17}@anchor{gnat_ugn/the_gnat_compilation_model id35}@anchor{82}
+@anchor{gnat_ugn/the_gnat_compilation_model gnat-and-libraries}@anchor{15}@anchor{gnat_ugn/the_gnat_compilation_model id35}@anchor{7f}
@section GNAT and Libraries
@geindex Library building and using
-This chapter describes how to build and use libraries with GNAT, and also shows
+This section describes how to build and use libraries with GNAT, and also shows
how to recompile the GNAT run-time library. You should be familiar with the
-Project Manager facility (@ref{b,,GNAT Project Manager}) before reading this
-chapter.
+Project Manager facility (see the @emph{GNAT_Project_Manager} chapter of the
+@emph{GPRbuild User's Guide}) before reading this chapter.
@menu
* Introduction to Libraries in GNAT::
@@ -3582,7 +3475,7 @@ chapter.
@end menu
@node Introduction to Libraries in GNAT,General Ada Libraries,,GNAT and Libraries
-@anchor{gnat_ugn/the_gnat_compilation_model introduction-to-libraries-in-gnat}@anchor{83}@anchor{gnat_ugn/the_gnat_compilation_model id36}@anchor{84}
+@anchor{gnat_ugn/the_gnat_compilation_model introduction-to-libraries-in-gnat}@anchor{80}@anchor{gnat_ugn/the_gnat_compilation_model id36}@anchor{81}
@subsection Introduction to Libraries in GNAT
@@ -3609,7 +3502,7 @@ In the GNAT environment, a library has three types of components:
Source files,
@item
-@code{ALI} files (see @ref{44,,The Ada Library Information Files}), and
+@code{ALI} files (see @ref{42,,The Ada Library Information Files}), and
@item
Object files, an archive or a shared library.
@@ -3621,7 +3514,7 @@ an external user to make use of the library. That is to say, the specs
reflecting the library services along with all the units needed to compile
those specs, which can include generic bodies or any body implementing an
inlined routine. In the case of @emph{stand-alone libraries} those exposed
-units are called @emph{interface units} (@ref{85,,Stand-alone Ada Libraries}).
+units are called @emph{interface units} (@ref{82,,Stand-alone Ada Libraries}).
All compilation units comprising an application, including those in a library,
need to be elaborated in an order partially defined by Ada's semantics. GNAT
@@ -3632,7 +3525,7 @@ library elaboration routine is produced independently of the application(s)
using the library.
@node General Ada Libraries,Stand-alone Ada Libraries,Introduction to Libraries in GNAT,GNAT and Libraries
-@anchor{gnat_ugn/the_gnat_compilation_model general-ada-libraries}@anchor{86}@anchor{gnat_ugn/the_gnat_compilation_model id37}@anchor{87}
+@anchor{gnat_ugn/the_gnat_compilation_model general-ada-libraries}@anchor{83}@anchor{gnat_ugn/the_gnat_compilation_model id37}@anchor{84}
@subsection General Ada Libraries
@@ -3644,13 +3537,14 @@ using the library.
@end menu
@node Building a library,Installing a library,,General Ada Libraries
-@anchor{gnat_ugn/the_gnat_compilation_model building-a-library}@anchor{88}@anchor{gnat_ugn/the_gnat_compilation_model id38}@anchor{89}
+@anchor{gnat_ugn/the_gnat_compilation_model building-a-library}@anchor{85}@anchor{gnat_ugn/the_gnat_compilation_model id38}@anchor{86}
@subsubsection Building a library
The easiest way to build a library is to use the Project Manager,
which supports a special type of project called a @emph{Library Project}
-(see @ref{8a,,Library Projects}).
+(see the @emph{Library Projects} section in the @emph{GNAT Project Manager}
+chapter of the @emph{GPRbuild User's Guide}).
A project is considered a library project, when two project-level attributes
are defined in it: @cite{Library_Name} and @cite{Library_Dir}. In order to
@@ -3725,7 +3619,7 @@ for this task. In special cases where this is not desired, the necessary
steps are discussed below.
There are various possibilities for compiling the units that make up the
-library: for example with a Makefile (@ref{21,,Using the GNU make Utility}) or
+library: for example with a Makefile (@ref{1f,,Using the GNU make Utility}) or
with a conventional script. For simple libraries, it is also possible to create
a dummy main program which depends upon all the packages that comprise the
interface of the library. This dummy main program can then be given to
@@ -3776,7 +3670,7 @@ or @code{lib@emph{xxx}.so} (or @code{lib@emph{xxx}.dll} on Windows) in order to
be accessed by the directive @code{-l@emph{xxx}} at link time.
@node Installing a library,Using a library,Building a library,General Ada Libraries
-@anchor{gnat_ugn/the_gnat_compilation_model installing-a-library}@anchor{8b}@anchor{gnat_ugn/the_gnat_compilation_model id39}@anchor{8c}
+@anchor{gnat_ugn/the_gnat_compilation_model installing-a-library}@anchor{87}@anchor{gnat_ugn/the_gnat_compilation_model id39}@anchor{88}
@subsubsection Installing a library
@@ -3785,12 +3679,13 @@ be accessed by the directive @code{-l@emph{xxx}} at link time.
@geindex GPR_PROJECT_PATH
If you use project files, library installation is part of the library build
-process (@ref{8d,,Installing a library with project files}).
+process (see the @emph{Installing a Library with Project Files} section of the
+@emph{GNAT Project Manager} chapter of the @emph{GPRbuild User's Guide}).
When project files are not an option, it is also possible, but not recommended,
to install the library so that the sources needed to use the library are on the
Ada source path and the ALI files & libraries be on the Ada Object path (see
-@ref{8e,,Search Paths and the Run-Time Library (RTL)}. Alternatively, the system
+@ref{89,,Search Paths and the Run-Time Library (RTL)}. Alternatively, the system
administrator can place general-purpose libraries in the default compiler
paths, by specifying the libraries' location in the configuration files
@code{ada_source_path} and @code{ada_object_path}. These configuration files
@@ -3832,7 +3727,7 @@ library must be installed before the GNAT library if it redefines
any part of it.
@node Using a library,,Installing a library,General Ada Libraries
-@anchor{gnat_ugn/the_gnat_compilation_model using-a-library}@anchor{8f}@anchor{gnat_ugn/the_gnat_compilation_model id40}@anchor{90}
+@anchor{gnat_ugn/the_gnat_compilation_model using-a-library}@anchor{8a}@anchor{gnat_ugn/the_gnat_compilation_model id40}@anchor{8b}
@subsubsection Using a library
@@ -3871,8 +3766,8 @@ left to the tools having visibility over project dependence information.
In order to use an Ada library manually, you need to make sure that this
library is on both your source and object path
-(see @ref{8e,,Search Paths and the Run-Time Library (RTL)}
-and @ref{91,,Search Paths for gnatbind}). Furthermore, when the objects are grouped
+(see @ref{89,,Search Paths and the Run-Time Library (RTL)}
+and @ref{8c,,Search Paths for gnatbind}). Furthermore, when the objects are grouped
in an archive or a shared library, you need to specify the desired
library at link time.
@@ -3926,7 +3821,7 @@ in the directory @code{share/examples/gnat/plugins} within the GNAT
install area.
@node Stand-alone Ada Libraries,Rebuilding the GNAT Run-Time Library,General Ada Libraries,GNAT and Libraries
-@anchor{gnat_ugn/the_gnat_compilation_model stand-alone-ada-libraries}@anchor{85}@anchor{gnat_ugn/the_gnat_compilation_model id41}@anchor{92}
+@anchor{gnat_ugn/the_gnat_compilation_model stand-alone-ada-libraries}@anchor{82}@anchor{gnat_ugn/the_gnat_compilation_model id41}@anchor{8d}
@subsection Stand-alone Ada Libraries
@@ -3941,7 +3836,7 @@ install area.
@end menu
@node Introduction to Stand-alone Libraries,Building a Stand-alone Library,,Stand-alone Ada Libraries
-@anchor{gnat_ugn/the_gnat_compilation_model introduction-to-stand-alone-libraries}@anchor{93}@anchor{gnat_ugn/the_gnat_compilation_model id42}@anchor{94}
+@anchor{gnat_ugn/the_gnat_compilation_model introduction-to-stand-alone-libraries}@anchor{8e}@anchor{gnat_ugn/the_gnat_compilation_model id42}@anchor{8f}
@subsubsection Introduction to Stand-alone Libraries
@@ -3976,16 +3871,18 @@ Stand-alone libraries are also well suited to be used in an executable whose
main routine is not written in Ada.
@node Building a Stand-alone Library,Creating a Stand-alone Library to be used in a non-Ada context,Introduction to Stand-alone Libraries,Stand-alone Ada Libraries
-@anchor{gnat_ugn/the_gnat_compilation_model id43}@anchor{95}@anchor{gnat_ugn/the_gnat_compilation_model building-a-stand-alone-library}@anchor{96}
+@anchor{gnat_ugn/the_gnat_compilation_model id43}@anchor{90}@anchor{gnat_ugn/the_gnat_compilation_model building-a-stand-alone-library}@anchor{91}
@subsubsection Building a Stand-alone Library
GNAT's Project facility provides a simple way of building and installing
-stand-alone libraries; see @ref{97,,Stand-alone Library Projects}.
+stand-alone libraries; see the @emph{Stand-alone Library Projects} section
+in the @emph{GNAT Project Manager} chapter of the @emph{GPRbuild User's Guide}.
To be a Stand-alone Library Project, in addition to the two attributes
that make a project a Library Project (@cite{Library_Name} and
-@cite{Library_Dir}; see @ref{8a,,Library Projects}), the attribute
-@cite{Library_Interface} must be defined. For example:
+@cite{Library_Dir}; see the @emph{Library Projects} section in the
+@emph{GNAT Project Manager} chapter of the @emph{GPRbuild User's Guide}),
+the attribute @cite{Library_Interface} must be defined. For example:
@example
for Library_Dir use "lib_dir";
@@ -4093,10 +3990,10 @@ read-only.
@end itemize
Using SALs is not different from using other libraries
-(see @ref{8f,,Using a library}).
+(see @ref{8a,,Using a library}).
@node Creating a Stand-alone Library to be used in a non-Ada context,Restrictions in Stand-alone Libraries,Building a Stand-alone Library,Stand-alone Ada Libraries
-@anchor{gnat_ugn/the_gnat_compilation_model creating-a-stand-alone-library-to-be-used-in-a-non-ada-context}@anchor{98}@anchor{gnat_ugn/the_gnat_compilation_model id44}@anchor{99}
+@anchor{gnat_ugn/the_gnat_compilation_model creating-a-stand-alone-library-to-be-used-in-a-non-ada-context}@anchor{92}@anchor{gnat_ugn/the_gnat_compilation_model id44}@anchor{93}
@subsubsection Creating a Stand-alone Library to be used in a non-Ada context
@@ -4181,7 +4078,7 @@ must be ensured at the application level using a specific operating
system services like a mutex or a critical-section.
@node Restrictions in Stand-alone Libraries,,Creating a Stand-alone Library to be used in a non-Ada context,Stand-alone Ada Libraries
-@anchor{gnat_ugn/the_gnat_compilation_model id45}@anchor{9a}@anchor{gnat_ugn/the_gnat_compilation_model restrictions-in-stand-alone-libraries}@anchor{9b}
+@anchor{gnat_ugn/the_gnat_compilation_model id45}@anchor{94}@anchor{gnat_ugn/the_gnat_compilation_model restrictions-in-stand-alone-libraries}@anchor{95}
@subsubsection Restrictions in Stand-alone Libraries
@@ -4227,7 +4124,7 @@ In practice these attributes are rarely used, so this is unlikely
to be a consideration.
@node Rebuilding the GNAT Run-Time Library,,Stand-alone Ada Libraries,GNAT and Libraries
-@anchor{gnat_ugn/the_gnat_compilation_model id46}@anchor{9c}@anchor{gnat_ugn/the_gnat_compilation_model rebuilding-the-gnat-run-time-library}@anchor{9d}
+@anchor{gnat_ugn/the_gnat_compilation_model id46}@anchor{96}@anchor{gnat_ugn/the_gnat_compilation_model rebuilding-the-gnat-run-time-library}@anchor{97}
@subsection Rebuilding the GNAT Run-Time Library
@@ -4261,7 +4158,7 @@ to use it.
@geindex Conditional compilation
@node Conditional Compilation,Mixed Language Programming,GNAT and Libraries,The GNAT Compilation Model
-@anchor{gnat_ugn/the_gnat_compilation_model id47}@anchor{9e}@anchor{gnat_ugn/the_gnat_compilation_model conditional-compilation}@anchor{18}
+@anchor{gnat_ugn/the_gnat_compilation_model id47}@anchor{98}@anchor{gnat_ugn/the_gnat_compilation_model conditional-compilation}@anchor{16}
@section Conditional Compilation
@@ -4278,7 +4175,7 @@ gnatprep preprocessor utility.
@end menu
@node Modeling Conditional Compilation in Ada,Preprocessing with gnatprep,,Conditional Compilation
-@anchor{gnat_ugn/the_gnat_compilation_model modeling-conditional-compilation-in-ada}@anchor{9f}@anchor{gnat_ugn/the_gnat_compilation_model id48}@anchor{a0}
+@anchor{gnat_ugn/the_gnat_compilation_model modeling-conditional-compilation-in-ada}@anchor{99}@anchor{gnat_ugn/the_gnat_compilation_model id48}@anchor{9a}
@subsection Modeling Conditional Compilation in Ada
@@ -4329,7 +4226,7 @@ be achieved using Ada in general, and GNAT in particular.
@end menu
@node Use of Boolean Constants,Debugging - A Special Case,,Modeling Conditional Compilation in Ada
-@anchor{gnat_ugn/the_gnat_compilation_model id49}@anchor{a1}@anchor{gnat_ugn/the_gnat_compilation_model use-of-boolean-constants}@anchor{a2}
+@anchor{gnat_ugn/the_gnat_compilation_model id49}@anchor{9b}@anchor{gnat_ugn/the_gnat_compilation_model use-of-boolean-constants}@anchor{9c}
@subsubsection Use of Boolean Constants
@@ -4373,7 +4270,7 @@ Then any other unit requiring conditional compilation can do a @emph{with}
of @cite{Config} to make the constants visible.
@node Debugging - A Special Case,Conditionalizing Declarations,Use of Boolean Constants,Modeling Conditional Compilation in Ada
-@anchor{gnat_ugn/the_gnat_compilation_model debugging-a-special-case}@anchor{a3}@anchor{gnat_ugn/the_gnat_compilation_model id50}@anchor{a4}
+@anchor{gnat_ugn/the_gnat_compilation_model debugging-a-special-case}@anchor{9d}@anchor{gnat_ugn/the_gnat_compilation_model id50}@anchor{9e}
@subsubsection Debugging - A Special Case
@@ -4486,7 +4383,7 @@ end if;
@end example
@node Conditionalizing Declarations,Use of Alternative Implementations,Debugging - A Special Case,Modeling Conditional Compilation in Ada
-@anchor{gnat_ugn/the_gnat_compilation_model conditionalizing-declarations}@anchor{a5}@anchor{gnat_ugn/the_gnat_compilation_model id51}@anchor{a6}
+@anchor{gnat_ugn/the_gnat_compilation_model conditionalizing-declarations}@anchor{9f}@anchor{gnat_ugn/the_gnat_compilation_model id51}@anchor{a0}
@subsubsection Conditionalizing Declarations
@@ -4551,7 +4448,7 @@ constant was introduced as @cite{System.Default_Bit_Order}, so you do not
need to define this one yourself).
@node Use of Alternative Implementations,Preprocessing,Conditionalizing Declarations,Modeling Conditional Compilation in Ada
-@anchor{gnat_ugn/the_gnat_compilation_model use-of-alternative-implementations}@anchor{a7}@anchor{gnat_ugn/the_gnat_compilation_model id52}@anchor{a8}
+@anchor{gnat_ugn/the_gnat_compilation_model use-of-alternative-implementations}@anchor{a1}@anchor{gnat_ugn/the_gnat_compilation_model id52}@anchor{a2}
@subsubsection Use of Alternative Implementations
@@ -4685,7 +4582,7 @@ The same idea can also be implemented using tagged types and dispatching
calls.
@node Preprocessing,,Use of Alternative Implementations,Modeling Conditional Compilation in Ada
-@anchor{gnat_ugn/the_gnat_compilation_model preprocessing}@anchor{a9}@anchor{gnat_ugn/the_gnat_compilation_model id53}@anchor{aa}
+@anchor{gnat_ugn/the_gnat_compilation_model preprocessing}@anchor{a3}@anchor{gnat_ugn/the_gnat_compilation_model id53}@anchor{a4}
@subsubsection Preprocessing
@@ -4708,7 +4605,7 @@ The preprocessor may be used in two separate modes. It can be used quite
separately from the compiler, to generate a separate output source file
that is then fed to the compiler as a separate step. This is the
@cite{gnatprep} utility, whose use is fully described in
-@ref{19,,Preprocessing with gnatprep}.
+@ref{17,,Preprocessing with gnatprep}.
The preprocessing language allows such constructs as
@@ -4728,10 +4625,10 @@ often more convenient. In this approach the preprocessing is integrated into
the compilation process. The compiler is fed the preprocessor input which
includes @cite{#if} lines etc, and then the compiler carries out the
preprocessing internally and processes the resulting output.
-For more details on this approach, see @ref{1a,,Integrated Preprocessing}.
+For more details on this approach, see @ref{18,,Integrated Preprocessing}.
@node Preprocessing with gnatprep,Integrated Preprocessing,Modeling Conditional Compilation in Ada,Conditional Compilation
-@anchor{gnat_ugn/the_gnat_compilation_model id54}@anchor{ab}@anchor{gnat_ugn/the_gnat_compilation_model preprocessing-with-gnatprep}@anchor{19}
+@anchor{gnat_ugn/the_gnat_compilation_model id54}@anchor{a5}@anchor{gnat_ugn/the_gnat_compilation_model preprocessing-with-gnatprep}@anchor{17}
@subsection Preprocessing with @cite{gnatprep}
@@ -4744,7 +4641,7 @@ preprocessing.
Although designed for use with GNAT, @cite{gnatprep} does not depend on any
special GNAT features.
For further discussion of conditional compilation in general, see
-@ref{18,,Conditional Compilation}.
+@ref{16,,Conditional Compilation}.
@menu
* Preprocessing Symbols::
@@ -4756,7 +4653,7 @@ For further discussion of conditional compilation in general, see
@end menu
@node Preprocessing Symbols,Using gnatprep,,Preprocessing with gnatprep
-@anchor{gnat_ugn/the_gnat_compilation_model id55}@anchor{ac}@anchor{gnat_ugn/the_gnat_compilation_model preprocessing-symbols}@anchor{ad}
+@anchor{gnat_ugn/the_gnat_compilation_model id55}@anchor{a6}@anchor{gnat_ugn/the_gnat_compilation_model preprocessing-symbols}@anchor{a7}
@subsubsection Preprocessing Symbols
@@ -4766,7 +4663,7 @@ normal Ada (case-insensitive) rules for its syntax, with the restriction that
all characters need to be in the ASCII set (no accented letters).
@node Using gnatprep,Switches for gnatprep,Preprocessing Symbols,Preprocessing with gnatprep
-@anchor{gnat_ugn/the_gnat_compilation_model using-gnatprep}@anchor{ae}@anchor{gnat_ugn/the_gnat_compilation_model id56}@anchor{af}
+@anchor{gnat_ugn/the_gnat_compilation_model using-gnatprep}@anchor{a8}@anchor{gnat_ugn/the_gnat_compilation_model id56}@anchor{a9}
@subsubsection Using @cite{gnatprep}
@@ -4824,10 +4721,31 @@ optional, and can be replaced by the use of the @emph{-D} switch.
@end itemize
@node Switches for gnatprep,Form of Definitions File,Using gnatprep,Preprocessing with gnatprep
-@anchor{gnat_ugn/the_gnat_compilation_model switches-for-gnatprep}@anchor{b0}@anchor{gnat_ugn/the_gnat_compilation_model id57}@anchor{b1}
+@anchor{gnat_ugn/the_gnat_compilation_model switches-for-gnatprep}@anchor{aa}@anchor{gnat_ugn/the_gnat_compilation_model id57}@anchor{ab}
@subsubsection Switches for @cite{gnatprep}
+@geindex --version (gnatprep)
+
+
+@table @asis
+
+@item @code{--version}
+
+Display Copyright and version, then exit disregarding all other options.
+@end table
+
+@geindex --help (gnatprep)
+
+
+@table @asis
+
+@item @code{--help}
+
+If @emph{--version} was not used, display usage, then exit disregarding
+all other options.
+@end table
+
@geindex -b (gnatprep)
@@ -4915,6 +4833,17 @@ Causes a sorted list of symbol names and values to be
listed on the standard output file.
@end table
+@geindex -T (gnatprep)
+
+
+@table @asis
+
+@item @code{-T}
+
+Use LF as line terminators when writing files. By default the line terminator
+of the host (LF under unix, CR/LF under Windows) is used.
+@end table
+
@geindex -u (gnatprep)
@@ -4927,13 +4856,23 @@ of a preprocessor test. In the absence of this option, an undefined symbol in
a @cite{#if} or @cite{#elsif} test will be treated as an error.
@end table
+@geindex -v (gnatprep)
+
+
+@table @asis
+
+@item @code{-v}
+
+Verbose mode: generates more output about work done.
+@end table
+
Note: if neither @emph{-b} nor @emph{-c} is present,
then preprocessor lines and
deleted lines are completely removed from the output, unless -r is
specified, in which case -b is assumed.
@node Form of Definitions File,Form of Input Text for gnatprep,Switches for gnatprep,Preprocessing with gnatprep
-@anchor{gnat_ugn/the_gnat_compilation_model form-of-definitions-file}@anchor{b2}@anchor{gnat_ugn/the_gnat_compilation_model id58}@anchor{b3}
+@anchor{gnat_ugn/the_gnat_compilation_model form-of-definitions-file}@anchor{ac}@anchor{gnat_ugn/the_gnat_compilation_model id58}@anchor{ad}
@subsubsection Form of Definitions File
@@ -4963,7 +4902,7 @@ the usual @code{--},
and comments may be added to the definitions lines.
@node Form of Input Text for gnatprep,,Form of Definitions File,Preprocessing with gnatprep
-@anchor{gnat_ugn/the_gnat_compilation_model id59}@anchor{b4}@anchor{gnat_ugn/the_gnat_compilation_model form-of-input-text-for-gnatprep}@anchor{b5}
+@anchor{gnat_ugn/the_gnat_compilation_model id59}@anchor{ae}@anchor{gnat_ugn/the_gnat_compilation_model form-of-input-text-for-gnatprep}@anchor{af}
@subsubsection Form of Input Text for @cite{gnatprep}
@@ -5095,7 +5034,7 @@ Header : String := $XYZ;
and then the substitution will occur as desired.
@node Integrated Preprocessing,,Preprocessing with gnatprep,Conditional Compilation
-@anchor{gnat_ugn/the_gnat_compilation_model id60}@anchor{b6}@anchor{gnat_ugn/the_gnat_compilation_model integrated-preprocessing}@anchor{1a}
+@anchor{gnat_ugn/the_gnat_compilation_model id60}@anchor{b0}@anchor{gnat_ugn/the_gnat_compilation_model integrated-preprocessing}@anchor{18}
@subsection Integrated Preprocessing
@@ -5126,7 +5065,7 @@ because @emph{gnatmake} cannot compute the checksum of the source after
preprocessing.
The actual preprocessing function is described in detail in section
-@ref{19,,Preprocessing with gnatprep}. This section only describes how integrated
+@ref{17,,Preprocessing with gnatprep}. This section only describes how integrated
preprocessing is triggered and parameterized.
@geindex -gnatep (gcc)
@@ -5138,10 +5077,18 @@ preprocessing is triggered and parameterized.
This switch indicates to the compiler the file name (without directory
information) of the preprocessor data file to use. The preprocessor data file
-should be found in the source directories. Note that when the compiler is
-called by a builder such as (@emph{gnatmake} with a project
-file, if the object directory is not also a source directory, the builder needs
-to be called with @emph{-x}.
+should be found in the source directories. Alternatively when using project
+files, you can reference to the project file's directory via the
+@code{project name'Project_Dir} project attribute, e.g:
+
+@example
+project Prj is
+ package Compiler is
+ for Switches ("Ada") use
+ ("-gnatep=" & Prj'Project_Dir & "prep.def");
+ end Compiler;
+end Prj;
+@end example
A preprocessing data file is a text file with significant lines indicating
how should be preprocessed either a specific source or all sources not
@@ -5157,7 +5104,7 @@ lines starting with the character '*'.
After the file name or the character '*', another optional literal string
indicating the file name of the definition file to be used for preprocessing
-(@ref{b2,,Form of Definitions File}). The definition files are found by the
+(@ref{ac,,Form of Definitions File}). The definition files are found by the
compiler in one of the source directories. In some cases, when compiling
a source in a directory other than the current directory, if the definition
file is in the current directory, it may be necessary to add the current
@@ -5260,7 +5207,7 @@ the source text, write the result of this preprocessing into a file
@end table
@node Mixed Language Programming,GNAT and Other Compilation Models,Conditional Compilation,The GNAT Compilation Model
-@anchor{gnat_ugn/the_gnat_compilation_model mixed-language-programming}@anchor{46}@anchor{gnat_ugn/the_gnat_compilation_model id61}@anchor{b7}
+@anchor{gnat_ugn/the_gnat_compilation_model mixed-language-programming}@anchor{44}@anchor{gnat_ugn/the_gnat_compilation_model id61}@anchor{b1}
@section Mixed Language Programming
@@ -5279,7 +5226,7 @@ with a focus on combining Ada with C or C++.
@end menu
@node Interfacing to C,Calling Conventions,,Mixed Language Programming
-@anchor{gnat_ugn/the_gnat_compilation_model interfacing-to-c}@anchor{b8}@anchor{gnat_ugn/the_gnat_compilation_model id62}@anchor{b9}
+@anchor{gnat_ugn/the_gnat_compilation_model interfacing-to-c}@anchor{b2}@anchor{gnat_ugn/the_gnat_compilation_model id62}@anchor{b3}
@subsection Interfacing to C
@@ -5390,7 +5337,7 @@ $ gnatmake my_main.adb -largs file1.o file2.o
If the main program is in a language other than Ada, then you may have
more than one entry point into the Ada subsystem. You must use a special
binder option to generate callable routines that initialize and
-finalize the Ada units (@ref{ba,,Binding with Non-Ada Main Programs}).
+finalize the Ada units (@ref{b4,,Binding with Non-Ada Main Programs}).
Calls to the initialization and finalization routines must be inserted
in the main program, or some other appropriate point in the code. The
call to initialize the Ada units must occur before the first Ada
@@ -5506,7 +5453,7 @@ GNAT linker not to include the standard startup objects by passing the
@code{-nostartfiles} switch to @cite{gnatlink}.
@node Calling Conventions,Building Mixed Ada and C++ Programs,Interfacing to C,Mixed Language Programming
-@anchor{gnat_ugn/the_gnat_compilation_model calling-conventions}@anchor{bb}@anchor{gnat_ugn/the_gnat_compilation_model id63}@anchor{bc}
+@anchor{gnat_ugn/the_gnat_compilation_model calling-conventions}@anchor{b5}@anchor{gnat_ugn/the_gnat_compilation_model id63}@anchor{b6}
@subsection Calling Conventions
@@ -5830,7 +5777,7 @@ identifier (for example in an @cite{Import} pragma) with the same
meaning as Fortran.
@node Building Mixed Ada and C++ Programs,Generating Ada Bindings for C and C++ headers,Calling Conventions,Mixed Language Programming
-@anchor{gnat_ugn/the_gnat_compilation_model id64}@anchor{bd}@anchor{gnat_ugn/the_gnat_compilation_model building-mixed-ada-and-c-programs}@anchor{be}
+@anchor{gnat_ugn/the_gnat_compilation_model id64}@anchor{b7}@anchor{gnat_ugn/the_gnat_compilation_model building-mixed-ada-and-c-programs}@anchor{b8}
@subsection Building Mixed Ada and C++ Programs
@@ -5848,7 +5795,7 @@ challenge. This section gives a few hints that should make this task easier.
@end menu
@node Interfacing to C++,Linking a Mixed C++ & Ada Program,,Building Mixed Ada and C++ Programs
-@anchor{gnat_ugn/the_gnat_compilation_model id65}@anchor{bf}@anchor{gnat_ugn/the_gnat_compilation_model id66}@anchor{c0}
+@anchor{gnat_ugn/the_gnat_compilation_model id65}@anchor{b9}@anchor{gnat_ugn/the_gnat_compilation_model id66}@anchor{ba}
@subsubsection Interfacing to C++
@@ -5860,7 +5807,7 @@ Interfacing can be done at 3 levels: simple data, subprograms, and
classes. In the first two cases, GNAT offers a specific @cite{Convention C_Plus_Plus}
(or @cite{CPP}) that behaves exactly like @cite{Convention C}.
Usually, C++ mangles the names of subprograms. To generate proper mangled
-names automatically, see @ref{1b,,Generating Ada Bindings for C and C++ headers}).
+names automatically, see @ref{19,,Generating Ada Bindings for C and C++ headers}).
This problem can also be addressed manually in two ways:
@@ -5879,7 +5826,7 @@ Interfacing at the class level can be achieved by using the GNAT specific
pragmas such as @cite{CPP_Constructor}. See the @cite{GNAT_Reference_Manual} for additional information.
@node Linking a Mixed C++ & Ada Program,A Simple Example,Interfacing to C++,Building Mixed Ada and C++ Programs
-@anchor{gnat_ugn/the_gnat_compilation_model linking-a-mixed-c-ada-program}@anchor{c1}@anchor{gnat_ugn/the_gnat_compilation_model linking-a-mixed-c-and-ada-program}@anchor{c2}
+@anchor{gnat_ugn/the_gnat_compilation_model linking-a-mixed-c-ada-program}@anchor{bb}@anchor{gnat_ugn/the_gnat_compilation_model linking-a-mixed-c-and-ada-program}@anchor{bc}
@subsubsection Linking a Mixed C++ & Ada Program
@@ -5994,7 +5941,7 @@ which has a large knowledge base and knows how to link Ada and C++ code
together automatically in most cases.
@node A Simple Example,Interfacing with C++ constructors,Linking a Mixed C++ & Ada Program,Building Mixed Ada and C++ Programs
-@anchor{gnat_ugn/the_gnat_compilation_model id67}@anchor{c3}@anchor{gnat_ugn/the_gnat_compilation_model a-simple-example}@anchor{c4}
+@anchor{gnat_ugn/the_gnat_compilation_model id67}@anchor{bd}@anchor{gnat_ugn/the_gnat_compilation_model a-simple-example}@anchor{be}
@subsubsection A Simple Example
@@ -6123,7 +6070,7 @@ end Simple_Cpp_Interface;
@end example
@node Interfacing with C++ constructors,Interfacing with C++ at the Class Level,A Simple Example,Building Mixed Ada and C++ Programs
-@anchor{gnat_ugn/the_gnat_compilation_model id68}@anchor{c5}@anchor{gnat_ugn/the_gnat_compilation_model interfacing-with-c-constructors}@anchor{c6}
+@anchor{gnat_ugn/the_gnat_compilation_model id68}@anchor{bf}@anchor{gnat_ugn/the_gnat_compilation_model interfacing-with-c-constructors}@anchor{c0}
@subsubsection Interfacing with C++ constructors
@@ -6150,8 +6097,8 @@ public:
For this purpose we can write the following package spec (further
information on how to build this spec is available in
-@ref{c7,,Interfacing with C++ at the Class Level} and
-@ref{1b,,Generating Ada Bindings for C and C++ headers}).
+@ref{c1,,Interfacing with C++ at the Class Level} and
+@ref{19,,Generating Ada Bindings for C and C++ headers}).
@example
with Interfaces.C; use Interfaces.C;
@@ -6320,7 +6267,7 @@ by means of a limited aggregate. Any further action associated with
the constructor can be placed inside the construct.
@node Interfacing with C++ at the Class Level,,Interfacing with C++ constructors,Building Mixed Ada and C++ Programs
-@anchor{gnat_ugn/the_gnat_compilation_model interfacing-with-c-at-the-class-level}@anchor{c7}@anchor{gnat_ugn/the_gnat_compilation_model id69}@anchor{c8}
+@anchor{gnat_ugn/the_gnat_compilation_model interfacing-with-c-at-the-class-level}@anchor{c1}@anchor{gnat_ugn/the_gnat_compilation_model id69}@anchor{c2}
@subsubsection Interfacing with C++ at the Class Level
@@ -6566,7 +6513,7 @@ int main ()
@end example
@node Generating Ada Bindings for C and C++ headers,Generating C Headers for Ada Specifications,Building Mixed Ada and C++ Programs,Mixed Language Programming
-@anchor{gnat_ugn/the_gnat_compilation_model id70}@anchor{c9}@anchor{gnat_ugn/the_gnat_compilation_model generating-ada-bindings-for-c-and-c-headers}@anchor{1b}
+@anchor{gnat_ugn/the_gnat_compilation_model id70}@anchor{c3}@anchor{gnat_ugn/the_gnat_compilation_model generating-ada-bindings-for-c-and-c-headers}@anchor{19}
@subsection Generating Ada Bindings for C and C++ headers
@@ -6616,7 +6563,7 @@ easier to interface with other languages than previous versions of Ada.
@end menu
@node Running the Binding Generator,Generating Bindings for C++ Headers,,Generating Ada Bindings for C and C++ headers
-@anchor{gnat_ugn/the_gnat_compilation_model id71}@anchor{ca}@anchor{gnat_ugn/the_gnat_compilation_model running-the-binding-generator}@anchor{cb}
+@anchor{gnat_ugn/the_gnat_compilation_model id71}@anchor{c4}@anchor{gnat_ugn/the_gnat_compilation_model running-the-binding-generator}@anchor{c5}
@subsubsection Running the Binding Generator
@@ -6710,7 +6657,7 @@ $ g++ -c -fdump-ada-spec readline1.h
@end example
@node Generating Bindings for C++ Headers,Switches,Running the Binding Generator,Generating Ada Bindings for C and C++ headers
-@anchor{gnat_ugn/the_gnat_compilation_model id72}@anchor{cc}@anchor{gnat_ugn/the_gnat_compilation_model generating-bindings-for-c-headers}@anchor{cd}
+@anchor{gnat_ugn/the_gnat_compilation_model id72}@anchor{c6}@anchor{gnat_ugn/the_gnat_compilation_model generating-bindings-for-c-headers}@anchor{c7}
@subsubsection Generating Bindings for C++ Headers
@@ -6811,7 +6758,7 @@ use Class_Dog;
@end example
@node Switches,,Generating Bindings for C++ Headers,Generating Ada Bindings for C and C++ headers
-@anchor{gnat_ugn/the_gnat_compilation_model switches}@anchor{ce}@anchor{gnat_ugn/the_gnat_compilation_model switches-for-ada-binding-generation}@anchor{cf}
+@anchor{gnat_ugn/the_gnat_compilation_model switches}@anchor{c8}@anchor{gnat_ugn/the_gnat_compilation_model switches-for-ada-binding-generation}@anchor{c9}
@subsubsection Switches
@@ -6859,7 +6806,7 @@ Extract comments from headers and generate Ada comments in the Ada spec files.
@end table
@node Generating C Headers for Ada Specifications,,Generating Ada Bindings for C and C++ headers,Mixed Language Programming
-@anchor{gnat_ugn/the_gnat_compilation_model generating-c-headers-for-ada-specifications}@anchor{d0}@anchor{gnat_ugn/the_gnat_compilation_model id73}@anchor{d1}
+@anchor{gnat_ugn/the_gnat_compilation_model generating-c-headers-for-ada-specifications}@anchor{ca}@anchor{gnat_ugn/the_gnat_compilation_model id73}@anchor{cb}
@subsection Generating C Headers for Ada Specifications
@@ -6902,7 +6849,7 @@ Subprogram declarations
@end menu
@node Running the C Header Generator,,,Generating C Headers for Ada Specifications
-@anchor{gnat_ugn/the_gnat_compilation_model running-the-c-header-generator}@anchor{d2}
+@anchor{gnat_ugn/the_gnat_compilation_model running-the-c-header-generator}@anchor{cc}
@subsubsection Running the C Header Generator
@@ -6970,7 +6917,7 @@ You can then @cite{include} @code{pack1.h} from a C source file and use the type
call subprograms, reference objects, and constants.
@node GNAT and Other Compilation Models,Using GNAT Files with External Tools,Mixed Language Programming,The GNAT Compilation Model
-@anchor{gnat_ugn/the_gnat_compilation_model id74}@anchor{d3}@anchor{gnat_ugn/the_gnat_compilation_model gnat-and-other-compilation-models}@anchor{47}
+@anchor{gnat_ugn/the_gnat_compilation_model id74}@anchor{cd}@anchor{gnat_ugn/the_gnat_compilation_model gnat-and-other-compilation-models}@anchor{45}
@section GNAT and Other Compilation Models
@@ -6986,7 +6933,7 @@ used for Ada 83.
@end menu
@node Comparison between GNAT and C/C++ Compilation Models,Comparison between GNAT and Conventional Ada Library Models,,GNAT and Other Compilation Models
-@anchor{gnat_ugn/the_gnat_compilation_model comparison-between-gnat-and-c-c-compilation-models}@anchor{d4}@anchor{gnat_ugn/the_gnat_compilation_model id75}@anchor{d5}
+@anchor{gnat_ugn/the_gnat_compilation_model comparison-between-gnat-and-c-c-compilation-models}@anchor{ce}@anchor{gnat_ugn/the_gnat_compilation_model id75}@anchor{cf}
@subsection Comparison between GNAT and C/C++ Compilation Models
@@ -7020,7 +6967,7 @@ elaboration, a C++ compiler would simply construct a program that
malfunctioned at run time.
@node Comparison between GNAT and Conventional Ada Library Models,,Comparison between GNAT and C/C++ Compilation Models,GNAT and Other Compilation Models
-@anchor{gnat_ugn/the_gnat_compilation_model comparison-between-gnat-and-conventional-ada-library-models}@anchor{d6}@anchor{gnat_ugn/the_gnat_compilation_model id76}@anchor{d7}
+@anchor{gnat_ugn/the_gnat_compilation_model comparison-between-gnat-and-conventional-ada-library-models}@anchor{d0}@anchor{gnat_ugn/the_gnat_compilation_model id76}@anchor{d1}
@subsection Comparison between GNAT and Conventional Ada Library Models
@@ -7088,7 +7035,7 @@ of rules saying what source files must be present when a file is
compiled.
@node Using GNAT Files with External Tools,,GNAT and Other Compilation Models,The GNAT Compilation Model
-@anchor{gnat_ugn/the_gnat_compilation_model using-gnat-files-with-external-tools}@anchor{1c}@anchor{gnat_ugn/the_gnat_compilation_model id77}@anchor{d8}
+@anchor{gnat_ugn/the_gnat_compilation_model using-gnat-files-with-external-tools}@anchor{1a}@anchor{gnat_ugn/the_gnat_compilation_model id77}@anchor{d2}
@section Using GNAT Files with External Tools
@@ -7102,7 +7049,7 @@ used with tools designed for other languages.
@end menu
@node Using Other Utility Programs with GNAT,The External Symbol Naming Scheme of GNAT,,Using GNAT Files with External Tools
-@anchor{gnat_ugn/the_gnat_compilation_model using-other-utility-programs-with-gnat}@anchor{d9}@anchor{gnat_ugn/the_gnat_compilation_model id78}@anchor{da}
+@anchor{gnat_ugn/the_gnat_compilation_model using-other-utility-programs-with-gnat}@anchor{d3}@anchor{gnat_ugn/the_gnat_compilation_model id78}@anchor{d4}
@subsection Using Other Utility Programs with GNAT
@@ -7117,7 +7064,7 @@ gprof (a profiling program), gdb (the FSF debugger), and utilities such
as Purify.
@node The External Symbol Naming Scheme of GNAT,,Using Other Utility Programs with GNAT,Using GNAT Files with External Tools
-@anchor{gnat_ugn/the_gnat_compilation_model the-external-symbol-naming-scheme-of-gnat}@anchor{db}@anchor{gnat_ugn/the_gnat_compilation_model id79}@anchor{dc}
+@anchor{gnat_ugn/the_gnat_compilation_model the-external-symbol-naming-scheme-of-gnat}@anchor{d5}@anchor{gnat_ugn/the_gnat_compilation_model id79}@anchor{d6}
@subsection The External Symbol Naming Scheme of GNAT
@@ -7175,29 +7122,31 @@ the external name of this procedure will be @cite{_ada_hello}.
@c -- Example: A |withing| unit has a |with| clause, it |withs| a |withed| unit
-@node Building Executable Programs with GNAT,GNAT Project Manager,The GNAT Compilation Model,Top
-@anchor{gnat_ugn/building_executable_programs_with_gnat building-executable-programs-with-gnat}@anchor{a}@anchor{gnat_ugn/building_executable_programs_with_gnat doc}@anchor{dd}@anchor{gnat_ugn/building_executable_programs_with_gnat id1}@anchor{de}
+@node Building Executable Programs with GNAT,GNAT Utility Programs,The GNAT Compilation Model,Top
+@anchor{gnat_ugn/building_executable_programs_with_gnat building-executable-programs-with-gnat}@anchor{a}@anchor{gnat_ugn/building_executable_programs_with_gnat doc}@anchor{d7}@anchor{gnat_ugn/building_executable_programs_with_gnat id1}@anchor{d8}
@chapter Building Executable Programs with GNAT
This chapter describes first the gnatmake tool
-(@ref{1d,,Building with gnatmake}),
+(@ref{1b,,Building with gnatmake}),
which automatically determines the set of sources
needed by an Ada compilation unit and executes the necessary
(re)compilations, binding and linking.
It also explains how to use each tool individually: the
-compiler (gcc, see @ref{1e,,Compiling with gcc}),
-binder (gnatbind, see @ref{1f,,Binding with gnatbind}),
-and linker (gnatlink, see @ref{20,,Linking with gnatlink})
+compiler (gcc, see @ref{1c,,Compiling with gcc}),
+binder (gnatbind, see @ref{1d,,Binding with gnatbind}),
+and linker (gnatlink, see @ref{1e,,Linking with gnatlink})
to build executable programs.
Finally, this chapter provides examples of
how to make use of the general GNU make mechanism
-in a GNAT context (see @ref{21,,Using the GNU make Utility}).
+in a GNAT context (see @ref{1f,,Using the GNU make Utility}).
+
@menu
* Building with gnatmake::
* Compiling with gcc::
* Compiler Switches::
+* Linker Switches::
* Binding with gnatbind::
* Linking with gnatlink::
* Using the GNU make Utility::
@@ -7205,7 +7154,7 @@ in a GNAT context (see @ref{21,,Using the GNU make Utility}).
@end menu
@node Building with gnatmake,Compiling with gcc,,Building Executable Programs with GNAT
-@anchor{gnat_ugn/building_executable_programs_with_gnat the-gnat-make-program-gnatmake}@anchor{1d}@anchor{gnat_ugn/building_executable_programs_with_gnat building-with-gnatmake}@anchor{df}
+@anchor{gnat_ugn/building_executable_programs_with_gnat the-gnat-make-program-gnatmake}@anchor{1b}@anchor{gnat_ugn/building_executable_programs_with_gnat building-with-gnatmake}@anchor{d9}
@section Building with @emph{gnatmake}
@@ -7252,8 +7201,9 @@ changes to the source program cause corresponding changes in
dependencies, they will always be tracked exactly correctly by
@emph{gnatmake}.
-Note that for advanced description of project structure, we recommend creating
-a project file as explained in @ref{b,,GNAT Project Manager} and use the
+Note that for advanced forms of project structure, we recommend creating
+a project file as explained in the @emph{GNAT_Project_Manager} chapter in the
+@emph{GPRbuild User's Guide}, and using the
@emph{gprbuild} tool which supports building with project files and works similarly
to @emph{gnatmake}.
@@ -7268,7 +7218,7 @@ to @emph{gnatmake}.
@end menu
@node Running gnatmake,Switches for gnatmake,,Building with gnatmake
-@anchor{gnat_ugn/building_executable_programs_with_gnat running-gnatmake}@anchor{e0}@anchor{gnat_ugn/building_executable_programs_with_gnat id2}@anchor{e1}
+@anchor{gnat_ugn/building_executable_programs_with_gnat running-gnatmake}@anchor{da}@anchor{gnat_ugn/building_executable_programs_with_gnat id2}@anchor{db}
@subsection Running @emph{gnatmake}
@@ -7296,14 +7246,14 @@ be searched for in the specified directory only. Otherwise, the input
source file will first be searched in the directory where
@emph{gnatmake} was invoked and if it is not found, it will be search on
the source path of the compiler as described in
-@ref{8e,,Search Paths and the Run-Time Library (RTL)}.
+@ref{89,,Search Paths and the Run-Time Library (RTL)}.
All @emph{gnatmake} output (except when you specify @emph{-M}) is sent to
@code{stderr}. The output produced by the
@emph{-M} switch is sent to @code{stdout}.
@node Switches for gnatmake,Mode Switches for gnatmake,Running gnatmake,Building with gnatmake
-@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gnatmake}@anchor{e2}@anchor{gnat_ugn/building_executable_programs_with_gnat id3}@anchor{e3}
+@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gnatmake}@anchor{dc}@anchor{gnat_ugn/building_executable_programs_with_gnat id3}@anchor{dd}
@subsection Switches for @emph{gnatmake}
@@ -7677,7 +7627,7 @@ then instead object files and ALI files that already exist are overwritten
in place. This means that once a large project is organized into separate
directories in the desired manner, then @emph{gnatmake} will automatically
maintain and update this organization. If no ALI files are found on the
-Ada object path (see @ref{8e,,Search Paths and the Run-Time Library (RTL)}),
+Ada object path (see @ref{89,,Search Paths and the Run-Time Library (RTL)}),
the new object and ALI files are created in the
directory containing the source being compiled. If another organization
is desired, where objects and sources are kept in different directories,
@@ -7838,9 +7788,11 @@ Same as @code{--create-missing-dirs}
@item @code{-P@emph{project}}
Use project file @cite{project}. Only one such switch can be used.
-@ref{e4,,gnatmake and Project Files}.
@end table
+@c -- Comment:
+@c :ref:`gnatmake_and_Project_Files`.
+
@geindex -q (gnatmake)
@@ -7879,10 +7831,12 @@ This switch is recommended when Integrated Preprocessing is used.
Unique. Recompile at most the main files. It implies -c. Combined with
-f, it is equivalent to calling the compiler directly. Note that using
--u with a project file and no main has a special meaning
-(@ref{e5,,Project Files and Main Subprograms}).
+-u with a project file and no main has a special meaning.
@end table
+@c --Comment:
+@c (See :ref:`Project_Files_and_Main_Subprograms`.)
+
@geindex -U (gnatmake)
@@ -7939,7 +7893,7 @@ Verbosity level High. Equivalent to -v.
@item @code{-vP@emph{x}}
Indicate the verbosity of the parsing of GNAT project files.
-See @ref{e6,,Switches Related to Project Files}.
+See @ref{de,,Switches Related to Project Files}.
@end table
@geindex -x (gnatmake)
@@ -7963,7 +7917,7 @@ command line need to be sources of a project file.
Indicate that external variable @cite{name} has the value @cite{value}.
The Project Manager will use this value for occurrences of
@cite{external(name)} when parsing the project file.
-@ref{e6,,Switches Related to Project Files}.
+@ref{de,,Switches Related to Project Files}.
@end table
@geindex -z (gnatmake)
@@ -7997,7 +7951,7 @@ is passed to @emph{gcc} (e.g., @emph{-O}, @emph{-gnato,} etc.)
When looking for source files also look in directory @cite{dir}.
The order in which source files search is undertaken is
-described in @ref{8e,,Search Paths and the Run-Time Library (RTL)}.
+described in @ref{89,,Search Paths and the Run-Time Library (RTL)}.
@end table
@geindex -aL (gnatmake)
@@ -8029,7 +7983,7 @@ ALI files.
When searching for library and object files, look in directory
@cite{dir}. The order in which library files are searched is described in
-@ref{91,,Search Paths for gnatbind}.
+@ref{8c,,Search Paths for gnatbind}.
@end table
@geindex Search paths
@@ -8134,7 +8088,7 @@ The selected path is handled like a normal RTS path.
@end table
@node Mode Switches for gnatmake,Notes on the Command Line,Switches for gnatmake,Building with gnatmake
-@anchor{gnat_ugn/building_executable_programs_with_gnat id4}@anchor{e7}@anchor{gnat_ugn/building_executable_programs_with_gnat mode-switches-for-gnatmake}@anchor{e8}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id4}@anchor{df}@anchor{gnat_ugn/building_executable_programs_with_gnat mode-switches-for-gnatmake}@anchor{e0}
@subsection Mode Switches for @emph{gnatmake}
@@ -8194,7 +8148,7 @@ or @emph{-largs}.
@end table
@node Notes on the Command Line,How gnatmake Works,Mode Switches for gnatmake,Building with gnatmake
-@anchor{gnat_ugn/building_executable_programs_with_gnat id5}@anchor{e9}@anchor{gnat_ugn/building_executable_programs_with_gnat notes-on-the-command-line}@anchor{ea}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id5}@anchor{e1}@anchor{gnat_ugn/building_executable_programs_with_gnat notes-on-the-command-line}@anchor{e2}
@subsection Notes on the Command Line
@@ -8264,7 +8218,7 @@ that the debugging information may be out of date.
@end itemize
@node How gnatmake Works,Examples of gnatmake Usage,Notes on the Command Line,Building with gnatmake
-@anchor{gnat_ugn/building_executable_programs_with_gnat id6}@anchor{eb}@anchor{gnat_ugn/building_executable_programs_with_gnat how-gnatmake-works}@anchor{ec}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id6}@anchor{e3}@anchor{gnat_ugn/building_executable_programs_with_gnat how-gnatmake-works}@anchor{e4}
@subsection How @emph{gnatmake} Works
@@ -8304,14 +8258,14 @@ When invoking @emph{gnatmake} with several @cite{file_names}, if a unit is
imported by several of the executables, it will be recompiled at most once.
Note: when using non-standard naming conventions
-(@ref{37,,Using Other File Names}), changing through a configuration pragmas
+(@ref{35,,Using Other File Names}), changing through a configuration pragmas
file the version of a source and invoking @emph{gnatmake} to recompile may
have no effect, if the previous version of the source is still accessible
by @emph{gnatmake}. It may be necessary to use the switch
-f.
@node Examples of gnatmake Usage,,How gnatmake Works,Building with gnatmake
-@anchor{gnat_ugn/building_executable_programs_with_gnat examples-of-gnatmake-usage}@anchor{ed}@anchor{gnat_ugn/building_executable_programs_with_gnat id7}@anchor{ee}
+@anchor{gnat_ugn/building_executable_programs_with_gnat examples-of-gnatmake-usage}@anchor{e5}@anchor{gnat_ugn/building_executable_programs_with_gnat id7}@anchor{e6}
@subsection Examples of @emph{gnatmake} Usage
@@ -8343,7 +8297,7 @@ displaying commands it is executing.
@end table
@node Compiling with gcc,Compiler Switches,Building with gnatmake,Building Executable Programs with GNAT
-@anchor{gnat_ugn/building_executable_programs_with_gnat compiling-with-gcc}@anchor{1e}@anchor{gnat_ugn/building_executable_programs_with_gnat id8}@anchor{ef}
+@anchor{gnat_ugn/building_executable_programs_with_gnat compiling-with-gcc}@anchor{1c}@anchor{gnat_ugn/building_executable_programs_with_gnat id8}@anchor{e7}
@section Compiling with @emph{gcc}
@@ -8360,7 +8314,7 @@ that can be used to control the behavior of the compiler.
@end menu
@node Compiling Programs,Search Paths and the Run-Time Library RTL,,Compiling with gcc
-@anchor{gnat_ugn/building_executable_programs_with_gnat compiling-programs}@anchor{f0}@anchor{gnat_ugn/building_executable_programs_with_gnat id9}@anchor{f1}
+@anchor{gnat_ugn/building_executable_programs_with_gnat compiling-programs}@anchor{e8}@anchor{gnat_ugn/building_executable_programs_with_gnat id9}@anchor{e9}
@subsection Compiling Programs
@@ -8471,11 +8425,11 @@ calls @cite{gnat1} (the Ada compiler) twice to compile @code{x.adb} and
The compiler generates two object files @code{x.o} and @code{y.o}
and the two ALI files @code{x.ali} and @code{y.ali}.
-Any switches apply to all the files listed, see @ref{f2,,Compiler Switches} for a
+Any switches apply to all the files listed, see @ref{ea,,Compiler Switches} for a
list of available @emph{gcc} switches.
@node Search Paths and the Run-Time Library RTL,Order of Compilation Issues,Compiling Programs,Compiling with gcc
-@anchor{gnat_ugn/building_executable_programs_with_gnat id10}@anchor{f3}@anchor{gnat_ugn/building_executable_programs_with_gnat search-paths-and-the-run-time-library-rtl}@anchor{8e}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id10}@anchor{eb}@anchor{gnat_ugn/building_executable_programs_with_gnat search-paths-and-the-run-time-library-rtl}@anchor{89}
@subsection Search Paths and the Run-Time Library (RTL)
@@ -8532,7 +8486,7 @@ names separated by colons (semicolons when working with the NT version).
The content of the @code{ada_source_path} file which is part of the GNAT
installation tree and is used to store standard libraries such as the
GNAT Run Time Library (RTL) source files.
-@ref{8b,,Installing a library}
+@ref{87,,Installing a library}
@end itemize
Specifying the switch @emph{-I-}
@@ -8574,7 +8528,7 @@ in compiling sources from multiple directories. This can make
development environments much more flexible.
@node Order of Compilation Issues,Examples,Search Paths and the Run-Time Library RTL,Compiling with gcc
-@anchor{gnat_ugn/building_executable_programs_with_gnat id11}@anchor{f4}@anchor{gnat_ugn/building_executable_programs_with_gnat order-of-compilation-issues}@anchor{f5}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id11}@anchor{ec}@anchor{gnat_ugn/building_executable_programs_with_gnat order-of-compilation-issues}@anchor{ed}
@subsection Order of Compilation Issues
@@ -8602,7 +8556,7 @@ source files on which it depends.
@item
There is no library as such, apart from the ALI files
-(@ref{44,,The Ada Library Information Files}, for information on the format
+(@ref{42,,The Ada Library Information Files}, for information on the format
of these files). For now we find it convenient to create separate ALI files,
but eventually the information therein may be incorporated into the object
file directly.
@@ -8615,7 +8569,7 @@ described above), or you will receive a fatal error message.
@end itemize
@node Examples,,Order of Compilation Issues,Compiling with gcc
-@anchor{gnat_ugn/building_executable_programs_with_gnat id12}@anchor{f6}@anchor{gnat_ugn/building_executable_programs_with_gnat examples}@anchor{f7}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id12}@anchor{ee}@anchor{gnat_ugn/building_executable_programs_with_gnat examples}@anchor{ef}
@subsection Examples
@@ -8642,8 +8596,8 @@ $ gcc -c -gnatc abc-def.adb
Compile the subunit in file @code{abc-def.adb} in semantic-checking-only
mode.
-@node Compiler Switches,Binding with gnatbind,Compiling with gcc,Building Executable Programs with GNAT
-@anchor{gnat_ugn/building_executable_programs_with_gnat compiler-switches}@anchor{f8}@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gcc}@anchor{f2}
+@node Compiler Switches,Linker Switches,Compiling with gcc,Building Executable Programs with GNAT
+@anchor{gnat_ugn/building_executable_programs_with_gnat compiler-switches}@anchor{f0}@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gcc}@anchor{ea}
@section Compiler Switches
@@ -8682,7 +8636,7 @@ compilation units.
@end menu
@node Alphabetical List of All Switches,Output and Error Message Control,,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat id13}@anchor{f9}@anchor{gnat_ugn/building_executable_programs_with_gnat alphabetical-list-of-all-switches}@anchor{fa}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id13}@anchor{f1}@anchor{gnat_ugn/building_executable_programs_with_gnat alphabetical-list-of-all-switches}@anchor{f2}
@subsection Alphabetical List of All Switches
@@ -8868,7 +8822,7 @@ and thus producing inferior code.
Causes the compiler to avoid assumptions regarding non-aliasing
of objects of different types. See
-@ref{fb,,Optimization and Strict Aliasing} for details.
+@ref{f3,,Optimization and Strict Aliasing} for details.
@end table
@geindex -fno-strict-overflow (gcc)
@@ -8894,7 +8848,7 @@ for very peculiar cases of low-level programming.
@item @code{-fstack-check}
Activates stack checking.
-See @ref{fc,,Stack Overflow Checking} for details.
+See @ref{f4,,Stack Overflow Checking} for details.
@end table
@geindex -fstack-usage (gcc)
@@ -8905,7 +8859,7 @@ See @ref{fc,,Stack Overflow Checking} for details.
@item @code{-fstack-usage}
Makes the compiler output stack usage information for the program, on a
-per-subprogram basis. See @ref{fd,,Static Stack Usage Analysis} for details.
+per-subprogram basis. See @ref{f5,,Static Stack Usage Analysis} for details.
@end table
@geindex -g (gcc)
@@ -9035,7 +8989,7 @@ Generate brief messages to @code{stderr} even if verbose mode set.
@item @code{-gnatB}
Assume no invalid (bad) values except for 'Valid attribute use
-(@ref{fe,,Validity Checking}).
+(@ref{f6,,Validity Checking}).
@end table
@geindex -gnatc (gcc)
@@ -9053,9 +9007,7 @@ object file after compilation. If @emph{gnatmake} is called with
@emph{-gnatc} as a builder switch (before @emph{-cargs} or in package
Builder of the project file) then @emph{gnatmake} will not fail because
it will not look for the object files after compilation, and it will not try
-to build and link. This switch may not be given if a previous @cite{-gnatR}
-switch has been given, since @cite{-gnatR} requires that the code generator
-be called to complete determination of representation information.
+to build and link.
@end table
@geindex -gnatC (gcc)
@@ -9096,7 +9048,7 @@ users guide.
@item @code{-gnatD}
Create expanded source files for source level debugging. This switch
-also suppress generation of cross-reference information
+also suppresses generation of cross-reference information
(see @emph{-gnatx}). Note that this switch is not allowed if a previous
-gnatR switch has been given, since these two switches are not compatible.
@end table
@@ -9150,7 +9102,7 @@ not share the memory location of @cite{Obj}.
Specify a configuration pragma file
(the equal sign is optional)
-(@ref{7b,,The Configuration Pragmas Files}).
+(@ref{79,,The Configuration Pragmas Files}).
@end table
@geindex -gnateC (gcc)
@@ -9183,7 +9135,7 @@ Disable atomic synchronization
@item @code{-gnateDsymbol[=@emph{value}]}
Defines a symbol, associated with @cite{value}, for preprocessing.
-(@ref{1a,,Integrated Preprocessing}).
+(@ref{18,,Integrated Preprocessing}).
@end table
@geindex -gnateE (gcc)
@@ -9232,7 +9184,7 @@ for unconstrained predefined types. See description of pragma
The @cite{-gnatc} switch must always be specified before this switch, e.g.
@cite{-gnatceg}. Generate a C header from the Ada input file. See
-@ref{d0,,Generating C Headers for Ada Specifications} for more
+@ref{ca,,Generating C Headers for Ada Specifications} for more
information.
@end quotation
@@ -9306,7 +9258,7 @@ This switch turns off the info messages about implicit elaboration pragmas.
Specify a mapping file
(the equal sign is optional)
-(@ref{ff,,Units to Sources Mapping Files}).
+(@ref{f7,,Units to Sources Mapping Files}).
@end table
@geindex -gnatep (gcc)
@@ -9318,7 +9270,7 @@ Specify a mapping file
Specify a preprocessing data file
(the equal sign is optional)
-(@ref{1a,,Integrated Preprocessing}).
+(@ref{18,,Integrated Preprocessing}).
@end table
@geindex -gnateP (gcc)
@@ -9488,7 +9440,7 @@ support this switch.
@item @code{-gnateV}
Check that all actual parameters of a subprogram call are valid according to
-the rules of validity checking (@ref{fe,,Validity Checking}).
+the rules of validity checking (@ref{f6,,Validity Checking}).
@end table
@geindex -gnateY (gcc)
@@ -9581,7 +9533,7 @@ Output usage information. The output is written to @code{stdout}.
Identifier character set (@cite{c} = 1/2/3/4/8/9/p/f/n/w).
For details of the possible selections for @cite{c},
-see @ref{4a,,Character Set Control}.
+see @ref{48,,Character Set Control}.
@end table
@geindex -gnatI (gcc)
@@ -9674,8 +9626,8 @@ means that no limit applies.
@item @code{-gnatn[12]}
-Activate inlining for subprograms for which pragma @cite{Inline} is
-specified. This inlining is performed by the GCC back-end. An optional
+Activate inlining across modules for subprograms for which pragma @cite{Inline}
+is specified. This inlining is performed by the GCC back-end. An optional
digit sets the inlining level: 1 for moderate inlining across modules
or 2 for full inlining across modules. If no inlining level is specified,
the compiler will pick it based on the optimization level.
@@ -9782,7 +9734,7 @@ overflow checking is enabled.
Note that division by zero is a separate check that is not
controlled by this switch (divide-by-zero checking is on by default).
-See also @ref{100,,Specifying the Desired Mode}.
+See also @ref{f8,,Specifying the Desired Mode}.
@end table
@geindex -gnatp (gcc)
@@ -9792,7 +9744,7 @@ See also @ref{100,,Specifying the Desired Mode}.
@item @code{-gnatp}
-Suppress all checks. See @ref{101,,Run-Time Checks} for details. This switch
+Suppress all checks. See @ref{f9,,Run-Time Checks} for details. This switch
has no effect if cancelled by a subsequent @emph{-gnat-p} switch.
@end table
@@ -9944,7 +9896,7 @@ Verbose mode. Full error output with source lines to @code{stdout}.
@item @code{-gnatV}
-Control level of validity checking (@ref{fe,,Validity Checking}).
+Control level of validity checking (@ref{f6,,Validity Checking}).
@end table
@geindex -gnatw (gcc)
@@ -9957,7 +9909,7 @@ Control level of validity checking (@ref{fe,,Validity Checking}).
Warning mode where
@cite{xxx} is a string of option letters that denotes
the exact warnings that
-are enabled or disabled (@ref{102,,Warning Message Control}).
+are enabled or disabled (@ref{fa,,Warning Message Control}).
@end table
@geindex -gnatW (gcc)
@@ -9998,7 +9950,7 @@ Enable GNAT implementation extensions and latest Ada version.
@item @code{-gnaty}
-Enable built-in style checks (@ref{103,,Style Checking}).
+Enable built-in style checks (@ref{fb,,Style Checking}).
@end table
@geindex -gnatz (gcc)
@@ -10023,7 +9975,7 @@ Distribution stub generation and compilation
Direct GNAT to search the @cite{dir} directory for source files needed by
the current compilation
-(see @ref{8e,,Search Paths and the Run-Time Library (RTL)}).
+(see @ref{89,,Search Paths and the Run-Time Library (RTL)}).
@end table
@geindex -I- (gcc)
@@ -10037,7 +9989,7 @@ the current compilation
Except for the source file named in the command line, do not look for source
files in the directory containing the source file named in the command line
-(see @ref{8e,,Search Paths and the Run-Time Library (RTL)}).
+(see @ref{89,,Search Paths and the Run-Time Library (RTL)}).
@end table
@geindex -o (gcc)
@@ -10141,7 +10093,7 @@ Optimize space usage
@end multitable
-See also @ref{104,,Optimization Levels}.
+See also @ref{fc,,Optimization Levels}.
@end table
@geindex -pass-exit-codes (gcc)
@@ -10163,7 +10115,7 @@ exit status.
@item @code{--RTS=@emph{rts-path}}
Specifies the default location of the runtime library. Same meaning as the
-equivalent @emph{gnatmake} flag (@ref{e2,,Switches for gnatmake}).
+equivalent @emph{gnatmake} flag (@ref{dc,,Switches for gnatmake}).
@end table
@geindex -S (gcc)
@@ -10289,7 +10241,7 @@ as warning mode modifiers (see description of @emph{-gnatw}).
@item
Once a 'V' appears in the string (that is a use of the @emph{-gnatV}
switch), then all further characters in the switch are interpreted
-as validity checking options (@ref{fe,,Validity Checking}).
+as validity checking options (@ref{f6,,Validity Checking}).
@item
Option 'em', 'ec', 'ep', 'l=' and 'R' must be the last options in
@@ -10297,7 +10249,7 @@ a combined list of options.
@end itemize
@node Output and Error Message Control,Warning Message Control,Alphabetical List of All Switches,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat id14}@anchor{105}@anchor{gnat_ugn/building_executable_programs_with_gnat output-and-error-message-control}@anchor{106}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id14}@anchor{fd}@anchor{gnat_ugn/building_executable_programs_with_gnat output-and-error-message-control}@anchor{fe}
@subsection Output and Error Message Control
@@ -10600,7 +10552,7 @@ since ALI files are never generated if @emph{-gnats} is set.
@end table
@node Warning Message Control,Debugging and Assertion Control,Output and Error Message Control,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat warning-message-control}@anchor{102}@anchor{gnat_ugn/building_executable_programs_with_gnat id15}@anchor{107}
+@anchor{gnat_ugn/building_executable_programs_with_gnat warning-message-control}@anchor{fa}@anchor{gnat_ugn/building_executable_programs_with_gnat id15}@anchor{ff}
@subsection Warning Message Control
@@ -11287,11 +11239,10 @@ but more warnings may be added in the future without advanced notice.
@geindex Hiding of Declarations
-This switch activates warnings on hiding declarations.
-A declaration is considered hiding
-if it is for a non-overloadable entity, and it declares an entity with the
-same name as some other entity that is directly or use-visible. The default
-is that such warnings are not generated.
+This switch activates warnings on hiding declarations that are considered
+potentially confusing. Not all cases of hiding cause warnings; for example an
+overriding declaration hides an implicit declaration, which is just normal
+code. The default is that warnings on hiding are not generated.
@end table
@geindex -gnatwH (gcc)
@@ -12496,7 +12447,7 @@ used in conjunction with an optimization level greater than zero.
@item @code{-Wstack-usage=@emph{len}}
Warn if the stack usage of a subprogram might be larger than @cite{len} bytes.
-See @ref{fd,,Static Stack Usage Analysis} for details.
+See @ref{f5,,Static Stack Usage Analysis} for details.
@end table
@geindex -Wall (gcc)
@@ -12664,7 +12615,7 @@ When no switch @emph{-gnatw} is used, this is equivalent to:
@end quotation
@node Debugging and Assertion Control,Validity Checking,Warning Message Control,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat debugging-and-assertion-control}@anchor{108}@anchor{gnat_ugn/building_executable_programs_with_gnat id16}@anchor{109}
+@anchor{gnat_ugn/building_executable_programs_with_gnat debugging-and-assertion-control}@anchor{100}@anchor{gnat_ugn/building_executable_programs_with_gnat id16}@anchor{101}
@subsection Debugging and Assertion Control
@@ -12753,7 +12704,7 @@ is @cite{False}, the exception @cite{Assert_Failure} is raised.
@end table
@node Validity Checking,Style Checking,Debugging and Assertion Control,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat validity-checking}@anchor{fe}@anchor{gnat_ugn/building_executable_programs_with_gnat id17}@anchor{10a}
+@anchor{gnat_ugn/building_executable_programs_with_gnat validity-checking}@anchor{f6}@anchor{gnat_ugn/building_executable_programs_with_gnat id17}@anchor{102}
@subsection Validity Checking
@@ -13042,7 +12993,7 @@ the validity checking mode at the program source level, and also allows for
temporary disabling of validity checks.
@node Style Checking,Run-Time Checks,Validity Checking,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat id18}@anchor{10b}@anchor{gnat_ugn/building_executable_programs_with_gnat style-checking}@anchor{103}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id18}@anchor{103}@anchor{gnat_ugn/building_executable_programs_with_gnat style-checking}@anchor{fb}
@subsection Style Checking
@@ -13750,7 +13701,7 @@ built-in standard style check options are enabled.
The switch @code{-gnatyN} clears any previously set style checks.
@node Run-Time Checks,Using gcc for Syntax Checking,Style Checking,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat run-time-checks}@anchor{101}@anchor{gnat_ugn/building_executable_programs_with_gnat id19}@anchor{10c}
+@anchor{gnat_ugn/building_executable_programs_with_gnat run-time-checks}@anchor{f9}@anchor{gnat_ugn/building_executable_programs_with_gnat id19}@anchor{104}
@subsection Run-Time Checks
@@ -13944,7 +13895,7 @@ on subprogram calls and generic instantiations.
Note that @emph{-gnatE} is not necessary for safety, because in the
default mode, GNAT ensures statically that the checks would not fail.
For full details of the effect and use of this switch,
-@ref{1e,,Compiling with gcc}.
+@ref{1c,,Compiling with gcc}.
@end table
@geindex -fstack-check (gcc)
@@ -13960,7 +13911,7 @@ For full details of the effect and use of this switch,
@item @code{-fstack-check}
Activates stack overflow checking. For full details of the effect and use of
-this switch see @ref{fc,,Stack Overflow Checking}.
+this switch see @ref{f4,,Stack Overflow Checking}.
@end table
@geindex Unsuppress
@@ -13971,7 +13922,7 @@ checks) or @cite{Unsuppress} (to add back suppressed checks) pragmas in
the program source.
@node Using gcc for Syntax Checking,Using gcc for Semantic Checking,Run-Time Checks,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat id20}@anchor{10d}@anchor{gnat_ugn/building_executable_programs_with_gnat using-gcc-for-syntax-checking}@anchor{10e}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id20}@anchor{105}@anchor{gnat_ugn/building_executable_programs_with_gnat using-gcc-for-syntax-checking}@anchor{106}
@subsection Using @emph{gcc} for Syntax Checking
@@ -14024,11 +13975,11 @@ Normally, GNAT allows only a single unit in a source file. However, this
restriction does not apply in syntax-check-only mode, and it is possible
to check a file containing multiple compilation units concatenated
together. This is primarily used by the @cite{gnatchop} utility
-(@ref{38,,Renaming Files with gnatchop}).
+(@ref{36,,Renaming Files with gnatchop}).
@end table
@node Using gcc for Semantic Checking,Compiling Different Versions of Ada,Using gcc for Syntax Checking,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat id21}@anchor{10f}@anchor{gnat_ugn/building_executable_programs_with_gnat using-gcc-for-semantic-checking}@anchor{110}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id21}@anchor{107}@anchor{gnat_ugn/building_executable_programs_with_gnat using-gcc-for-semantic-checking}@anchor{108}
@subsection Using @emph{gcc} for Semantic Checking
@@ -14053,13 +14004,13 @@ semantic restrictions on file structuring to operate in this mode:
@item
The needed source files must be accessible
-(see @ref{8e,,Search Paths and the Run-Time Library (RTL)}).
+(see @ref{89,,Search Paths and the Run-Time Library (RTL)}).
@item
Each file must contain only one compilation unit.
@item
-The file name and unit name must match (@ref{54,,File Naming Rules}).
+The file name and unit name must match (@ref{52,,File Naming Rules}).
@end itemize
The output consists of error messages as appropriate. No object file is
@@ -14075,7 +14026,7 @@ and specifications where a separate body is present).
@end table
@node Compiling Different Versions of Ada,Character Set Control,Using gcc for Semantic Checking,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat compiling-different-versions-of-ada}@anchor{6}@anchor{gnat_ugn/building_executable_programs_with_gnat id22}@anchor{111}
+@anchor{gnat_ugn/building_executable_programs_with_gnat compiling-different-versions-of-ada}@anchor{6}@anchor{gnat_ugn/building_executable_programs_with_gnat id22}@anchor{109}
@subsection Compiling Different Versions of Ada
@@ -14209,7 +14160,7 @@ extensions, see the GNAT reference manual.
@end table
@node Character Set Control,File Naming Control,Compiling Different Versions of Ada,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat id23}@anchor{112}@anchor{gnat_ugn/building_executable_programs_with_gnat character-set-control}@anchor{4a}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id23}@anchor{10a}@anchor{gnat_ugn/building_executable_programs_with_gnat character-set-control}@anchor{48}
@subsection Character Set Control
@@ -14320,7 +14271,7 @@ allowed in identifiers
@end multitable
-See @ref{40,,Foreign Language Representation} for full details on the
+See @ref{3e,,Foreign Language Representation} for full details on the
implementation of these character sets.
@end table
@@ -14388,7 +14339,7 @@ Brackets encoding only (default value)
For full details on these encoding
-methods see @ref{50,,Wide_Character Encodings}.
+methods see @ref{4e,,Wide_Character Encodings}.
Note that brackets coding is always accepted, even if one of the other
options is specified, so for example @emph{-gnatW8} specifies that both
brackets and UTF-8 encodings will be recognized. The units that are
@@ -14436,7 +14387,7 @@ comments are ended by an appropriate (CR, or CR/LF, or LF) line terminator.
This is a common mode for many programs with foreign language comments.
@node File Naming Control,Subprogram Inlining Control,Character Set Control,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat file-naming-control}@anchor{113}@anchor{gnat_ugn/building_executable_programs_with_gnat id24}@anchor{114}
+@anchor{gnat_ugn/building_executable_programs_with_gnat file-naming-control}@anchor{10b}@anchor{gnat_ugn/building_executable_programs_with_gnat id24}@anchor{10c}
@subsection File Naming Control
@@ -14452,11 +14403,11 @@ Activates file name 'krunching'. @cite{n}, a decimal integer in the range
including the @code{.ads} or @code{.adb} extension). The default is not
to enable file name krunching.
-For the source file naming rules, @ref{54,,File Naming Rules}.
+For the source file naming rules, @ref{52,,File Naming Rules}.
@end table
@node Subprogram Inlining Control,Auxiliary Output Control,File Naming Control,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat subprogram-inlining-control}@anchor{115}@anchor{gnat_ugn/building_executable_programs_with_gnat id25}@anchor{116}
+@anchor{gnat_ugn/building_executable_programs_with_gnat subprogram-inlining-control}@anchor{10d}@anchor{gnat_ugn/building_executable_programs_with_gnat id25}@anchor{10e}
@subsection Subprogram Inlining Control
@@ -14467,16 +14418,16 @@ For the source file naming rules, @ref{54,,File Naming Rules}.
@item @code{-gnatn[12]}
-The @cite{n} here is intended to suggest the first syllable of the
-word 'inline'.
-GNAT recognizes and processes @cite{Inline} pragmas. However, for the
-inlining to actually occur, optimization must be enabled and, in order
-to enable inlining of subprograms specified by pragma @cite{Inline},
+The @cite{n} here is intended to suggest the first syllable of the word 'inline'.
+GNAT recognizes and processes @cite{Inline} pragmas. However, for inlining to
+actually occur, optimization must be enabled and, by default, inlining of
+subprograms across modules is not performed. If you want to additionally
+enable inlining of subprograms specified by pragma @cite{Inline} across modules,
you must also specify this switch.
-In the absence of this switch, GNAT does not attempt
-inlining and does not need to access the bodies of
-subprograms for which @cite{pragma Inline} is specified if they are not
-in the current unit.
+
+In the absence of this switch, GNAT does not attempt inlining across modules
+and does not access the bodies of subprograms for which @cite{pragma Inline} is
+specified if they are not in the current unit.
You can optionally specify the inlining level: 1 for moderate inlining across
modules, which is a good compromise between compilation times and performances
@@ -14489,7 +14440,7 @@ If you specify this switch the compiler will access these bodies,
creating an extra source dependency for the resulting object file, and
where possible, the call will be inlined.
For further details on when inlining is possible
-see @ref{117,,Inlining of Subprograms}.
+see @ref{10f,,Inlining of Subprograms}.
@end table
@geindex -gnatN (gcc)
@@ -14510,7 +14461,7 @@ inlining, but that is no longer the case.
@end table
@node Auxiliary Output Control,Debugging Control,Subprogram Inlining Control,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat auxiliary-output-control}@anchor{118}@anchor{gnat_ugn/building_executable_programs_with_gnat id26}@anchor{119}
+@anchor{gnat_ugn/building_executable_programs_with_gnat auxiliary-output-control}@anchor{110}@anchor{gnat_ugn/building_executable_programs_with_gnat id26}@anchor{111}
@subsection Auxiliary Output Control
@@ -14602,7 +14553,7 @@ An object file has been generated for every source file.
@end table
@node Debugging Control,Exception Handling Control,Auxiliary Output Control,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat debugging-control}@anchor{11a}@anchor{gnat_ugn/building_executable_programs_with_gnat id27}@anchor{11b}
+@anchor{gnat_ugn/building_executable_programs_with_gnat debugging-control}@anchor{112}@anchor{gnat_ugn/building_executable_programs_with_gnat id27}@anchor{113}
@subsection Debugging Control
@@ -14783,7 +14734,7 @@ will refer to the generated @code{xxx.dg} file. This allows
you to do source level debugging using the generated code which is
sometimes useful for complex code, for example to find out exactly
which part of a complex construction raised an exception. This switch
-also suppress generation of cross-reference information (see
+also suppresses generation of cross-reference information (see
@emph{-gnatx}) since otherwise the cross-reference information
would refer to the @code{.dg} file, which would cause
confusion since this is not the original source file.
@@ -14859,12 +14810,6 @@ and parameter passing mechanisms for all subprograms. A following
Note that it is possible for record components to have zero size. In
this case, the component clause uses an obvious extension of permitted
Ada syntax, for example @cite{at 0 range 0 .. -1}.
-
-Representation information requires that code be generated (since it is the
-code generator that lays out complex data structures). If an attempt is made
-to output representation information when no code is generated, for example
-when a subunit is compiled on its own, then no information can be generated
-and the compiler outputs a message to this effect.
@end table
@geindex -gnatS (gcc)
@@ -14901,7 +14846,7 @@ speed up compilation, but means that these tools cannot be used.
@end table
@node Exception Handling Control,Units to Sources Mapping Files,Debugging Control,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat id28}@anchor{11c}@anchor{gnat_ugn/building_executable_programs_with_gnat exception-handling-control}@anchor{11d}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id28}@anchor{114}@anchor{gnat_ugn/building_executable_programs_with_gnat exception-handling-control}@anchor{115}
@subsection Exception Handling Control
@@ -14969,11 +14914,11 @@ is available for the target in use, otherwise it will generate an error.
The same option @emph{--RTS} must be used both for @emph{gcc}
and @emph{gnatbind}. Passing this option to @emph{gnatmake}
-(@ref{e2,,Switches for gnatmake}) will ensure the required consistency
+(@ref{dc,,Switches for gnatmake}) will ensure the required consistency
through the compilation and binding steps.
@node Units to Sources Mapping Files,Code Generation Control,Exception Handling Control,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat id29}@anchor{11e}@anchor{gnat_ugn/building_executable_programs_with_gnat units-to-sources-mapping-files}@anchor{ff}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id29}@anchor{116}@anchor{gnat_ugn/building_executable_programs_with_gnat units-to-sources-mapping-files}@anchor{f7}
@subsection Units to Sources Mapping Files
@@ -15025,7 +14970,7 @@ mapping file and communicates it to the compiler using this switch.
@end table
@node Code Generation Control,,Units to Sources Mapping Files,Compiler Switches
-@anchor{gnat_ugn/building_executable_programs_with_gnat code-generation-control}@anchor{11f}@anchor{gnat_ugn/building_executable_programs_with_gnat id30}@anchor{120}
+@anchor{gnat_ugn/building_executable_programs_with_gnat code-generation-control}@anchor{117}@anchor{gnat_ugn/building_executable_programs_with_gnat id30}@anchor{118}
@subsection Code Generation Control
@@ -15053,8 +14998,28 @@ special needs lead to requirements in this area. In particular,
there is no point in using @emph{-m} switches to improve performance
unless you actually see a performance improvement.
-@node Binding with gnatbind,Linking with gnatlink,Compiler Switches,Building Executable Programs with GNAT
-@anchor{gnat_ugn/building_executable_programs_with_gnat binding-with-gnatbind}@anchor{1f}@anchor{gnat_ugn/building_executable_programs_with_gnat id31}@anchor{121}
+@node Linker Switches,Binding with gnatbind,Compiler Switches,Building Executable Programs with GNAT
+@anchor{gnat_ugn/building_executable_programs_with_gnat linker-switches}@anchor{119}@anchor{gnat_ugn/building_executable_programs_with_gnat id31}@anchor{11a}
+@section Linker Switches
+
+
+Linker switches can be specified after @code{-largs} builder switch.
+
+@geindex -fuse-ld=name
+
+
+@table @asis
+
+@item @code{-fuse-ld=@emph{name}}
+
+Linker to be used. The default is @code{bfd} for @code{ld.bfd},
+the alternative being @code{gold} for @code{ld.gold}. The later is
+a more recent and faster linker, but only available on GNU/Linux
+platforms.
+@end table
+
+@node Binding with gnatbind,Linking with gnatlink,Linker Switches,Building Executable Programs with GNAT
+@anchor{gnat_ugn/building_executable_programs_with_gnat binding-with-gnatbind}@anchor{1d}@anchor{gnat_ugn/building_executable_programs_with_gnat id32}@anchor{11b}
@section Binding with @cite{gnatbind}
@@ -15064,7 +15029,7 @@ This chapter describes the GNAT binder, @cite{gnatbind}, which is used
to bind compiled GNAT objects.
Note: to invoke @cite{gnatbind} with a project file, use the @cite{gnat}
-driver (see @ref{122,,The GNAT Driver and Project Files}).
+driver (see @emph{The_GNAT_Driver_and_Project_Files}).
The @cite{gnatbind} program performs four separate functions:
@@ -15108,7 +15073,7 @@ to be read by the @emph{gnatlink} utility used to link the Ada application.
@end menu
@node Running gnatbind,Switches for gnatbind,,Binding with gnatbind
-@anchor{gnat_ugn/building_executable_programs_with_gnat running-gnatbind}@anchor{123}@anchor{gnat_ugn/building_executable_programs_with_gnat id32}@anchor{124}
+@anchor{gnat_ugn/building_executable_programs_with_gnat running-gnatbind}@anchor{11c}@anchor{gnat_ugn/building_executable_programs_with_gnat id33}@anchor{11d}
@subsection Running @cite{gnatbind}
@@ -15183,7 +15148,7 @@ error: "p.ads" has been modified and must be recompiled
Now both files must be recompiled as indicated, and then the bind can
succeed, generating a main program. You need not normally be concerned
with the contents of this file, but for reference purposes a sample
-binder output file is given in @ref{10,,Example of Binder Output File}.
+binder output file is given in @ref{e,,Example of Binder Output File}.
In most normal usage, the default mode of @emph{gnatbind} which is to
generate the main package in Ada, as described in the previous section.
@@ -15193,7 +15158,7 @@ Ada code provided the @emph{-g} switch is used for
@emph{gnatbind} and @emph{gnatlink}.
@node Switches for gnatbind,Command-Line Access,Running gnatbind,Binding with gnatbind
-@anchor{gnat_ugn/building_executable_programs_with_gnat id33}@anchor{125}@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gnatbind}@anchor{126}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id34}@anchor{11e}@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gnatbind}@anchor{11f}
@subsection Switches for @emph{gnatbind}
@@ -15327,10 +15292,12 @@ relevant. It only give some control over the size of the allocated
blocks (whose size is the minimum of the default secondary stack size value,
and the actual size needed for the current allocation request).
-For certain targets, notably VxWorks 653,
-the secondary stack is allocated by carving off a fixed ratio chunk of the
-primary task stack. The -D option is used to define the
-size of the environment task's secondary stack.
+For certain targets, notably VxWorks 653 and bare board targets,
+the secondary stack is allocated by carving off a chunk of the primary task
+stack. By default this is a fixed percentage of the primary task stack as
+defined by System.Parameter.Sec_Stack_Percentage. This can be overridden per
+task using the Secondary_Stack_Size pragma/aspect. The -D option is used to
+define the size of the environment task's secondary stack.
@end table
@geindex -e (gnatbind)
@@ -15381,6 +15348,16 @@ The "s" is for "symbolic"; symbolic tracebacks are enabled.
Currently the same as @cite{-Ea}.
@end table
+@geindex -f (gnatbind)
+
+
+@table @asis
+
+@item @code{-f@emph{elab-order}}
+
+Force elaboration order.
+@end table
+
@geindex -F (gnatbind)
@@ -15411,7 +15388,7 @@ Output usage (help) information.
@item @code{-H32}
Use 32-bit allocations for @cite{__gnat_malloc} (and thus for access types).
-For further details see @ref{127,,Dynamic Allocation Control}.
+For further details see @ref{120,,Dynamic Allocation Control}.
@geindex -H64 (gnatbind)
@@ -15420,7 +15397,7 @@ For further details see @ref{127,,Dynamic Allocation Control}.
@item @code{-H64}
Use 64-bit allocations for @cite{__gnat_malloc} (and thus for access types).
-For further details see @ref{127,,Dynamic Allocation Control}.
+For further details see @ref{120,,Dynamic Allocation Control}.
@geindex -I (gnatbind)
@@ -15447,7 +15424,7 @@ Output chosen elaboration order.
@item @code{-L@emph{xxx}}
Bind the units for library building. In this case the adainit and
-adafinal procedures (@ref{ba,,Binding with Non-Ada Main Programs})
+adafinal procedures (@ref{b4,,Binding with Non-Ada Main Programs})
are renamed to @cite{xxx`init and `xxx`final. Implies -n. (:ref:`GNAT_and_Libraries}, for more details.)
@geindex -M (gnatbind)
@@ -15493,7 +15470,7 @@ Do not look for library files in the system default directory.
@item @code{--RTS=@emph{rts-path}}
Specifies the default location of the runtime library. Same meaning as the
-equivalent @emph{gnatmake} flag (@ref{e2,,Switches for gnatmake}).
+equivalent @emph{gnatmake} flag (@ref{dc,,Switches for gnatmake}).
@geindex -o (gnatbind)
@@ -15647,7 +15624,7 @@ Enable dynamic stack usage, with @cite{n} results stored and displayed
at program termination. A result is generated when a task
terminates. Results that can't be stored are displayed on the fly, at
task termination. This option is currently not supported on Itanium
-platforms. (See @ref{128,,Dynamic Stack Usage Analysis} for details.)
+platforms. (See @ref{121,,Dynamic Stack Usage Analysis} for details.)
@geindex -v (gnatbind)
@@ -15716,7 +15693,7 @@ no arguments.
@end menu
@node Consistency-Checking Modes,Binder Error Message Control,,Switches for gnatbind
-@anchor{gnat_ugn/building_executable_programs_with_gnat consistency-checking-modes}@anchor{129}@anchor{gnat_ugn/building_executable_programs_with_gnat id34}@anchor{12a}
+@anchor{gnat_ugn/building_executable_programs_with_gnat consistency-checking-modes}@anchor{122}@anchor{gnat_ugn/building_executable_programs_with_gnat id35}@anchor{123}
@subsubsection Consistency-Checking Modes
@@ -15770,7 +15747,7 @@ case the checking against sources has already been performed by
@end table
@node Binder Error Message Control,Elaboration Control,Consistency-Checking Modes,Switches for gnatbind
-@anchor{gnat_ugn/building_executable_programs_with_gnat id35}@anchor{12b}@anchor{gnat_ugn/building_executable_programs_with_gnat binder-error-message-control}@anchor{12c}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id36}@anchor{124}@anchor{gnat_ugn/building_executable_programs_with_gnat binder-error-message-control}@anchor{125}
@subsubsection Binder Error Message Control
@@ -15880,21 +15857,59 @@ with extreme care.
@end table
@node Elaboration Control,Output Control,Binder Error Message Control,Switches for gnatbind
-@anchor{gnat_ugn/building_executable_programs_with_gnat id36}@anchor{12d}@anchor{gnat_ugn/building_executable_programs_with_gnat elaboration-control}@anchor{12e}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id37}@anchor{126}@anchor{gnat_ugn/building_executable_programs_with_gnat elaboration-control}@anchor{127}
@subsubsection Elaboration Control
The following switches provide additional control over the elaboration
-order. For full details see @ref{11,,Elaboration Order Handling in GNAT}.
+order. For full details see @ref{f,,Elaboration Order Handling in GNAT}.
-@quotation
-
-@geindex -p (gnatbind)
-@end quotation
+@geindex -f (gnatbind)
@table @asis
+@item @code{-f@emph{elab-order}}
+
+Force elaboration order.
+
+@cite{elab-order} should be the name of a "forced elaboration order file", that
+is, a text file containing library item names, one per line. A name of the
+form "some.unit%s" or "some.unit (spec)" denotes the spec of Some.Unit. A
+name of the form "some.unit%b" or "some.unit (body)" denotes the body of
+Some.Unit. Each pair of lines is taken to mean that there is an elaboration
+dependence of the second line on the first. For example, if the file
+contains:
+
+@example
+this (spec)
+this (body)
+that (spec)
+that (body)
+@end example
+
+then the spec of This will be elaborated before the body of This, and the
+body of This will be elaborated before the spec of That, and the spec of That
+will be elaborated before the body of That. The first and last of these three
+dependences are already required by Ada rules, so this file is really just
+forcing the body of This to be elaborated before the spec of That.
+
+The given order must be consistent with Ada rules, or else @cite{gnatbind} will
+give elaboration cycle errors. For example, if you say x (body) should be
+elaborated before x (spec), there will be a cycle, because Ada rules require
+x (spec) to be elaborated before x (body); you can't have the spec and body
+both elaborated before each other.
+
+If you later add "with That;" to the body of This, there will be a cycle, in
+which case you should erase either "this (body)" or "that (spec)" from the
+above forced elaboration order file.
+
+Blank lines and Ada-style comments are ignored. Unit names that do not exist
+in the program are ignored. Units in the GNAT predefined library are also
+ignored.
+
+@geindex -p (gnatbind)
+
@item @code{-p}
Normally the binder attempts to choose an elaboration order that is
@@ -15919,7 +15934,7 @@ production use; it is more for debugging/experimental use.
@end table
@node Output Control,Dynamic Allocation Control,Elaboration Control,Switches for gnatbind
-@anchor{gnat_ugn/building_executable_programs_with_gnat output-control}@anchor{12f}@anchor{gnat_ugn/building_executable_programs_with_gnat id37}@anchor{130}
+@anchor{gnat_ugn/building_executable_programs_with_gnat output-control}@anchor{128}@anchor{gnat_ugn/building_executable_programs_with_gnat id38}@anchor{129}
@subsubsection Output Control
@@ -16000,7 +16015,7 @@ be used to improve code generation in some cases.
@end table
@node Dynamic Allocation Control,Binding with Non-Ada Main Programs,Output Control,Switches for gnatbind
-@anchor{gnat_ugn/building_executable_programs_with_gnat dynamic-allocation-control}@anchor{127}@anchor{gnat_ugn/building_executable_programs_with_gnat id38}@anchor{131}
+@anchor{gnat_ugn/building_executable_programs_with_gnat dynamic-allocation-control}@anchor{120}@anchor{gnat_ugn/building_executable_programs_with_gnat id39}@anchor{12a}
@subsubsection Dynamic Allocation Control
@@ -16026,7 +16041,7 @@ unless explicitly overridden by a @cite{'Size} clause on the access type.
These switches are only effective on VMS platforms.
@node Binding with Non-Ada Main Programs,Binding Programs with No Main Subprogram,Dynamic Allocation Control,Switches for gnatbind
-@anchor{gnat_ugn/building_executable_programs_with_gnat binding-with-non-ada-main-programs}@anchor{ba}@anchor{gnat_ugn/building_executable_programs_with_gnat id39}@anchor{132}
+@anchor{gnat_ugn/building_executable_programs_with_gnat binding-with-non-ada-main-programs}@anchor{b4}@anchor{gnat_ugn/building_executable_programs_with_gnat id40}@anchor{12b}
@subsubsection Binding with Non-Ada Main Programs
@@ -16035,7 +16050,7 @@ program is in Ada, and that the task of the binder is to generate a
corresponding function @cite{main} that invokes this Ada main
program. GNAT also supports the building of executable programs where
the main program is not in Ada, but some of the called routines are
-written in Ada and compiled using GNAT (@ref{46,,Mixed Language Programming}).
+written in Ada and compiled using GNAT (@ref{44,,Mixed Language Programming}).
The following switch is used in this situation:
@quotation
@@ -16122,7 +16137,7 @@ side effect is that this could be the wrong mode for the foreign code
where floating point computation could be broken after this call.
@node Binding Programs with No Main Subprogram,,Binding with Non-Ada Main Programs,Switches for gnatbind
-@anchor{gnat_ugn/building_executable_programs_with_gnat binding-programs-with-no-main-subprogram}@anchor{133}@anchor{gnat_ugn/building_executable_programs_with_gnat id40}@anchor{134}
+@anchor{gnat_ugn/building_executable_programs_with_gnat binding-programs-with-no-main-subprogram}@anchor{12c}@anchor{gnat_ugn/building_executable_programs_with_gnat id41}@anchor{12d}
@subsubsection Binding Programs with No Main Subprogram
@@ -16153,7 +16168,7 @@ the binder switch
@end table
@node Command-Line Access,Search Paths for gnatbind,Switches for gnatbind,Binding with gnatbind
-@anchor{gnat_ugn/building_executable_programs_with_gnat id41}@anchor{135}@anchor{gnat_ugn/building_executable_programs_with_gnat command-line-access}@anchor{136}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id42}@anchor{12e}@anchor{gnat_ugn/building_executable_programs_with_gnat command-line-access}@anchor{12f}
@subsection Command-Line Access
@@ -16183,7 +16198,7 @@ required, your main program must set @cite{gnat_argc} and
it.
@node Search Paths for gnatbind,Examples of gnatbind Usage,Command-Line Access,Binding with gnatbind
-@anchor{gnat_ugn/building_executable_programs_with_gnat search-paths-for-gnatbind}@anchor{91}@anchor{gnat_ugn/building_executable_programs_with_gnat id42}@anchor{137}
+@anchor{gnat_ugn/building_executable_programs_with_gnat search-paths-for-gnatbind}@anchor{8c}@anchor{gnat_ugn/building_executable_programs_with_gnat id43}@anchor{130}
@subsection Search Paths for @cite{gnatbind}
@@ -16191,7 +16206,7 @@ The binder takes the name of an ALI file as its argument and needs to
locate source files as well as other ALI files to verify object consistency.
For source files, it follows exactly the same search rules as @emph{gcc}
-(see @ref{8e,,Search Paths and the Run-Time Library (RTL)}). For ALI files the
+(see @ref{89,,Search Paths and the Run-Time Library (RTL)}). For ALI files the
directories searched are:
@@ -16240,7 +16255,7 @@ of GNAT).
The content of the @code{ada_object_path} file which is part of the GNAT
installation tree and is used to store standard libraries such as the
GNAT Run Time Library (RTL) unless the switch @emph{-nostdlib} is
-specified. See @ref{8b,,Installing a library}
+specified. See @ref{87,,Installing a library}
@end itemize
@geindex -I (gnatbind)
@@ -16287,7 +16302,7 @@ in compiling sources from multiple directories. This can make
development environments much more flexible.
@node Examples of gnatbind Usage,,Search Paths for gnatbind,Binding with gnatbind
-@anchor{gnat_ugn/building_executable_programs_with_gnat examples-of-gnatbind-usage}@anchor{138}@anchor{gnat_ugn/building_executable_programs_with_gnat id43}@anchor{139}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id44}@anchor{131}@anchor{gnat_ugn/building_executable_programs_with_gnat examples-of-gnatbind-usage}@anchor{132}
@subsection Examples of @cite{gnatbind} Usage
@@ -16316,7 +16331,7 @@ since gnatlink will not be able to find the generated file.
@end quotation
@node Linking with gnatlink,Using the GNU make Utility,Binding with gnatbind,Building Executable Programs with GNAT
-@anchor{gnat_ugn/building_executable_programs_with_gnat id44}@anchor{13a}@anchor{gnat_ugn/building_executable_programs_with_gnat linking-with-gnatlink}@anchor{20}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id45}@anchor{133}@anchor{gnat_ugn/building_executable_programs_with_gnat linking-with-gnatlink}@anchor{1e}
@section Linking with @emph{gnatlink}
@@ -16331,7 +16346,7 @@ references for the Ada part of a program. It uses the binder file
generated by the @emph{gnatbind} to determine this list.
Note: to invoke @cite{gnatlink} with a project file, use the @cite{gnat}
-driver (see @ref{122,,The GNAT Driver and Project Files}).
+driver (see @emph{The_GNAT_Driver_and_Project_Files}).
@menu
* Running gnatlink::
@@ -16340,7 +16355,7 @@ driver (see @ref{122,,The GNAT Driver and Project Files}).
@end menu
@node Running gnatlink,Switches for gnatlink,,Linking with gnatlink
-@anchor{gnat_ugn/building_executable_programs_with_gnat id45}@anchor{13b}@anchor{gnat_ugn/building_executable_programs_with_gnat running-gnatlink}@anchor{13c}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id46}@anchor{134}@anchor{gnat_ugn/building_executable_programs_with_gnat running-gnatlink}@anchor{135}
@subsection Running @emph{gnatlink}
@@ -16399,8 +16414,8 @@ $ gnatlink my_prog -Wl,-Map,MAPFILE
Using @cite{linker options} it is possible to set the program stack and
heap size.
-See @ref{13d,,Setting Stack Size from gnatlink} and
-@ref{13e,,Setting Heap Size from gnatlink}.
+See @ref{136,,Setting Stack Size from gnatlink} and
+@ref{137,,Setting Heap Size from gnatlink}.
@emph{gnatlink} determines the list of objects required by the Ada
program and prepends them to the list of objects passed to the linker.
@@ -16409,7 +16424,7 @@ program and prepends them to the list of objects passed to the linker.
presented to the linker.
@node Switches for gnatlink,,Running gnatlink,Linking with gnatlink
-@anchor{gnat_ugn/building_executable_programs_with_gnat id46}@anchor{13f}@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gnatlink}@anchor{140}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id47}@anchor{138}@anchor{gnat_ugn/building_executable_programs_with_gnat switches-for-gnatlink}@anchor{139}
@subsection Switches for @emph{gnatlink}
@@ -16616,7 +16631,7 @@ switch.
@end table
@node Using the GNU make Utility,,Linking with gnatlink,Building Executable Programs with GNAT
-@anchor{gnat_ugn/building_executable_programs_with_gnat id47}@anchor{141}@anchor{gnat_ugn/building_executable_programs_with_gnat using-the-gnu-make-utility}@anchor{21}
+@anchor{gnat_ugn/building_executable_programs_with_gnat using-the-gnu-make-utility}@anchor{1f}@anchor{gnat_ugn/building_executable_programs_with_gnat id48}@anchor{13a}
@section Using the GNU @cite{make} Utility
@@ -16625,7 +16640,7 @@ switch.
This chapter offers some examples of makefiles that solve specific
problems. It does not explain how to write a makefile, nor does it try to replace the
-@emph{gnatmake} utility (@ref{1d,,Building with gnatmake}).
+@emph{gnatmake} utility (@ref{1b,,Building with gnatmake}).
All the examples in this section are specific to the GNU version of
make. Although @emph{make} is a standard utility, and the basic language
@@ -16641,7 +16656,7 @@ is the same, these examples use some advanced features found only in
@end menu
@node Using gnatmake in a Makefile,Automatically Creating a List of Directories,,Using the GNU make Utility
-@anchor{gnat_ugn/building_executable_programs_with_gnat using-gnatmake-in-a-makefile}@anchor{142}@anchor{gnat_ugn/building_executable_programs_with_gnat id48}@anchor{143}
+@anchor{gnat_ugn/building_executable_programs_with_gnat using-gnatmake-in-a-makefile}@anchor{13b}@anchor{gnat_ugn/building_executable_programs_with_gnat id49}@anchor{13c}
@subsection Using gnatmake in a Makefile
@@ -16660,7 +16675,7 @@ the appropriate directories.
Note that you should also read the example on how to automatically
create the list of directories
-(@ref{144,,Automatically Creating a List of Directories})
+(@ref{13d,,Automatically Creating a List of Directories})
which might help you in case your project has a lot of subdirectories.
@example
@@ -16740,7 +16755,7 @@ clean::
@end example
@node Automatically Creating a List of Directories,Generating the Command Line Switches,Using gnatmake in a Makefile,Using the GNU make Utility
-@anchor{gnat_ugn/building_executable_programs_with_gnat automatically-creating-a-list-of-directories}@anchor{144}@anchor{gnat_ugn/building_executable_programs_with_gnat id49}@anchor{145}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id50}@anchor{13e}@anchor{gnat_ugn/building_executable_programs_with_gnat automatically-creating-a-list-of-directories}@anchor{13d}
@subsection Automatically Creating a List of Directories
@@ -16813,12 +16828,12 @@ DIRS := $@{shell find $@{ROOT_DIRECTORY@} -type d -print@}
@end example
@node Generating the Command Line Switches,Overcoming Command Line Length Limits,Automatically Creating a List of Directories,Using the GNU make Utility
-@anchor{gnat_ugn/building_executable_programs_with_gnat id50}@anchor{146}@anchor{gnat_ugn/building_executable_programs_with_gnat generating-the-command-line-switches}@anchor{147}
+@anchor{gnat_ugn/building_executable_programs_with_gnat id51}@anchor{13f}@anchor{gnat_ugn/building_executable_programs_with_gnat generating-the-command-line-switches}@anchor{140}
@subsection Generating the Command Line Switches
Once you have created the list of directories as explained in the
-previous section (@ref{144,,Automatically Creating a List of Directories}),
+previous section (@ref{13d,,Automatically Creating a List of Directories}),
you can easily generate the command line arguments to pass to gnatmake.
For the sake of completeness, this example assumes that the source path
@@ -16839,7 +16854,7 @@ all:
@end example
@node Overcoming Command Line Length Limits,,Generating the Command Line Switches,Using the GNU make Utility
-@anchor{gnat_ugn/building_executable_programs_with_gnat overcoming-command-line-length-limits}@anchor{148}@anchor{gnat_ugn/building_executable_programs_with_gnat id51}@anchor{149}
+@anchor{gnat_ugn/building_executable_programs_with_gnat overcoming-command-line-length-limits}@anchor{141}@anchor{gnat_ugn/building_executable_programs_with_gnat id52}@anchor{142}
@subsection Overcoming Command Line Length Limits
@@ -16854,7 +16869,7 @@ even none on most systems).
It assumes that you have created a list of directories in your Makefile,
using one of the methods presented in
-@ref{144,,Automatically Creating a List of Directories}.
+@ref{13d,,Automatically Creating a List of Directories}.
For the sake of completeness, we assume that the object
path (where the ALI files are found) is different from the sources patch.
@@ -16896,6390 +16911,8 @@ all:
gnatmake main_unit
@end example
-@c -- Example: A |withing| unit has a |with| clause, it |withs| a |withed| unit
-
-@node GNAT Project Manager,Tools Supporting Project Files,Building Executable Programs with GNAT,Top
-@anchor{gnat_ugn/gnat_project_manager doc}@anchor{14a}@anchor{gnat_ugn/gnat_project_manager gnat-project-manager}@anchor{b}@anchor{gnat_ugn/gnat_project_manager id1}@anchor{14b}
-@chapter GNAT Project Manager
-
-
-@menu
-* Introduction::
-* Building With Projects::
-* Organizing Projects into Subsystems::
-* Scenarios in Projects::
-* Library Projects::
-* Project Extension::
-* Aggregate Projects::
-* Aggregate Library Projects::
-* Project File Reference::
-
-@end menu
-
-@node Introduction,Building With Projects,,GNAT Project Manager
-@anchor{gnat_ugn/gnat_project_manager introduction}@anchor{14c}@anchor{gnat_ugn/gnat_project_manager gnat-project-manager-introduction}@anchor{14d}
-@section Introduction
-
-
-This chapter describes GNAT's @emph{Project Manager}, a facility that allows
-you to manage complex builds involving a number of source files, directories,
-and options for different system configurations. In particular,
-project files allow you to specify:
-
-
-@itemize *
-
-@item
-The directory or set of directories containing the source files, and/or the
-names of the specific source files themselves
-
-@item
-The directory in which the compiler's output
-(@code{ALI} files, object files, tree files, etc.) is to be placed
-
-@item
-The directory in which the executable programs are to be placed
-
-@item
-Switch settings for any of the project-enabled tools;
-you can apply these settings either globally or to individual compilation units.
-
-@item
-The source files containing the main subprogram(s) to be built
-
-@item
-The source programming language(s)
-
-@item
-Source file naming conventions; you can specify these either globally or for
-individual compilation units (see @ref{14e,,Naming Schemes}).
-
-@item
-Change any of the above settings depending on external values, thus enabling
-the reuse of the projects in various @strong{scenarios} (see @ref{14f,,Scenarios in Projects}).
-
-@item
-Automatically build libraries as part of the build process
-(see @ref{8a,,Library Projects}).
-@end itemize
-
-Project files are written in a syntax close to that of Ada, using familiar
-notions such as packages, context clauses, declarations, default values,
-assignments, and inheritance (see @ref{150,,Project File Reference}).
-
-Project files can be built hierarchically from other project files, simplifying
-complex system integration and project reuse (see @ref{151,,Organizing Projects into Subsystems}).
-
-
-@itemize *
-
-@item
-One project can import other projects containing needed source files.
-More generally, the Project Manager lets you structure large development
-efforts into hierarchical subsystems, where build decisions are delegated
-to the subsystem level, and thus different compilation environments
-(switch settings) used for different subsystems.
-
-@item
-You can organize GNAT projects in a hierarchy: a child project
-can extend a parent project, inheriting the parent's source files and
-optionally overriding any of them with alternative versions
-(see @ref{152,,Project Extension}).
-@end itemize
-
-Several tools support project files, generally in addition to specifying
-the information on the command line itself). They share common switches
-to control the loading of the project (in particular
-@code{-P@emph{projectfile}} and
-@code{-X@emph{vbl}=@emph{value}}).
-
-The Project Manager supports a wide range of development strategies,
-for systems of all sizes. Here are some typical practices that are
-easily handled:
-
-
-@itemize *
-
-@item
-Using a common set of source files and generating object files in different
-directories via different switch settings. It can be used for instance, for
-generating separate sets of object files for debugging and for production.
-
-@item
-Using a mostly-shared set of source files with different versions of
-some units or subunits. It can be used for instance, for grouping and hiding
-all OS dependencies in a small number of implementation units.
-@end itemize
-
-Project files can be used to achieve some of the effects of a source
-versioning system (for example, defining separate projects for
-the different sets of sources that comprise different releases) but the
-Project Manager is independent of any source configuration management tool
-that might be used by the developers.
-
-The various sections below introduce the different concepts related to
-projects. Each section starts with examples and use cases, and then goes into
-the details of related project file capabilities.
-
-@node Building With Projects,Organizing Projects into Subsystems,Introduction,GNAT Project Manager
-@anchor{gnat_ugn/gnat_project_manager building-with-projects}@anchor{153}@anchor{gnat_ugn/gnat_project_manager id2}@anchor{154}
-@section Building With Projects
-
-
-In its simplest form, a unique project is used to build a single executable.
-This section concentrates on such a simple setup. Later sections will extend
-this basic model to more complex setups.
-
-The following concepts are the foundation of project files, and will be further
-detailed later in this documentation. They are summarized here as a reference.
-
-
-@table @asis
-
-@item @strong{Project file}:
-
-A text file using an Ada-like syntax, generally using the @code{.gpr}
-extension. It defines build-related characteristics of an application.
-The characteristics include the list of sources, the location of those
-sources, the location for the generated object files, the name of
-the main program, and the options for the various tools involved in the
-build process.
-
-@item @strong{Project attribute}:
-
-A specific project characteristic is defined by an attribute clause. Its
-value is a string or a sequence of strings. All settings in a project
-are defined through a list of predefined attributes with precise
-semantics. See @ref{155,,Attributes}.
-
-@item @strong{Package in a project}:
-
-Global attributes are defined at the top level of a project.
-Attributes affecting specific tools are grouped in a
-package whose name is related to tool's function. The most common
-packages are @cite{Builder}, @cite{Compiler}, @cite{Binder},
-and @cite{Linker}. See @ref{156,,Packages}.
-
-@item @strong{Project variables}:
-
-In addition to attributes, a project can use variables to store intermediate
-values and avoid duplication in complex expressions. It can be initialized
-with a value coming from the environment.
-A frequent use of variables is to define scenarios.
-See @ref{157,,External Values}, @ref{14f,,Scenarios in Projects}, and @ref{158,,Variables}.
-
-@item @strong{Source files} and @strong{source directories}:
-
-A source file is associated with a language through a naming convention. For
-instance, @cite{foo.c} is typically the name of a C source file;
-@cite{bar.ads} or @cite{bar.1.ada} are two common naming conventions for a
-file containing an Ada spec. A compilation unit is often composed of a main
-source file and potentially several auxiliary ones, such as header files in C.
-The naming conventions can be user defined @ref{14e,,Naming Schemes}, and will
-drive the builder to call the appropriate compiler for the given source file.
-Source files are searched for in the source directories associated with the
-project through the @strong{Source_Dirs} attribute. By default, all the files (in
-these source directories) following the naming conventions associated with the
-declared languages are considered to be part of the project. It is also
-possible to limit the list of source files using the @strong{Source_Files} or
-@strong{Source_List_File} attributes. Note that those last two attributes only
-accept basenames with no directory information.
-
-@item @strong{Object files} and @strong{object directory}:
-
-An object file is an intermediate file produced by the compiler from a
-compilation unit. It is used by post-compilation tools to produce
-final executables or libraries. Object files produced in the context of
-a given project are stored in a single directory that can be specified by the
-@strong{Object_Dir} attribute. In order to store objects in
-two or more object directories, the system must be split into
-distinct subsystems with their own project file.
-@end table
-
-The following subsections introduce gradually all the attributes of interest
-for simple build needs. Here is the simple setup that will be used in the
-following examples.
-
-The Ada source files @code{pack.ads}, @code{pack.adb}, and @code{proc.adb} are in
-the @code{common/} directory. The file @code{proc.adb} contains an Ada main
-subprogram @cite{Proc} that @emph{with}s package @cite{Pack}. We want to compile
-these source files with the switch
-@emph{-O2}, and put the resulting files in
-the directory @code{obj/}.
-
-@example
-common/
- pack.ads
- pack.adb
- proc.adb
-common/obj/
- proc.ali, proc.o pack.ali, pack.o
-@end example
-
-Our project is to be called @emph{Build}. The name of the
-file is the name of the project (case-insensitive) with the
-@code{.gpr} extension, therefore the project file name is @code{build.gpr}. This
-is not mandatory, but a warning is issued when this convention is not followed.
-
-This is a very simple example, and as stated above, a single project
-file is enough for it. We will thus create a new file, that for now
-should contain the following code:
-
-@example
-project Build is
-end Build;
-@end example
-
-@menu
-* Source Files and Directories::
-* Duplicate Sources in Projects::
-* Object and Exec Directory::
-* Main Subprograms::
-* Tools Options in Project Files::
-* Compiling with Project Files::
-* Executable File Names::
-* Avoid Duplication With Variables::
-* Naming Schemes::
-* Installation::
-* Distributed support::
-
-@end menu
-
-@node Source Files and Directories,Duplicate Sources in Projects,,Building With Projects
-@anchor{gnat_ugn/gnat_project_manager id3}@anchor{159}@anchor{gnat_ugn/gnat_project_manager source-files-and-directories}@anchor{15a}
-@subsection Source Files and Directories
-
-
-When you create a new project, the first thing to describe is how to find the
-corresponding source files. These are the only settings that are needed by all
-the tools that will use this project (builder, compiler, binder and linker for
-the compilation, IDEs to edit the source files,...).
-
-@geindex Source directories (GNAT Project Manager)
-
-The first step is to declare the source directories, which are the directories
-to be searched to find source files. In the case of the example,
-the @code{common} directory is the only source directory.
-
-@geindex Source_Dirs (GNAT Project Manager)
-
-There are several ways of defining source directories:
-
-
-@itemize *
-
-@item
-When the attribute @strong{Source_Dirs} is not used, a project contains a
-single source directory which is the one where the project file itself
-resides. In our example, if @code{build.gpr} is placed in the @code{common}
-directory, the project has the needed implicit source directory.
-
-@item
-The attribute @strong{Source_Dirs} can be set to a list of path names, one
-for each of the source directories. Such paths can either be absolute
-names (for instance @code{"/usr/local/common/"} on UNIX), or relative to the
-directory in which the project file resides (for instance "." if
-@code{build.gpr} is inside @code{common/}, or "common" if it is one level up).
-Each of the source directories must exist and be readable.
-
-@geindex portability of path names (GNAT Project Manager)
-
-The syntax for directories is platform specific. For portability, however,
-the project manager will always properly translate UNIX-like path names to
-the native format of the specific platform. For instance, when the same
-project file is to be used both on Unix and Windows, "/" should be used as
-the directory separator rather than "\".
-
-@item
-The attribute @strong{Source_Dirs} can automatically include subdirectories
-using a special syntax inspired by some UNIX shells. If any of the paths in
-the list ends with "@code{**}", then that path and all its subdirectories
-(recursively) are included in the list of source directories. For instance,
-@code{**} and @code{./**} represent the complete directory tree rooted at
-the directory in which the project file resides.
-
-@geindex Source directories (GNAT Project Manager)
-
-@geindex Excluded_Source_Dirs (GNAT Project Manager)
-
-When using that construct, it can sometimes be convenient to also use the
-attribute @strong{Excluded_Source_Dirs}, which is also a list of paths. Each entry
-specifies a directory whose immediate content, not including subdirs, is to
-be excluded. It is also possible to exclude a complete directory subtree
-using the "**" notation.
-
-@geindex Ignore_Source_Sub_Dirs (GNAT Project Manager)
-
-It is often desirable to remove, from the source directories, directory
-subtrees rooted at some subdirectories. An example is the subdirectories
-created by a Version Control System such as Subversion that creates directory
-subtrees rooted at subdirectories ".svn". To do that, attribute
-@strong{Ignore_Source_Sub_Dirs} can be used. It specifies the list of simple
-file names for the roots of these undesirable directory subtrees.
-
-@example
-for Source_Dirs use ("./**");
-for Ignore_Source_Sub_Dirs use (".svn");
-@end example
-@end itemize
-
-When applied to the simple example, and because we generally prefer to have
-the project file at the toplevel directory rather than mixed with the sources,
-we will create the following file
-
-@example
-build.gpr
-project Build is
- for Source_Dirs use ("common"); -- <<<<
-end Build;
-@end example
-
-Once source directories have been specified, one may need to indicate
-source files of interest. By default, all source files present in the source
-directories are considered by the project manager. When this is not desired,
-it is possible to specify the list of sources to consider explicitly.
-In such a case, only source file base names are indicated and not
-their absolute or relative path names. The project manager is in charge of
-locating the specified source files in the specified source directories.
-
-
-@itemize *
-
-@item
-By default, the project manager searches for all source files of all
-specified languages in all the source directories.
-
-Since the project manager was initially developed for Ada environments, the
-default language is usually Ada and the above project file is complete: it
-defines without ambiguity the sources composing the project: that is to say,
-all the sources in subdirectory "common" for the default language (Ada) using
-the default naming convention.
-
-@geindex Languages (GNAT Project Manager)
-
-However, when compiling a multi-language application, or a pure C
-application, the project manager must be told which languages are of
-interest, which is done by setting the @strong{Languages} attribute to a list of
-strings, each of which is the name of a language.
-
-@geindex Naming scheme (GNAT Project Manager)
-
-Even when using only Ada, the default naming might not be suitable. Indeed,
-how does the project manager recognizes an "Ada file" from any other
-file? Project files can describe the naming scheme used for source files,
-and override the default (see @ref{14e,,Naming Schemes}). The default is the
-standard GNAT extension (@code{.adb} for bodies and @code{.ads} for
-specs), which is what is used in our example, explaining why no naming scheme
-is explicitly specified.
-See @ref{14e,,Naming Schemes}.
-
-@geindex Source_Files (GNAT Project Manager)
-
-@item
-@cite{Source_Files}.
-In some cases, source directories might contain files that should not be
-included in a project. One can specify the explicit list of file names to
-be considered through the @strong{Source_Files} attribute.
-When this attribute is defined, instead of looking at every file in the
-source directories, the project manager takes only those names into
-consideration reports errors if they cannot be found in the source
-directories or does not correspond to the naming scheme.
-
-@item
-For various reasons, it is sometimes useful to have a project with no
-sources (most of the time because the attributes defined in the project
-file will be reused in other projects, as explained in
-@ref{151,,Organizing Projects into Subsystems}. To do this, the attribute
-@emph{Source_Files} is set to the empty list, i.e. @cite{()}. Alternatively,
-@emph{Source_Dirs} can be set to the empty list, with the same
-result.
-
-@geindex Source_List_File (GNAT Project Manager)
-
-@item
-@cite{Source_List_File}.
-If there is a great number of files, it might be more convenient to use
-the attribute @strong{Source_List_File}, which specifies the full path of a file.
-This file must contain a list of source file names (one per line, no
-directory information) that are searched as if they had been defined
-through @emph{Source_Files}. Such a file can easily be created through
-external tools.
-
-A warning is issued if both attributes @cite{Source_Files} and
-@cite{Source_List_File} are given explicit values. In this case, the
-attribute @cite{Source_Files} prevails.
-
-@geindex Excluded_Source_Files (GNAT Project Manager)
-
-@geindex Locally_Removed_Files (GNAT Project Manager)
-
-@geindex Excluded_Source_List_File (GNAT Project Manager)
-
-@item
-@cite{Excluded_Source_Files}.
-Specifying an explicit list of files is not always convenient.It might be
-more convenient to use the default search rules with specific exceptions.
-This can be done thanks to the attribute @strong{Excluded_Source_Files}
-(or its synonym @strong{Locally_Removed_Files}).
-Its value is the list of file names that should not be taken into account.
-This attribute is often used when extending a project,
-see @ref{152,,Project Extension}. A similar attribute
-@strong{Excluded_Source_List_File} plays the same
-role but takes the name of file containing file names similarly to
-@cite{Source_List_File}.
-@end itemize
-
-In most simple cases, such as the above example, the default source file search
-behavior provides the expected result, and we do not need to add anything after
-setting @cite{Source_Dirs}. The project manager automatically finds
-@code{pack.ads}, @code{pack.adb}, and @code{proc.adb} as source files of the
-project.
-
-Note that by default a warning is issued when a project has no sources attached
-to it and this is not explicitly indicated in the project file.
-
-@node Duplicate Sources in Projects,Object and Exec Directory,Source Files and Directories,Building With Projects
-@anchor{gnat_ugn/gnat_project_manager duplicate-sources-in-projects}@anchor{15b}@anchor{gnat_ugn/gnat_project_manager id4}@anchor{15c}
-@subsection Duplicate Sources in Projects
-
-
-If the order of the source directories is known statically, that is if
-@cite{"/**"} is not used in the string list @cite{Source_Dirs}, then there may
-be several files with the same name sitting in different directories of the
-project. In this case, only the file in the first directory is considered as a
-source of the project and the others are hidden. If @cite{"/**"} is used in the
-string list @cite{Source_Dirs}, it is an error to have several files with the
-same name in the same directory @cite{"/**"} subtree, since there would be an
-ambiguity as to which one should be used. However, two files with the same name
-may exist in two single directories or directory subtrees. In this case, the
-one in the first directory or directory subtree is a source of the project.
-
-If there are two sources in different directories of the same @cite{"/**"}
-subtree, one way to resolve the problem is to exclude the directory of the
-file that should not be used as a source of the project.
-
-@node Object and Exec Directory,Main Subprograms,Duplicate Sources in Projects,Building With Projects
-@anchor{gnat_ugn/gnat_project_manager object-and-exec-directory}@anchor{15d}@anchor{gnat_ugn/gnat_project_manager id5}@anchor{15e}
-@subsection Object and Exec Directory
-
-
-The next step when writing a project is to indicate where the compiler should
-put the object files. In fact, the compiler and other tools might create
-several different kind of files (for GNAT, there is the object file and the ALI
-file for instance). One of the important concepts in projects is that most
-tools may consider source directories as read-only and do not attempt to create
-new or temporary files there. Instead, all files are created in the object
-directory. It is of course not true for project-aware IDEs, whose purpose it is
-to create the source files.
-
-@geindex Object_Dir (GNAT Project Manager)
-
-The object directory is specified through the @strong{Object_Dir} attribute.
-Its value is the path to the object directory, either absolute or
-relative to the directory containing the project file. This
-directory must already exist and be readable and writable, although
-some tools have a switch to create the directory if needed (See
-the switch @cite{-p} for @emph{gprbuild}).
-
-If the attribute @cite{Object_Dir} is not specified, it defaults to
-the project directory, that is the directory containing the project file.
-
-For our example, we can specify the object dir in this way:
-
-@example
-project Build is
- for Source_Dirs use ("common");
- for Object_Dir use "obj"; -- <<<<
-end Build;
-@end example
-
-As mentioned earlier, there is a single object directory per project. As a
-result, if you have an existing system where the object files are spread across
-several directories, you can either move all of them into the same directory if
-you want to build it with a single project file, or study the section on
-subsystems (see @ref{151,,Organizing Projects into Subsystems}) to see how each
-separate object directory can be associated with one of the subsystems
-constituting the application.
-
-When the @emph{linker} is called, it usually creates an executable. By
-default, this executable is placed in the object directory of the project. It
-might be convenient to store it in its own directory.
-
-@geindex Exec_Dir (GNAT Project Manager)
-
-This can be done through the @cite{Exec_Dir} attribute, which, like
-@emph{Object_Dir} contains a single absolute or relative path and must point to
-an existing and writable directory, unless you ask the tool to create it on
-your behalf. When not specified, It defaults to the object directory and
-therefore to the project file's directory if neither @emph{Object_Dir} nor
-@emph{Exec_Dir} was specified.
-
-In the case of the example, let's place the executable in the root
-of the hierarchy, ie the same directory as @code{build.gpr}. Hence
-the project file is now
-
-@example
-project Build is
- for Source_Dirs use ("common");
- for Object_Dir use "obj";
- for Exec_Dir use "."; -- <<<<
-end Build;
-@end example
-
-@node Main Subprograms,Tools Options in Project Files,Object and Exec Directory,Building With Projects
-@anchor{gnat_ugn/gnat_project_manager id6}@anchor{15f}@anchor{gnat_ugn/gnat_project_manager main-subprograms}@anchor{160}
-@subsection Main Subprograms
-
-
-In the previous section, executables were mentioned. The project manager needs
-to be taught what they are. In a project file, an executable is indicated by
-pointing to the source file of a main subprogram. In C this is the file that
-contains the @cite{main} function, and in Ada the file that contains the main
-unit.
-
-There can be any number of such main files within a given project, and thus
-several executables can be built in the context of a single project file. Of
-course, one given executable might not (and in fact will not) need all the
-source files referenced by the project. As opposed to other build environments
-such as @emph{makefile}, one does not need to specify the list of
-dependencies of each executable, the project-aware builder knows enough of the
-semantics of the languages to build and link only the necessary elements.
-
-@geindex Main (GNAT Project Manager)
-
-The list of main files is specified via the @strong{Main} attribute. It contains
-a list of file names (no directories). If a project defines this
-attribute, it is not necessary to identify main files on the
-command line when invoking a builder, and editors like
-@emph{GPS} will be able to create extra menus to spawn or debug the
-corresponding executables.
-
-@example
-project Build is
- for Source_Dirs use ("common");
- for Object_Dir use "obj";
- for Exec_Dir use ".";
- for Main use ("proc.adb"); -- <<<<
-end Build;
-@end example
-
-If this attribute is defined in the project, then spawning the builder
-with a command such as
-
-@example
-gprbuild -Pbuild
-@end example
-
-automatically builds all the executables corresponding to the files
-listed in the @emph{Main} attribute. It is possible to specify one
-or more executables on the command line to build a subset of them.
-
-@node Tools Options in Project Files,Compiling with Project Files,Main Subprograms,Building With Projects
-@anchor{gnat_ugn/gnat_project_manager tools-options-in-project-files}@anchor{161}@anchor{gnat_ugn/gnat_project_manager id7}@anchor{162}
-@subsection Tools Options in Project Files
-
-
-We now have a project file that fully describes our environment, and can be
-used to build the application with a simple @emph{gprbuild} command as seen
-in the previous section. In fact, the empty project we showed immediately at
-the beginning (with no attribute at all) could already fulfill that need if it
-was put in the @code{common} directory.
-
-Of course, we might want more control. This section shows you how to specify
-the compilation switches that the various tools involved in the building of the
-executable should use.
-
-@geindex command line length (GNAT Project Manager)
-
-Since source names and locations are described in the project file, it is not
-necessary to use switches on the command line for this purpose (switches such
-as -I for gcc). This removes a major source of command line length overflow.
-Clearly, the builders will have to communicate this information one way or
-another to the underlying compilers and tools they call but they usually use
-response files for this and thus are not subject to command line overflows.
-
-Several tools participate to the creation of an executable: the compiler
-produces object files from the source files; the binder (in the Ada case)
-creates a "source" file that takes care, among other things, of elaboration
-issues and global variable initialization; and the linker gathers everything
-into a single executable that users can execute. All these tools are known to
-the project manager and will be called with user defined switches from the
-project files. However, we need to introduce a new project file concept to
-express the switches to be used for any of the tools involved in the build.
-
-@geindex project file packages (GNAT Project Manager)
-
-A project file is subdivided into zero or more @strong{packages}, each of which
-contains the attributes specific to one tool (or one set of tools). Project
-files use an Ada-like syntax for packages. Package names permitted in project
-files are restricted to a predefined set (see @ref{156,,Packages}), and the contents
-of packages are limited to a small set of constructs and attributes
-(see @ref{155,,Attributes}).
-
-Our example project file can be extended with the following empty packages. At
-this stage, they could all be omitted since they are empty, but they show which
-packages would be involved in the build process.
-
-@example
-project Build is
- for Source_Dirs use ("common");
- for Object_Dir use "obj";
- for Exec_Dir use ".";
- for Main use ("proc.adb");
-
- package Builder is --<<< for gprbuild
- end Builder;
-
- package Compiler is --<<< for the compiler
- end Compiler;
-
- package Binder is --<<< for the binder
- end Binder;
-
- package Linker is --<<< for the linker
- end Linker;
-end Build;
-@end example
-
-Let's first examine the compiler switches. As stated in the initial description
-of the example, we want to compile all files with @emph{-O2}. This is a
-compiler switch, although it is usual, on the command line, to pass it to the
-builder which then passes it to the compiler. It is recommended to use directly
-the right package, which will make the setup easier to understand for other
-people.
-
-Several attributes can be used to specify the switches:
-
-@geindex Default_Switches (GNAT Project Manager)
-
-@strong{Default_Switches}:
-
-@quotation
-
-This is the first mention in this manual of an @strong{indexed attribute}. When
-this attribute is defined, one must supply an @emph{index} in the form of a
-literal string.
-In the case of @emph{Default_Switches}, the index is the name of the
-language to which the switches apply (since a different compiler will
-likely be used for each language, and each compiler has its own set of
-switches). The value of the attribute is a list of switches.
-
-In this example, we want to compile all Ada source files with the switch
-@emph{-O2}, and the resulting project file is as follows
-(only the @cite{Compiler} package is shown):
-
-@example
-package Compiler is
- for Default_Switches ("Ada") use ("-O2");
-end Compiler;
-@end example
-@end quotation
-
-@geindex Switches (GNAT Project Manager)
-
-@strong{Switches}:
-
-@quotation
-
-In some cases, we might want to use specific switches
-for one or more files. For instance, compiling @code{proc.adb} might not be
-possible at high level of optimization because of a compiler issue.
-In such a case, the @emph{Switches}
-attribute (indexed on the file name) can be used and will override the
-switches defined by @emph{Default_Switches}. Our project file would
-become:
-
-@example
-package Compiler is
- for Default_Switches ("Ada")
- use ("-O2");
- for Switches ("proc.adb")
- use ("-O0");
-end Compiler;
-@end example
-
-@cite{Switches} may take a pattern as an index, such as in:
-
-@example
-package Compiler is
- for Default_Switches ("Ada")
- use ("-O2");
- for Switches ("pkg*")
- use ("-O0");
-end Compiler;
-@end example
-
-Sources @code{pkg.adb} and @code{pkg-child.adb} would be compiled with -O0,
-not -O2.
-
-@cite{Switches} can also be given a language name as index instead of a file
-name in which case it has the same semantics as @emph{Default_Switches}.
-However, indexes with wild cards are never valid for language name.
-@end quotation
-
-@geindex Local_Configuration_Pragmas (GNAT Project Manager)
-
-@strong{Local_Configuration_Pragmas}:
-
-@quotation
-
-This attribute may specify the path
-of a file containing configuration pragmas for use by the Ada compiler,
-such as @cite{pragma Restrictions (No_Tasking)}. These pragmas will be
-used for all the sources of the project.
-@end quotation
-
-The switches for the other tools are defined in a similar manner through the
-@strong{Default_Switches} and @strong{Switches} attributes, respectively in the
-@emph{Builder} package (for @emph{gprbuild}),
-the @emph{Binder} package (binding Ada executables) and the @emph{Linker}
-package (for linking executables).
-
-@node Compiling with Project Files,Executable File Names,Tools Options in Project Files,Building With Projects
-@anchor{gnat_ugn/gnat_project_manager compiling-with-project-files}@anchor{163}@anchor{gnat_ugn/gnat_project_manager id8}@anchor{164}
-@subsection Compiling with Project Files
-
-
-Now that our project files are written, let's build our executable.
-Here is the command we would use from the command line:
-
-@example
-gprbuild -Pbuild
-@end example
-
-This will automatically build the executables specified through the
-@emph{Main} attribute: for each, it will compile or recompile the
-sources for which the object file does not exist or is not up-to-date; it
-will then run the binder; and finally run the linker to create the
-executable itself.
-
-The @emph{gprbuild} builder, can automatically manage C files the
-same way: create the file @code{utils.c} in the @code{common} directory,
-set the attribute @emph{Languages} to @cite{"(Ada@comma{} C)"}, and re-run
-
-@example
-gprbuild -Pbuild
-@end example
-
-Gprbuild knows how to recompile the C files and will
-recompile them only if one of their dependencies has changed. No direct
-indication on how to build the various elements is given in the
-project file, which describes the project properties rather than a
-set of actions to be executed. Here is the invocation of
-@emph{gprbuild} when building a multi-language program:
-
-@example
-$ gprbuild -Pbuild
-gcc -c proc.adb
-gcc -c pack.adb
-gcc -c utils.c
-gprbind proc
-...
-gcc proc.o -o proc
-@end example
-
-Notice the three steps described earlier:
-
-
-@itemize *
-
-@item
-The first three gcc commands correspond to the compilation phase.
-
-@item
-The gprbind command corresponds to the post-compilation phase.
-
-@item
-The last gcc command corresponds to the final link.
-@end itemize
-
-@geindex -v option (for GPRbuild)
-
-The default output of GPRbuild's execution is kept reasonably simple and easy
-to understand. In particular, some of the less frequently used commands are not
-shown, and some parameters are abbreviated. So it is not possible to rerun the
-effect of the @emph{gprbuild} command by cut-and-pasting its output.
-GPRbuild's option @cite{-v} provides a much more verbose output which includes,
-among other information, more complete compilation, post-compilation and link
-commands.
-
-@node Executable File Names,Avoid Duplication With Variables,Compiling with Project Files,Building With Projects
-@anchor{gnat_ugn/gnat_project_manager executable-file-names}@anchor{165}@anchor{gnat_ugn/gnat_project_manager id9}@anchor{166}
-@subsection Executable File Names
-
-
-@geindex Executable (GNAT Project Manager)
-
-By default, the executable name corresponding to a main file is
-computed from the main source file name. Through the attribute
-@strong{Builder.Executable}, it is possible to change this default.
-
-For instance, instead of building @emph{proc} (or @emph{proc.exe}
-on Windows), we could configure our project file to build "proc1"
-(resp proc1.exe) with the following addition:
-
-@example
-project Build is
- ... -- same as before
- package Builder is
- for Executable ("proc.adb") use "proc1";
- end Builder
-end Build;
-@end example
-
-@geindex Executable_Suffix (GNAT Project Manager)
-
-Attribute @strong{Executable_Suffix}, when specified, may change the suffix
-of the executable files, when no attribute @cite{Executable} applies:
-its value replaces the platform-specific executable suffix.
-The default executable suffix is empty on UNIX and ".exe" on Windows.
-
-It is also possible to change the name of the produced executable by using the
-command line switch @emph{-o}. When several mains are defined in the project,
-it is not possible to use the @emph{-o} switch and the only way to change the
-names of the executable is provided by Attributes @cite{Executable} and
-@cite{Executable_Suffix}.
-
-@node Avoid Duplication With Variables,Naming Schemes,Executable File Names,Building With Projects
-@anchor{gnat_ugn/gnat_project_manager id10}@anchor{167}@anchor{gnat_ugn/gnat_project_manager avoid-duplication-with-variables}@anchor{168}
-@subsection Avoid Duplication With Variables
-
-
-To illustrate some other project capabilities, here is a slightly more complex
-project using similar sources and a main program in C:
-
-@example
-project C_Main is
- for Languages use ("Ada", "C");
- for Source_Dirs use ("common");
- for Object_Dir use "obj";
- for Main use ("main.c");
- package Compiler is
- C_Switches := ("-pedantic");
- for Default_Switches ("C") use C_Switches;
- for Default_Switches ("Ada") use ("-gnaty");
- for Switches ("main.c") use C_Switches & ("-g");
- end Compiler;
-end C_Main;
-@end example
-
-This project has many similarities with the previous one.
-As expected, its @cite{Main} attribute now refers to a C source.
-The attribute @emph{Exec_Dir} is now omitted, thus the resulting
-executable will be put in the directory @code{obj}.
-
-The most noticeable difference is the use of a variable in the
-@emph{Compiler} package to store settings used in several attributes.
-This avoids text duplication, and eases maintenance (a single place to
-modify if we want to add new switches for C files). We will revisit
-the use of variables in the context of scenarios (see @ref{14f,,Scenarios in Projects}).
-
-In this example, we see how the file @code{main.c} can be compiled with
-the switches used for all the other C files, plus @emph{-g}.
-In this specific situation the use of a variable could have been
-replaced by a reference to the @cite{Default_Switches} attribute:
-
-@example
-for Switches ("c_main.c") use Compiler'Default_Switches ("C") & ("-g");
-@end example
-
-Note the tick (@emph{'}) used to refer to attributes defined in a package.
-
-Here is the output of the GPRbuild command using this project:
-
-@example
-$ gprbuild -Pc_main
-gcc -c -pedantic -g main.c
-gcc -c -gnaty proc.adb
-gcc -c -gnaty pack.adb
-gcc -c -pedantic utils.c
-gprbind main.bexch
-...
-gcc main.o -o main
-@end example
-
-The default switches for Ada sources,
-the default switches for C sources (in the compilation of @code{lib.c}),
-and the specific switches for @code{main.c} have all been taken into
-account.
-
-@node Naming Schemes,Installation,Avoid Duplication With Variables,Building With Projects
-@anchor{gnat_ugn/gnat_project_manager id11}@anchor{169}@anchor{gnat_ugn/gnat_project_manager naming-schemes}@anchor{14e}
-@subsection Naming Schemes
-
-
-Sometimes an Ada software system is ported from one compilation environment to
-another (say GNAT), and the file are not named using the default GNAT
-conventions. Instead of changing all the file names, which for a variety of
-reasons might not be possible, you can define the relevant file naming scheme
-in the @strong{Naming} package of your project file.
-
-The naming scheme has two distinct goals for the project manager: it
-allows finding of source files when searching in the source
-directories, and given a source file name it makes it possible to guess
-the associated language, and thus the compiler to use.
-
-Note that the use by the Ada compiler of pragmas Source_File_Name is not
-supported when using project files. You must use the features described in this
-paragraph. You can however specify other configuration pragmas.
-
-The following attributes can be defined in package @cite{Naming}:
-
-@geindex Casing (GNAT Project Manager)
-
-@strong{Casing}:
-
-@quotation
-
-Its value must be one of @cite{"lowercase"} (the default if
-unspecified), @cite{"uppercase"} or @cite{"mixedcase"}. It describes the
-casing of file names with regards to the Ada unit name. Given an Ada unit
-My_Unit, the file name will respectively be @code{my_unit.adb} (lowercase),
-@code{MY_UNIT.ADB} (uppercase) or @code{My_Unit.adb} (mixedcase).
-On Windows, file names are case insensitive, so this attribute is
-irrelevant.
-@end quotation
-
-@geindex Dot_Replacement (GNAT Project Manager)
-
-@strong{Dot_Replacement}:
-
-@quotation
-
-This attribute specifies the string that should replace the "." in unit
-names. Its default value is @cite{"-"} so that a unit
-@cite{Parent.Child} is expected to be found in the file
-@code{parent-child.adb}. The replacement string must satisfy the following
-requirements to avoid ambiguities in the naming scheme:
-
-
-@itemize *
-
-@item
-It must not be empty
-
-@item
-It cannot start or end with an alphanumeric character
-
-@item
-It cannot be a single underscore
-
-@item
-It cannot start with an underscore followed by an alphanumeric
-
-@item
-It cannot contain a dot @cite{'.'} except if the entire string is @cite{"."}
-@end itemize
-@end quotation
-
-@geindex Spec_Suffix (GNAT Project Manager)
-
-@geindex Specification_Suffix (GNAT Project Manager)
-
-@strong{Spec_Suffix} and @strong{Specification_Suffix}:
-
-@quotation
-
-For Ada, these attributes give the suffix used in file names that contain
-specifications. For other languages, they give the extension for files
-that contain declaration (header files in C for instance). The attribute
-is indexed on the language.
-The two attributes are equivalent, but the latter is obsolescent.
-
-If the value of the attribute is the empty string, it indicates to the
-Project Manager that the only specifications/header files for the language
-are those specified with attributes @cite{Spec} or
-@cite{Specification_Exceptions}.
-
-If @cite{Spec_Suffix ("Ada")} is not specified, then the default is
-@cite{".ads"}.
-
-A non empty value must satisfy the following requirements:
-
-
-@itemize *
-
-@item
-It must include at least one dot
-
-@item
-If @cite{Dot_Replacement} is a single dot, then it cannot include
-more than one dot.
-@end itemize
-@end quotation
-
-@geindex Body_Suffix (GNAT Project Manager)
-
-@geindex Implementation_Suffix (GNAT Project Manager)
-
-@strong{Body_Suffix} and @strong{Implementation_Suffix}:
-
-@quotation
-
-These attributes give the extension used for file names that contain
-code (bodies in Ada). They are indexed on the language. The second
-version is obsolescent and fully replaced by the first attribute.
-
-For each language of a project, one of these two attributes need to be
-specified, either in the project itself or in the configuration project file.
-
-If the value of the attribute is the empty string, it indicates to the
-Project Manager that the only source files for the language
-are those specified with attributes @cite{Body} or
-@cite{Implementation_Exceptions}.
-
-These attributes must satisfy the same requirements as @cite{Spec_Suffix}.
-In addition, they must be different from any of the values in
-@cite{Spec_Suffix}.
-If @cite{Body_Suffix ("Ada")} is not specified, then the default is
-@cite{".adb"}.
-
-If @cite{Body_Suffix ("Ada")} and @cite{Spec_Suffix ("Ada")} end with the
-same string, then a file name that ends with the longest of these two
-suffixes will be a body if the longest suffix is @cite{Body_Suffix ("Ada")}
-or a spec if the longest suffix is @cite{Spec_Suffix ("Ada")}.
-
-If the suffix does not start with a '.', a file with a name exactly equal to
-the suffix will also be part of the project (for instance if you define the
-suffix as @cite{Makefile.in}, a file called @code{Makefile.in} will be part
-of the project. This capability is usually not interesting when building.
-However, it might become useful when a project is also used to
-find the list of source files in an editor, like the GNAT Programming System
-(GPS).
-@end quotation
-
-@geindex Separate_Suffix (GNAT Project Manager)
-
-@strong{Separate_Suffix}:
-
-@quotation
-
-This attribute is specific to Ada. It denotes the suffix used in file names
-that contain separate bodies. If it is not specified, then it defaults to
-same value as @cite{Body_Suffix ("Ada")}.
-
-The value of this attribute cannot be the empty string.
-
-Otherwise, the same rules apply as for the
-@cite{Body_Suffix} attribute. The only accepted index is "Ada".
-@end quotation
-
-@strong{Spec} or @strong{Specification}:
-
-@quotation
-
-@geindex Spec (GNAT Project Manager)
-
-@geindex Specification (GNAT Project Manager)
-
-This attribute @cite{Spec} can be used to define the source file name for a
-given Ada compilation unit's spec. The index is the literal name of the Ada
-unit (case insensitive). The value is the literal base name of the file that
-contains this unit's spec (case sensitive or insensitive depending on the
-operating system). This attribute allows the definition of exceptions to the
-general naming scheme, in case some files do not follow the usual
-convention.
-
-When a source file contains several units, the relative position of the unit
-can be indicated. The first unit in the file is at position 1
-
-@example
-for Spec ("MyPack.MyChild") use "mypack.mychild.spec";
-for Spec ("top") use "foo.a" at 1;
-for Spec ("foo") use "foo.a" at 2;
-@end example
-@end quotation
-
-@geindex Body (GNAT Project Manager)
-
-@geindex Implementation (GNAT Project Manager)
-
-@strong{Body} or @strong{Implementation}:
-
-@quotation
-
-These attribute play the same role as @emph{Spec} for Ada bodies.
-@end quotation
-
-@geindex Specification_Exceptions (GNAT Project Manager)
-
-@geindex Implementation_Exceptions (GNAT Project Manager)
-
-@strong{Specification_Exceptions} and @strong{Implementation_Exceptions}:
-
-@quotation
-
-These attributes define exceptions to the naming scheme for languages
-other than Ada. They are indexed on the language name, and contain
-a list of file names respectively for headers and source code.
-@end quotation
-
-For example, the following package models the Apex file naming rules:
-
-@example
-package Naming is
- for Casing use "lowercase";
- for Dot_Replacement use ".";
- for Spec_Suffix ("Ada") use ".1.ada";
- for Body_Suffix ("Ada") use ".2.ada";
-end Naming;
-@end example
-
-@node Installation,Distributed support,Naming Schemes,Building With Projects
-@anchor{gnat_ugn/gnat_project_manager id12}@anchor{16a}@anchor{gnat_ugn/gnat_project_manager installation}@anchor{16b}
-@subsection Installation
-
-
-After building an application or a library it is often required to
-install it into the development environment. For instance this step is
-required if the library is to be used by another application.
-The @emph{gprinstall} tool provides an easy way to install
-libraries, executable or object code generated during the build. The
-@strong{Install} package can be used to change the default locations.
-
-The following attributes can be defined in package @cite{Install}:
-
-@geindex Active (GNAT Project Manager)
-
-
-@table @asis
-
-@item @strong{Active}
-
-Whether the project is to be installed, values are @cite{true}
-(default) or @cite{false}.
-@end table
-
-@geindex Artifacts (GNAT Project Manager)
-
-@strong{Artifacts}
-
-@quotation
-
-An array attribute to declare a set of files not part of the sources
-to be installed. The array discriminant is the directory where the
-file is to be installed. If a relative directory then Prefix (see
-below) is prepended. Note also that if the same file name occurs
-multiple time in the attribute list, the last one will be the one
-installed.
-@end quotation
-
-@geindex Prefix (GNAT Project Manager)
-
-@strong{Prefix}:
-
-@quotation
-
-Root directory for the installation.
-@end quotation
-
-@strong{Exec_Subdir}
-
-@quotation
-
-Subdirectory of @strong{Prefix} where executables are to be
-installed. Default is @strong{bin}.
-@end quotation
-
-@strong{Lib_Subdir}
-
-@quotation
-
-Subdirectory of @strong{Prefix} where directory with the library or object
-files is to be installed. Default is @strong{lib}.
-@end quotation
-
-@strong{Sources_Subdir}
-
-@quotation
-
-Subdirectory of @strong{Prefix} where directory with sources is to be
-installed. Default is @strong{include}.
-@end quotation
-
-@strong{Project_Subdir}
-
-@quotation
-
-Subdirectory of @strong{Prefix} where the generated project file is to be
-installed. Default is @strong{share/gpr}.
-@end quotation
-
-@strong{Mode}
-
-@quotation
-
-The installation mode, it is either @strong{dev} (default) or @strong{usage}.
-See @strong{gprbuild} user's guide for details.
-@end quotation
-
-@strong{Install_Name}
-
-@quotation
-
-Specify the name to use for recording the installation. The default is
-the project name without the extension.
-@end quotation
-
-@node Distributed support,,Installation,Building With Projects
-@anchor{gnat_ugn/gnat_project_manager id13}@anchor{16c}@anchor{gnat_ugn/gnat_project_manager distributed-support}@anchor{16d}
-@subsection Distributed support
-
-
-For large projects the compilation time can become a limitation in
-the development cycle. To cope with that, GPRbuild supports
-distributed compilation.
-
-The following attributes can be defined in package @cite{Remote}:
-
-@geindex Root_Dir (GNAT Project Manager)
-
-@strong{Root_Dir}:
-
-@quotation
-
-Root directory of the project's sources. The default value is the
-project's directory.
-@end quotation
-
-@node Organizing Projects into Subsystems,Scenarios in Projects,Building With Projects,GNAT Project Manager
-@anchor{gnat_ugn/gnat_project_manager organizing-projects-into-subsystems}@anchor{151}@anchor{gnat_ugn/gnat_project_manager id14}@anchor{16e}
-@section Organizing Projects into Subsystems
-
-
-A @strong{subsystem} is a coherent part of the complete system to be built. It is
-represented by a set of sources and one single object directory. A system can
-be composed of a single subsystem when it is simple as we have seen in the
-first section. Complex systems are usually composed of several interdependent
-subsystems. A subsystem is dependent on another subsystem if knowledge of the
-other one is required to build it, and in particular if visibility on some of
-the sources of this other subsystem is required. Each subsystem is usually
-represented by its own project file.
-
-In this section, the previous example is being extended. Let's assume some
-sources of our @cite{Build} project depend on other sources.
-For instance, when building a graphical interface, it is usual to depend upon
-a graphical library toolkit such as GtkAda. Furthermore, we also need
-sources from a logging module we had previously written.
-
-@menu
-* Project Dependencies::
-* Cyclic Project Dependencies::
-* Sharing Between Projects::
-* Global Attributes::
-
-@end menu
-
-@node Project Dependencies,Cyclic Project Dependencies,,Organizing Projects into Subsystems
-@anchor{gnat_ugn/gnat_project_manager project-dependencies}@anchor{16f}@anchor{gnat_ugn/gnat_project_manager id15}@anchor{170}
-@subsection Project Dependencies
-
-
-GtkAda comes with its own project file (appropriately called
-@code{gtkada.gpr}), and we will assume we have already built a project
-called @code{logging.gpr} for the logging module. With the information provided
-so far in @code{build.gpr}, building the application would fail with an error
-indicating that the gtkada and logging units that are relied upon by the sources
-of this project cannot be found.
-
-This is solved by adding the following @strong{with} clauses at the beginning of our
-project:
-
-@example
-with "gtkada.gpr";
-with "a/b/logging.gpr";
-project Build is
- ... -- as before
-end Build;
-@end example
-
-@geindex Externally_Built (GNAT Project Manager)
-
-When such a project is compiled, @emph{gprbuild} will automatically check
-the other projects and recompile their sources when needed. It will also
-recompile the sources from @cite{Build} when needed, and finally create the
-executable. In some cases, the implementation units needed to recompile a
-project are not available, or come from some third party and you do not want to
-recompile it yourself. In this case, set the attribute @strong{Externally_Built} to
-"true", indicating to the builder that this project can be assumed to be
-up-to-date, and should not be considered for recompilation. In Ada, if the
-sources of this externally built project were compiled with another version of
-the compiler or with incompatible options, the binder will issue an error.
-
-The project's @emph{with} clause has several effects. It provides source
-visibility between projects during the compilation process. It also guarantees
-that the necessary object files from @cite{Logging} and @cite{GtkAda} are
-available when linking @cite{Build}.
-
-As can be seen in this example, the syntax for importing projects is similar
-to the syntax for importing compilation units in Ada. However, project files
-use literal strings instead of names, and the @emph{with} clause identifies
-project files rather than packages.
-
-Each literal string after @emph{with} is the path
-(absolute or relative) to a project file. The @cite{.gpr} extension is
-optional, although we recommend adding it. If no extension is specified,
-and no project file with the @code{.gpr} extension is found, then
-the file is searched for exactly as written in the @emph{with} clause,
-that is with no extension.
-
-As mentioned above, the path after a @emph{with} has to be a literal
-string, and you cannot use concatenation, or lookup the value of external
-variables to change the directories from which a project is loaded.
-A solution if you need something like this is to use aggregate projects
-(see @ref{171,,Aggregate Projects}).
-
-@geindex project path (GNAT Project Manager)
-
-When a relative path or a base name is used, the
-project files are searched relative to each of the directories in the
-@strong{project path}. This path includes all the directories found with the
-following algorithm, in this order; the first matching file is used:
-
-
-@itemize *
-
-@item
-First, the file is searched relative to the directory that contains the
-current project file.
-
-@geindex GPR_PROJECT_PATH_FILE (GNAT Project Manager)
-
-@geindex GPR_PROJECT_PATH (GNAT Project Manager)
-
-@geindex ADA_PROJECT_PATH (GNAT Project Manager)
-
-@item
-Then it is searched relative to all the directories specified in the
-environment variables @strong{GPR_PROJECT_PATH_FILE},
-@strong{GPR_PROJECT_PATH} and @strong{ADA_PROJECT_PATH} (in that order) if they exist.
-The value of @strong{GPR_PROJECT_PATH_FILE}, when defined, is the path name of
-a text file that contains project directory path names, one per line.
-@strong{GPR_PROJECT_PATH} and @strong{ADA_PROJECT_PATH}, when defined, contain
-project directory path names separated by directory separators.
-@strong{ADA_PROJECT_PATH} is used for compatibility, it is recommended to
-use @strong{GPR_PROJECT_PATH_FILE} or @strong{GPR_PROJECT_PATH}.
-
-@item
-Finally, it is searched relative to the default project directories.
-Such directories depend on the tool used. The locations searched in the
-specified order are:
-
-
-@itemize *
-
-@item
-@code{<prefix>/<target>/lib/gnat} if option @emph{--target} is specified
-
-@item
-@code{<prefix>/<target>/share/gpr} if option @emph{--target} is specified
-
-@item
-@code{<prefix>/share/gpr/}
-
-@item
-@code{<prefix>/lib/gnat/}
-@end itemize
-
-In our example, @code{gtkada.gpr} is found in the predefined directory if
-it was installed at the same root as GNAT.
-@end itemize
-
-Some tools also support extending the project path from the command line,
-generally through the @emph{-aP}. You can see the value of the project
-path by using the @emph{gnatls -v} command.
-
-Any symbolic link will be fully resolved in the directory of the
-importing project file before the imported project file is examined.
-
-Any source file in the imported project can be used by the sources of the
-importing project, transitively.
-Thus if @cite{A} imports @cite{B}, which imports @cite{C}, the sources of
-@cite{A} may depend on the sources of @cite{C}, even if @cite{A} does not
-import @cite{C} explicitly. However, this is not recommended, because if
-and when @cite{B} ceases to import @cite{C}, some sources in @cite{A} will
-no longer compile. @emph{gprbuild} has a switch @emph{--no-indirect-imports}
-that will report such indirect dependencies.
-
-@cartouche
-@quotation Note
-One very important aspect of a project hierarchy is that
-@strong{a given source can only belong to one project} (otherwise the project manager
-would not know which settings apply to it and when to recompile it). It means
-that different project files do not usually share source directories or
-when they do, they need to specify precisely which project owns which sources
-using attribute @cite{Source_Files} or equivalent. By contrast, 2 projects
-can each own a source with the same base file name as long as they live in
-different directories. The latter is not true for Ada Sources because of the
-correlation between source files and Ada units.
-@end quotation
-@end cartouche
-
-@node Cyclic Project Dependencies,Sharing Between Projects,Project Dependencies,Organizing Projects into Subsystems
-@anchor{gnat_ugn/gnat_project_manager id16}@anchor{172}@anchor{gnat_ugn/gnat_project_manager cyclic-project-dependencies}@anchor{173}
-@subsection Cyclic Project Dependencies
-
-
-Cyclic dependencies are mostly forbidden:
-if @cite{A} imports @cite{B} (directly or indirectly) then @cite{B}
-is not allowed to import @cite{A}. However, there are cases when cyclic
-dependencies would be beneficial. For these cases, another form of import
-between projects exists: the @strong{limited with}. A project @cite{A} that
-imports a project @cite{B} with a straight @emph{with} may also be imported,
-directly or indirectly, by @cite{B} through a @cite{limited with}.
-
-The difference between straight @emph{with} and @cite{limited with} is that
-the name of a project imported with a @cite{limited with} cannot be used in the
-project importing it. In particular, its packages cannot be renamed and
-its variables cannot be referred to.
-
-@example
-with "b.gpr";
-with "c.gpr";
-project A is
- for Exec_Dir use B'Exec_Dir; -- ok
-end A;
-
-limited with "a.gpr"; -- Cyclic dependency: A -> B -> A
-project B is
- for Exec_Dir use A'Exec_Dir; -- not ok
-end B;
-
-with "d.gpr";
-project C is
-end C;
-
-limited with "a.gpr"; -- Cyclic dependency: A -> C -> D -> A
-project D is
- for Exec_Dir use A'Exec_Dir; -- not ok
-end D;
-@end example
-
-@node Sharing Between Projects,Global Attributes,Cyclic Project Dependencies,Organizing Projects into Subsystems
-@anchor{gnat_ugn/gnat_project_manager sharing-between-projects}@anchor{174}@anchor{gnat_ugn/gnat_project_manager id17}@anchor{175}
-@subsection Sharing Between Projects
-
-
-When building an application, it is common to have similar needs in several of
-the projects corresponding to the subsystems under construction. For instance,
-they will all have the same compilation switches.
-
-As seen before (see @ref{161,,Tools Options in Project Files}), setting compilation
-switches for all sources of a subsystem is simple: it is just a matter of
-adding a @cite{Compiler.Default_Switches} attribute to each project files with
-the same value. Of course, that means duplication of data, and both places need
-to be changed in order to recompile the whole application with different
-switches. It can become a real problem if there are many subsystems and thus
-many project files to edit.
-
-There are two main approaches to avoiding this duplication:
-
-
-@itemize *
-
-@item
-Since @code{build.gpr} imports @code{logging.gpr}, we could change it
-to reference the attribute in Logging, either through a package renaming,
-or by referencing the attribute. The following example shows both cases:
-
-@example
-project Logging is
- package Compiler is
- for Switches ("Ada")
- use ("-O2");
- end Compiler;
- package Binder is
- for Switches ("Ada")
- use ("-E");
- end Binder;
-end Logging;
-
-with "logging.gpr";
-project Build is
- package Compiler renames Logging.Compiler;
- package Binder is
- for Switches ("Ada") use Logging.Binder'Switches ("Ada");
- end Binder;
-end Build;
-@end example
-
-The solution used for @cite{Compiler} gets the same value for all
-attributes of the package, but you cannot modify anything from the
-package (adding extra switches or some exceptions). The second
-version is more flexible, but more verbose.
-
-If you need to refer to the value of a variable in an imported
-project, rather than an attribute, the syntax is similar but uses
-a "." rather than an apostrophe. For instance:
-
-@example
-with "imported";
-project Main is
- Var1 := Imported.Var;
-end Main;
-@end example
-
-@item
-The second approach is to define the switches in a third project.
-That project is set up without any sources (so that, as opposed to
-the first example, none of the project plays a special role), and
-will only be used to define the attributes. Such a project is
-typically called @code{shared.gpr}.
-
-@example
-abstract project Shared is
- for Source_Files use (); -- no sources
- package Compiler is
- for Switches ("Ada")
- use ("-O2");
- end Compiler;
-end Shared;
-
-with "shared.gpr";
-project Logging is
- package Compiler renames Shared.Compiler;
-end Logging;
-
-with "shared.gpr";
-project Build is
- package Compiler renames Shared.Compiler;
-end Build;
-@end example
-
-As for the first example, we could have chosen to set the attributes
-one by one rather than to rename a package. The reason we explicitly
-indicate that @cite{Shared} has no sources is so that it can be created
-in any directory and we are sure it shares no sources with @cite{Build}
-or @cite{Logging}, which of course would be invalid.
-
-@geindex project qualifier (GNAT Project Manager)
-
-Note the additional use of the @strong{abstract} qualifier in @code{shared.gpr}.
-This qualifier is optional, but helps convey the message that we do not
-intend this project to have sources (see @ref{176,,Qualified Projects} for
-more qualifiers).
-@end itemize
-
-@node Global Attributes,,Sharing Between Projects,Organizing Projects into Subsystems
-@anchor{gnat_ugn/gnat_project_manager global-attributes}@anchor{177}@anchor{gnat_ugn/gnat_project_manager id18}@anchor{178}
-@subsection Global Attributes
-
-
-We have already seen many examples of attributes used to specify a special
-option of one of the tools involved in the build process. Most of those
-attributes are project specific. That it to say, they only affect the invocation
-of tools on the sources of the project where they are defined.
-
-There are a few additional attributes that apply to all projects in a
-hierarchy as long as they are defined on the "main" project.
-The main project is the project explicitly mentioned on the command-line.
-The project hierarchy is the "with"-closure of the main project.
-
-Here is a list of commonly used global attributes:
-
-@geindex Global_Configuration_Pragmas (GNAT Project Manager)
-
-@strong{Builder.Global_Configuration_Pragmas}:
-
-@quotation
-
-This attribute points to a file that contains configuration pragmas
-to use when building executables. These pragmas apply for all
-executables built from this project hierarchy. As we have seen before,
-additional pragmas can be specified on a per-project basis by setting the
-@cite{Compiler.Local_Configuration_Pragmas} attribute.
-@end quotation
-
-@geindex Global_Compilation_Switches (GNAT Project Manager)
-
-@strong{Builder.Global_Compilation_Switches}:
-
-@quotation
-
-This attribute is a list of compiler switches to use when compiling any
-source file in the project hierarchy. These switches are used in addition
-to the ones defined in the @cite{Compiler} package, which only apply to
-the sources of the corresponding project. This attribute is indexed on
-the name of the language.
-@end quotation
-
-Using such global capabilities is convenient. It can also lead to unexpected
-behavior. Especially when several subsystems are shared among different main
-projects and the different global attributes are not
-compatible. Note that using aggregate projects can be a safer and more powerful
-replacement to global attributes.
-
-@node Scenarios in Projects,Library Projects,Organizing Projects into Subsystems,GNAT Project Manager
-@anchor{gnat_ugn/gnat_project_manager id19}@anchor{179}@anchor{gnat_ugn/gnat_project_manager scenarios-in-projects}@anchor{14f}
-@section Scenarios in Projects
-
-
-Various aspects of the projects can be modified based on @strong{scenarios}. These
-are user-defined modes that change the behavior of a project. Typical
-examples are the setup of platform-specific compiler options, or the use of
-a debug and a release mode (the former would activate the generation of debug
-information, while the second will focus on improving code optimization).
-
-Let's enhance our example to support debug and release modes. The issue is to
-let the user choose what kind of system he is building: use @emph{-g} as
-compiler switches in debug mode and @emph{-O2} in release mode. We will also
-set up the projects so that we do not share the same object directory in both
-modes; otherwise switching from one to the other might trigger more
-recompilations than needed or mix objects from the two modes.
-
-One naive approach is to create two different project files, say
-@code{build_debug.gpr} and @code{build_release.gpr}, that set the appropriate
-attributes as explained in previous sections. This solution does not scale
-well, because in the presence of multiple projects depending on each other, you
-will also have to duplicate the complete hierarchy and adapt the project files
-to point to the right copies.
-
-@geindex scenarios (GNAT Project Manager)
-
-Instead, project files support the notion of scenarios controlled
-by external values. Such values can come from several sources (in decreasing
-order of priority):
-
-@geindex -X (usage with GNAT Project Manager)
-
-
-@table @asis
-
-@item @strong{Command line}:
-
-When launching @emph{gprbuild}, the user can pass
-extra @emph{-X} switches to define the external value. In
-our case, the command line might look like
-
-@example
-gprbuild -Pbuild.gpr -Xmode=release
-@end example
-
-@item @strong{Environment variables}:
-
-When the external value does not come from the command line, it can come from
-the value of environment variables of the appropriate name.
-In our case, if an environment variable called "mode"
-exists, its value will be taken into account.
-@end table
-
-@geindex external (GNAT Project Manager)
-
-@strong{External function second parameter}.
-
-We now need to get that value in the project. The general form is to use
-the predefined function @strong{external} which returns the current value of
-the external. For instance, we could set up the object directory to point to
-either @code{obj/debug} or @code{obj/release} by changing our project to
-
-@example
-project Build is
- for Object_Dir use "obj/" & external ("mode", "debug");
- ... -- as before
-end Build;
-@end example
-
-The second parameter to @cite{external} is optional, and is the default
-value to use if "mode" is not set from the command line or the environment.
-
-In order to set the switches according to the different scenarios, other
-constructs have to be introduced such as typed variables and case constructions.
-
-@geindex typed variable (GNAT Project Manager)
-
-@geindex case construction (GNAT Project Manager)
-
-A @strong{typed variable} is a variable that
-can take only a limited number of values, similar to an enumeration in Ada.
-Such a variable can then be used in a @strong{case construction} and create conditional
-sections in the project. The following example shows how this can be done:
-
-@example
-project Build is
- type Mode_Type is ("debug", "release"); -- all possible values
- Mode : Mode_Type := external ("mode", "debug"); -- a typed variable
-
- package Compiler is
- case Mode is
- when "debug" =>
- for Switches ("Ada")
- use ("-g");
- when "release" =>
- for Switches ("Ada")
- use ("-O2");
- end case;
- end Compiler;
-end Build;
-@end example
-
-The project has suddenly grown in size, but has become much more flexible.
-@cite{Mode_Type} defines the only valid values for the @cite{mode} variable. If
-any other value is read from the environment, an error is reported and the
-project is considered as invalid.
-
-The @cite{Mode} variable is initialized with an external value
-defaulting to @cite{"debug"}. This default could be omitted and that would
-force the user to define the value. Finally, we can use a case construction to set the
-switches depending on the scenario the user has chosen.
-
-Most aspects of the projects can depend on scenarios. The notable exception
-are project dependencies (@emph{with} clauses), which cannot depend on a scenario.
-
-Scenarios work the same way with @strong{project hierarchies}: you can either
-duplicate a variable similar to @cite{Mode} in each of the project (as long
-as the first argument to @cite{external} is always the same and the type is
-the same), or simply set the variable in the @code{shared.gpr} project
-(see @ref{174,,Sharing Between Projects}).
-
-@node Library Projects,Project Extension,Scenarios in Projects,GNAT Project Manager
-@anchor{gnat_ugn/gnat_project_manager library-projects}@anchor{8a}@anchor{gnat_ugn/gnat_project_manager id20}@anchor{17a}
-@section Library Projects
-
-
-So far, we have seen examples of projects that create executables. However,
-it is also possible to create libraries instead. A @strong{library} is a specific
-type of subsystem where, for convenience, objects are grouped together
-using system-specific means such as archives or windows DLLs.
-
-Library projects provide a system- and language-independent way of building
-both @strong{static} and @strong{dynamic} libraries. They also support the concept of
-@strong{standalone libraries} (SAL) which offer two significant properties: the
-elaboration (e.g. initialization) of the library is either automatic or
-very simple; a change in the
-implementation part of the library implies minimal post-compilation actions on
-the complete system and potentially no action at all for the rest of the
-system in the case of dynamic SALs.
-
-There is a restriction on shared library projects: by default, they are only
-allowed to import other shared library projects. They are not allowed to
-import non library projects or static library projects.
-
-The GNAT Project Manager takes complete care of the library build, rebuild and
-installation tasks, including recompilation of the source files for which
-objects do not exist or are not up to date, assembly of the library archive, and
-installation of the library (i.e., copying associated source, object and
-@code{ALI} files to the specified location).
-
-@menu
-* Building Libraries::
-* Using Library Projects::
-* Stand-alone Library Projects::
-* Installing a library with project files::
-
-@end menu
-
-@node Building Libraries,Using Library Projects,,Library Projects
-@anchor{gnat_ugn/gnat_project_manager id21}@anchor{17b}@anchor{gnat_ugn/gnat_project_manager building-libraries}@anchor{17c}
-@subsection Building Libraries
-
-
-Let's enhance our example and transform the @cite{logging} subsystem into a
-library. In order to do so, a few changes need to be made to
-@code{logging.gpr}. Some attributes need to be defined: at least
-@cite{Library_Name} and @cite{Library_Dir}; in addition, some other attributes
-can be used to specify specific aspects of the library. For readability, it is
-also recommended (although not mandatory), to use the qualifier @cite{library}
-in front of the @cite{project} keyword.
-
-@geindex Library_Name (GNAT Project Manager)
-
-@strong{Library_Name}:
-
-@quotation
-
-This attribute is the name of the library to be built. There is no
-restriction on the name of a library imposed by the project manager, except
-for stand-alone libraries whose names must follow the syntax of Ada
-identifiers; however, there may be system-specific restrictions on the name.
-In general, it is recommended to stick to alphanumeric characters (and
-possibly single underscores) to help portability.
-@end quotation
-
-@geindex Library_Dir (GNAT Project Manager)
-
-@strong{Library_Dir}:
-
-@quotation
-
-This attribute is the path (absolute or relative) of the directory where
-the library is to be installed. In the process of building a library,
-the sources are compiled, the object files end up in the explicit or
-implicit @cite{Object_Dir} directory. When all sources of a library
-are compiled, some of the compilation artifacts, including the library itself,
-are copied to the library_dir directory. This directory must exist and be
-writable. It must also be different from the object directory so that cleanup
-activities in the Library_Dir do not affect recompilation needs.
-@end quotation
-
-Here is the new version of @code{logging.gpr} that makes it a library:
-
-@example
-library project Logging is -- "library" is optional
- for Library_Name use "logging"; -- will create "liblogging.a" on Unix
- for Object_Dir use "obj";
- for Library_Dir use "lib"; -- different from object_dir
-end Logging;
-@end example
-
-Once the above two attributes are defined, the library project is valid and
-is enough for building a library with default characteristics.
-Other library-related attributes can be used to change the defaults:
-
-@geindex Library_Kind (GNAT Project Manager)
-
-@strong{Library_Kind}:
-
-@quotation
-
-The value of this attribute must be either @cite{"static"}, @cite{"dynamic"} or
-@cite{"relocatable"} (the latter is a synonym for dynamic). It indicates
-which kind of library should be built (the default is to build a
-static library, that is an archive of object files that can potentially
-be linked into a static executable). When the library is set to be dynamic,
-a separate image is created that will be loaded independently, usually
-at the start of the main program execution. Support for dynamic libraries is
-very platform specific, for instance on Windows it takes the form of a DLL
-while on GNU/Linux, it is a dynamic elf image whose suffix is usually
-@code{.so}. Library project files, on the other hand, can be written in
-a platform independent way so that the same project file can be used to build
-a library on different operating systems.
-
-If you need to build both a static and a dynamic library, it is recommended
-to use two different object directories, since in some cases some extra code
-needs to be generated for the latter. For such cases, one can either define
-two different project files, or a single one that uses scenarios to indicate
-the various kinds of library to be built and their corresponding object_dir.
-@end quotation
-
-@geindex Library_ALI_Dir (GNAT Project Manager)
-
-@strong{Library_ALI_Dir}:
-
-@quotation
-
-This attribute may be specified to indicate the directory where the ALI
-files of the library are installed. By default, they are copied into the
-@cite{Library_Dir} directory, but as for the executables where we have a
-separate @cite{Exec_Dir} attribute, you might want to put them in a separate
-directory since there can be hundreds of them. The same restrictions as for
-the @cite{Library_Dir} attribute apply.
-@end quotation
-
-@geindex Library_Version (GNAT Project Manager)
-
-@strong{Library_Version}:
-
-@quotation
-
-This attribute is platform dependent, and has no effect on Windows.
-On Unix, it is used only for dynamic libraries as the internal
-name of the library (the @cite{"soname"}). If the library file name (built
-from the @cite{Library_Name}) is different from the @cite{Library_Version},
-then the library file will be a symbolic link to the actual file whose name
-will be @cite{Library_Version}. This follows the usual installation schemes
-for dynamic libraries on many Unix systems.
-
-@example
-project Logging is
- Version := "1";
- for Library_Dir use "lib";
- for Library_Name use "logging";
- for Library_Kind use "dynamic";
- for Library_Version use "liblogging.so." & Version;
-end Logging;
-@end example
-
-After the compilation, the directory @code{lib} will contain both a
-@code{libdummy.so.1} library and a symbolic link to it called
-@code{libdummy.so}.
-@end quotation
-
-@geindex Library_GCC (GNAT Project Manager)
-
-@strong{Library_GCC}:
-
-@quotation
-
-This attribute is the name of the tool to use instead of "gcc" to link shared
-libraries. A common use of this attribute is to define a wrapper script that
-accomplishes specific actions before calling gcc (which itself calls the
-linker to build the library image).
-@end quotation
-
-@geindex Library_Options (GNAT Project Manager)
-
-@strong{Library_Options}:
-
-@quotation
-
-This attribute may be used to specify additional switches (last switches)
-when linking a shared library.
-
-It may also be used to add foreign object files to a static library.
-Each string in Library_Options is an absolute or relative path of an object
-file. When a relative path, it is relative to the object directory.
-@end quotation
-
-@geindex Leading_Library_Options (GNAT Project Manager)
-
-@strong{Leading_Library_Options}:
-
-@quotation
-
-This attribute, that is taken into account only by @emph{gprbuild}, may be
-used to specified leading options (first switches) when linking a shared
-library.
-@end quotation
-
-@geindex Linker_Options (GNAT Project Manager)
-
-@strong{Linker.Linker_Options}:
-
-@quotation
-
-This attribute specifies additional switches to be given to the linker when
-linking an executable. It is ignored when defined in the main project and
-taken into account in all other projects that are imported directly or
-indirectly. These switches complement the @cite{Linker.Switches}
-defined in the main project. This is useful when a particular subsystem
-depends on an external library: adding this dependency as a
-@cite{Linker_Options} in the project of the subsystem is more convenient than
-adding it to all the @cite{Linker.Switches} of the main projects that depend
-upon this subsystem.
-@end quotation
-
-@node Using Library Projects,Stand-alone Library Projects,Building Libraries,Library Projects
-@anchor{gnat_ugn/gnat_project_manager id22}@anchor{17d}@anchor{gnat_ugn/gnat_project_manager using-library-projects}@anchor{17e}
-@subsection Using Library Projects
-
-
-When the builder detects that a project file is a library project file, it
-recompiles all sources of the project that need recompilation and rebuild the
-library if any of the sources have been recompiled. It then groups all object
-files into a single file, which is a shared or a static library. This library
-can later on be linked with multiple executables. Note that the use
-of shard libraries reduces the size of the final executable and can also reduce
-the memory footprint at execution time when the library is shared among several
-executables.
-
-@emph{gprbuild also allows to build **multi-language libraries*} when specifying
-sources from multiple languages.
-
-A non-library project can import a library project. When the builder is invoked
-on the former, the library of the latter is only rebuilt when absolutely
-necessary. For instance, if a unit of the library is not up-to-date but none of
-the executables need this unit, then the unit is not recompiled and the library
-is not reassembled. For instance, let's assume in our example that logging has
-the following sources: @code{log1.ads}, @code{log1.adb}, @code{log2.ads} and
-@code{log2.adb}. If @code{log1.adb} has been modified, then the library
-@code{liblogging} will be rebuilt when compiling all the sources of
-@cite{Build} only if @code{proc.ads}, @code{pack.ads} or @code{pack.adb}
-include a @cite{"with Log1"}.
-
-To ensure that all the sources in the @cite{Logging} library are
-up to date, and that all the sources of @cite{Build} are also up to date,
-the following two commands need to be used:
-
-@example
-gprbuild -Plogging.gpr
-gprbuild -Pbuild.gpr
-@end example
-
-All @code{ALI} files will also be copied from the object directory to the
-library directory. To build executables, @emph{gprbuild} will use the
-library rather than the individual object files.
-
-Library projects can also be useful to describe a library that needs to be used
-but, for some reason, cannot be rebuilt. For instance, it is the case when some
-of the library sources are not available. Such library projects need to use the
-@cite{Externally_Built} attribute as in the example below:
-
-@example
-library project Extern_Lib is
- for Languages use ("Ada", "C");
- for Source_Dirs use ("lib_src");
- for Library_Dir use "lib2";
- for Library_Kind use "dynamic";
- for Library_Name use "l2";
- for Externally_Built use "true"; -- <<<<
-end Extern_Lib;
-@end example
-
-In the case of externally built libraries, the @cite{Object_Dir}
-attribute does not need to be specified because it will never be
-used.
-
-The main effect of using such an externally built library project is mostly to
-affect the linker command in order to reference the desired library. It can
-also be achieved by using @cite{Linker.Linker_Options} or @cite{Linker.Switches}
-in the project corresponding to the subsystem needing this external library.
-This latter method is more straightforward in simple cases but when several
-subsystems depend upon the same external library, finding the proper place
-for the @cite{Linker.Linker_Options} might not be easy and if it is
-not placed properly, the final link command is likely to present ordering issues.
-In such a situation, it is better to use the externally built library project
-so that all other subsystems depending on it can declare this dependency thanks
-to a project @emph{with} clause, which in turn will trigger the builder to find
-the proper order of libraries in the final link command.
-
-@node Stand-alone Library Projects,Installing a library with project files,Using Library Projects,Library Projects
-@anchor{gnat_ugn/gnat_project_manager id23}@anchor{17f}@anchor{gnat_ugn/gnat_project_manager stand-alone-library-projects}@anchor{97}
-@subsection Stand-alone Library Projects
-
-
-@geindex standalone libraries (usage with GNAT Project Manager)
-
-A @strong{stand-alone library} is a library that contains the necessary code to
-elaborate the Ada units that are included in the library. A stand-alone
-library is a convenient way to add an Ada subsystem to a more global system
-whose main is not in Ada since it makes the elaboration of the Ada part mostly
-transparent. However, stand-alone libraries are also useful when the main is in
-Ada: they provide a means for minimizing relinking & redeployment of complex
-systems when localized changes are made.
-
-The name of a stand-alone library, specified with attribute
-@cite{Library_Name}, must have the syntax of an Ada identifier.
-
-The most prominent characteristic of a stand-alone library is that it offers a
-distinction between interface units and implementation units. Only the former
-are visible to units outside the library. A stand-alone library project is thus
-characterised by a third attribute, usually @strong{Library_Interface}, in addition
-to the two attributes that make a project a Library Project
-(@cite{Library_Name} and @cite{Library_Dir}). This third attribute may also be
-@strong{Interfaces}. @strong{Library_Interface} only works when the interface is in Ada
-and takes a list of units as parameter. @strong{Interfaces} works for any supported
-language and takes a list of sources as parameter.
-
-@geindex Library_Interface (GNAT Project Manager)
-
-@strong{Library_Interface}:
-
-@quotation
-
-This attribute defines an explicit subset of the units of the project. Units
-from projects importing this library project may only "with" units whose
-sources are listed in the @cite{Library_Interface}. Other sources are
-considered implementation units.
-
-@example
-for Library_Dir use "lib";
-for Library_Name use "logging";
-for Library_Interface use ("lib1", "lib2"); -- unit names
-@end example
-@end quotation
-
-@strong{Interfaces}
-
-@quotation
-
-This attribute defines an explicit subset of the source files of a project.
-Sources from projects importing this project, can only depend on sources from
-this subset. This attribute can be used on non library projects. It can also
-be used as a replacement for attribute @cite{Library_Interface}, in which
-case, units have to be replaced by source files. For multi-language library
-projects, it is the only way to make the project a Stand-Alone Library project
-whose interface is not purely Ada.
-@end quotation
-
-@geindex Library_Standalone (GNAT Project Manager)
-
-@strong{Library_Standalone}:
-
-@quotation
-
-This attribute defines the kind of standalone library to
-build. Values are either @cite{standard} (the default), @cite{no} or
-@cite{encapsulated}. When @cite{standard} is used the code to elaborate and
-finalize the library is embedded, when @cite{encapsulated} is used the
-library can furthermore depend only on static libraries (including
-the GNAT runtime). This attribute can be set to @cite{no} to make it clear
-that the library should not be standalone in which case the
-@cite{Library_Interface} should not defined. Note that this attribute
-only applies to shared libraries, so @cite{Library_Kind} must be set
-to @cite{dynamic}.
-
-@example
-for Library_Dir use "lib";
-for Library_Name use "logging";
-for Library_Kind use "dynamic";
-for Library_Interface use ("lib1", "lib2"); -- unit names
-for Library_Standalone use "encapsulated";
-@end example
-@end quotation
-
-In order to include the elaboration code in the stand-alone library, the binder
-is invoked on the closure of the library units creating a package whose name
-depends on the library name (b~logging.ads/b in the example).
-This binder-generated package includes @strong{initialization} and @strong{finalization}
-procedures whose names depend on the library name (@cite{logginginit} and
-@cite{loggingfinal} in the example). The object corresponding to this package is
-included in the library.
-
-@geindex Library_Auto_Init (GNAT Project Manager)
-
-@strong{Library_Auto_Init}:
-
-@quotation
-
-A dynamic stand-alone Library is automatically initialized
-if automatic initialization of Stand-alone Libraries is supported on the
-platform and if attribute @strong{Library_Auto_Init} is not specified or
-is specified with the value "true". A static Stand-alone Library is never
-automatically initialized. Specifying "false" for this attribute
-prevents automatic initialization.
-
-When a non-automatically initialized stand-alone library is used in an
-executable, its initialization procedure must be called before any service of
-the library is used. When the main subprogram is in Ada, it may mean that the
-initialization procedure has to be called during elaboration of another
-package.
-@end quotation
-
-@geindex Library_Dir (GNAT Project Manager)
-
-@strong{Library_Dir}:
-
-@quotation
-
-For a stand-alone library, only the @code{ALI} files of the interface units
-(those that are listed in attribute @cite{Library_Interface}) are copied to
-the library directory. As a consequence, only the interface units may be
-imported from Ada units outside of the library. If other units are imported,
-the binding phase will fail.
-@end quotation
-
-@strong{Binder.Default_Switches}:
-
-@quotation
-
-When a stand-alone library is bound, the switches that are specified in
-the attribute @strong{Binder.Default_Switches ("Ada")} are
-used in the call to @emph{gnatbind}.
-@end quotation
-
-@geindex Library_Src_Dir (GNAT Project Manager)
-
-@strong{Library_Src_Dir}:
-
-@quotation
-
-This attribute defines the location (absolute or relative to the project
-directory) where the sources of the interface units are copied at
-installation time.
-These sources includes the specs of the interface units along with the
-closure of sources necessary to compile them successfully. That may include
-bodies and subunits, when pragmas @cite{Inline} are used, or when there are
-generic units in specs. This directory cannot point to the object directory
-or one of the source directories, but it can point to the library directory,
-which is the default value for this attribute.
-@end quotation
-
-@geindex Library_Symbol_Policy (GNAT Project Manager)
-
-@strong{Library_Symbol_Policy}:
-
-@quotation
-
-This attribute controls the export of symbols and, on some platforms (like
-VMS) that have the notions of major and minor IDs built in the library
-files, it controls the setting of these IDs. It is not supported on all
-platforms (where it will just have no effect). It may have one of the
-following values:
-
-
-@itemize *
-
-@item
-@cite{"autonomous"} or @cite{"default"}: exported symbols are not controlled
-
-@item
-@cite{"compliant"}: if attribute @strong{Library_Reference_Symbol_File}
-is not defined, then it is equivalent to policy "autonomous". If there
-are exported symbols in the reference symbol file that are not in the
-object files of the interfaces, the major ID of the library is increased.
-If there are symbols in the object files of the interfaces that are not
-in the reference symbol file, these symbols are put at the end of the list
-in the newly created symbol file and the minor ID is increased.
-
-@item
-@cite{"controlled"}: the attribute @strong{Library_Reference_Symbol_File} must be
-defined. The library will fail to build if the exported symbols in the
-object files of the interfaces do not match exactly the symbol in the
-symbol file.
-
-@item
-@cite{"restricted"}: The attribute @strong{Library_Symbol_File} must be defined.
-The library will fail to build if there are symbols in the symbol file that
-are not in the exported symbols of the object files of the interfaces.
-Additional symbols in the object files are not added to the symbol file.
-
-@item
-@cite{"direct"}: The attribute @strong{Library_Symbol_File} must be defined and
-must designate an existing file in the object directory. This symbol file
-is passed directly to the underlying linker without any symbol processing.
-@end itemize
-@end quotation
-
-@geindex Library_Reference_Symbol_File (GNAT Project Manager)
-
-@strong{Library_Reference_Symbol_File}
-
-@quotation
-
-This attribute may define the path name of a reference symbol file that is
-read when the symbol policy is either "compliant" or "controlled", on
-platforms that support symbol control, such as VMS, when building a
-stand-alone library. The path may be an absolute path or a path relative
-to the project directory.
-@end quotation
-
-@geindex Library_Symbol_File (GNAT Project Manager)
-
-@strong{Library_Symbol_File}
-
-@quotation
-
-This attribute may define the name of the symbol file to be created when
-building a stand-alone library when the symbol policy is either "compliant",
-"controlled" or "restricted", on platforms that support symbol control,
-such as VMS. When symbol policy is "direct", then a file with this name
-must exist in the object directory.
-@end quotation
-
-@node Installing a library with project files,,Stand-alone Library Projects,Library Projects
-@anchor{gnat_ugn/gnat_project_manager installing-a-library-with-project-files}@anchor{8d}@anchor{gnat_ugn/gnat_project_manager id24}@anchor{180}
-@subsection Installing a library with project files
-
-
-When using project files, a usable version of the library is created in the
-directory specified by the @cite{Library_Dir} attribute of the library
-project file. Thus no further action is needed in order to make use of
-the libraries that are built as part of the general application build.
-
-You may want to install a library in a context different from where the library
-is built. This situation arises with third party suppliers, who may want
-to distribute a library in binary form where the user is not expected to be
-able to recompile the library. The simplest option in this case is to provide
-a project file slightly different from the one used to build the library, by
-using the @cite{externally_built} attribute. See @ref{17e,,Using Library Projects}
-
-Another option is to use @emph{gprinstall} to install the library in a
-different context than the build location. @emph{gprinstall} automatically
-generates a project to use this library, and also copies the minimum set of
-sources needed to use the library to the install location.
-@ref{16b,,Installation}
-
-@node Project Extension,Aggregate Projects,Library Projects,GNAT Project Manager
-@anchor{gnat_ugn/gnat_project_manager id25}@anchor{181}@anchor{gnat_ugn/gnat_project_manager project-extension}@anchor{152}
-@section Project Extension
-
-
-During development of a large system, it is sometimes necessary to use
-modified versions of some of the source files, without changing the original
-sources. This can be achieved through the @strong{project extension} facility.
-
-Suppose for instance that our example @cite{Build} project is built every night
-for the whole team, in some shared directory. A developer usually needs to work
-on a small part of the system, and might not want to have a copy of all the
-sources and all the object files (mostly because that would require too much
-disk space, time to recompile everything). He prefers to be able to override
-some of the source files in his directory, while taking advantage of all the
-object files generated at night.
-
-Another example can be taken from large software systems, where it is common to have
-multiple implementations of a common interface; in Ada terms, multiple
-versions of a package body for the same spec. For example, one implementation
-might be safe for use in tasking programs, while another might be used only
-in sequential applications. This can be modeled in GNAT using the concept
-of @emph{project extension}. If one project (the 'child') @emph{extends}
-another project (the 'parent') then by default all source files of the
-parent project are inherited by the child, but the child project can
-override any of the parent's source files with new versions, and can also
-add new files or remove unnecessary ones.
-This facility is the project analog of a type extension in
-object-oriented programming. Project hierarchies are permitted (an extending
-project may itself be extended), and a project that
-extends a project can also import other projects.
-
-A third example is that of using project extensions to provide different
-versions of the same system. For instance, assume that a @cite{Common}
-project is used by two development branches. One of the branches has now
-been frozen, and no further change can be done to it or to @cite{Common}.
-However, the other development branch still needs evolution of @cite{Common}.
-Project extensions provide a flexible solution to create a new version
-of a subsystem while sharing and reusing as much as possible from the original
-one.
-
-A project extension implicitly inherits all the sources and objects from the
-project it extends. It is possible to create a new version of some of the
-sources in one of the additional source directories of the extending
-project. Those new versions hide the original versions. Adding new sources or
-removing existing ones is also possible. Here is an example on how to extend
-the project @cite{Build} from previous examples:
-
-@example
-project Work extends "../bld/build.gpr" is
-end Work;
-@end example
-
-The project after @strong{extends} is the one being extended. As usual, it can be
-specified using an absolute path, or a path relative to any of the directories
-in the project path (see @ref{16f,,Project Dependencies}). This project does not
-specify source or object directories, so the default values for these
-attributes will be used that is to say the current directory (where project
-@cite{Work} is placed). We can compile that project with
-
-@example
-gprbuild -Pwork
-@end example
-
-If no sources have been placed in the current directory, this command
-won't do anything, since this project does not change the
-sources it inherited from @cite{Build}, therefore all the object files
-in @cite{Build} and its dependencies are still valid and are reused
-automatically.
-
-Suppose we now want to supply an alternate version of @code{pack.adb} but use
-the existing versions of @code{pack.ads} and @code{proc.adb}. We can create
-the new file in Work's current directory (likely by copying the one from the
-@cite{Build} project and making changes to it. If new packages are needed at
-the same time, we simply create new files in the source directory of the
-extending project.
-
-When we recompile, @emph{gprbuild} will now automatically recompile
-this file (thus creating @code{pack.o} in the current directory) and
-any file that depends on it (thus creating @code{proc.o}). Finally, the
-executable is also linked locally.
-
-Note that we could have obtained the desired behavior using project import
-rather than project inheritance. A @cite{base} project would contain the
-sources for @code{pack.ads} and @code{proc.adb}, and @cite{Work} would
-import @cite{base} and add @code{pack.adb}. In this scenario, @cite{base}
-cannot contain the original version of @code{pack.adb} otherwise there would be
-2 versions of the same unit in the closure of the project and this is not
-allowed. Generally speaking, it is not recommended to put the spec and the
-body of a unit in different projects since this affects their autonomy and
-reusability.
-
-In a project file that extends another project, it is possible to
-indicate that an inherited source is @strong{not part} of the sources of the
-extending project. This is necessary sometimes when a package spec has
-been overridden and no longer requires a body: in this case, it is
-necessary to indicate that the inherited body is not part of the sources
-of the project, otherwise there will be a compilation error
-when compiling the spec.
-
-@geindex Excluded_Source_Files (GNAT Project Manager)
-
-@geindex Excluded_Source_List_File (GNAT Project Manager)
-
-For that purpose, the attribute @strong{Excluded_Source_Files} is used.
-Its value is a list of file names.
-It is also possible to use attribute @cite{Excluded_Source_List_File}.
-Its value is the path of a text file containing one file name per
-line.
-
-@example
-project Work extends "../bld/build.gpr" is
- for Source_Files use ("pack.ads");
- -- New spec of Pkg does not need a completion
- for Excluded_Source_Files use ("pack.adb");
-end Work;
-@end example
-
-All packages that are not declared in the extending project are inherited from
-the project being extended, with their attributes, with the exception of
-@cite{Linker'Linker_Options} which is never inherited. In particular, an
-extending project retains all the switches specified in the project being
-extended.
-
-At the project level, if they are not declared in the extending project, some
-attributes are inherited from the project being extended. They are:
-@cite{Languages}, @cite{Main} (for a root non library project) and
-@cite{Library_Name} (for a project extending a library project).
-
-@menu
-* Project Hierarchy Extension::
-
-@end menu
-
-@node Project Hierarchy Extension,,,Project Extension
-@anchor{gnat_ugn/gnat_project_manager project-hierarchy-extension}@anchor{182}@anchor{gnat_ugn/gnat_project_manager id26}@anchor{183}
-@subsection Project Hierarchy Extension
-
-
-One of the fundamental restrictions in project extension is the following:
-@strong{A project is not allowed to import directly or indirectly at the same time an extending project and one of its ancestors}.
-
-For example, consider the following hierarchy of projects.
-
-@example
-a.gpr contains package A1
-b.gpr, imports a.gpr and contains B1, which depends on A1
-c.gpr, imports b.gpr and contains C1, which depends on B1
-@end example
-
-If we want to locally extend the packages @cite{A1} and @cite{C1}, we need to
-create several extending projects:
-
-@example
-a_ext.gpr which extends a.gpr, and overrides A1
-b_ext.gpr which extends b.gpr and imports a_ext.gpr
-c_ext.gpr which extends c.gpr, imports b_ext.gpr and overrides C1
-@end example
-
-@example
-project A_Ext extends "a.gpr" is
- for Source_Files use ("a1.adb", "a1.ads");
-end A_Ext;
-
-with "a_ext.gpr";
-project B_Ext extends "b.gpr" is
-end B_Ext;
-
-with "b_ext.gpr";
-project C_Ext extends "c.gpr" is
- for Source_Files use ("c1.adb");
-end C_Ext;
-@end example
-
-The extension @code{b_ext.gpr} is required, even though we are not overriding
-any of the sources of @code{b.gpr} because otherwise @code{c_expr.gpr} would
-import @code{b.gpr} which itself knows nothing about @code{a_ext.gpr}.
-
-@geindex extends all (GNAT Project Manager)
-
-When extending a large system spanning multiple projects, it is often
-inconvenient to extend every project in the hierarchy that is impacted by a
-small change introduced in a low layer. In such cases, it is possible to create
-an @strong{implicit extension} of an entire hierarchy using @strong{extends all}
-relationship.
-
-When the project is extended using @cite{extends all} inheritance, all projects
-that are imported by it, both directly and indirectly, are considered virtually
-extended. That is, the project manager creates implicit projects
-that extend every project in the hierarchy; all these implicit projects do not
-control sources on their own and use the object directory of
-the "extending all" project.
-
-It is possible to explicitly extend one or more projects in the hierarchy
-in order to modify the sources. These extending projects must be imported by
-the "extending all" project, which will replace the corresponding virtual
-projects with the explicit ones.
-
-When building such a project hierarchy extension, the project manager will
-ensure that both modified sources and sources in implicit extending projects
-that depend on them are recompiled.
-
-Thus, in our example we could create the following projects instead:
-
-@example
-a_ext.gpr, extends a.gpr and overrides A1
-c_ext.gpr, "extends all" c.gpr, imports a_ext.gpr and overrides C1
-@end example
-
-@example
-project A_Ext extends "a.gpr" is
- for Source_Files use ("a1.adb", "a1.ads");
-end A_Ext;
-
-with "a_ext.gpr";
-project C_Ext extends all "c.gpr" is
- for Source_Files use ("c1.adb");
-end C_Ext;
-@end example
-
-When building project @code{c_ext.gpr}, the entire modified project space is
-considered for recompilation, including the sources of @code{b.gpr} that are
-impacted by the changes in @cite{A1} and @cite{C1}.
-
-@node Aggregate Projects,Aggregate Library Projects,Project Extension,GNAT Project Manager
-@anchor{gnat_ugn/gnat_project_manager aggregate-projects}@anchor{171}@anchor{gnat_ugn/gnat_project_manager id27}@anchor{184}
-@section Aggregate Projects
-
-
-Aggregate projects are an extension of the project paradigm, and are
-meant to solve a few specific use cases that cannot be solved directly
-using standard projects. This section will go over a few of these use
-cases to try to explain what you can use aggregate projects for.
-
-@menu
-* Building all main programs from a single project tree::
-* Building a set of projects with a single command::
-* Define a build environment::
-* Performance improvements in builder::
-* Syntax of aggregate projects::
-* package Builder in aggregate projects::
-
-@end menu
-
-@node Building all main programs from a single project tree,Building a set of projects with a single command,,Aggregate Projects
-@anchor{gnat_ugn/gnat_project_manager id28}@anchor{185}@anchor{gnat_ugn/gnat_project_manager building-all-main-programs-from-a-single-project-tree}@anchor{186}
-@subsection Building all main programs from a single project tree
-
-
-Most often, an application is organized into modules and submodules,
-which are very conveniently represented as a project tree or graph
-(the root project A @emph{with}s the projects for each modules (say B and C),
-which in turn @emph{with} projects for submodules.
-
-Very often, modules will build their own executables (for testing
-purposes for instance), or libraries (for easier reuse in various
-contexts).
-
-However, if you build your project through @emph{gprbuild}, using a syntax similar to
-
-@example
-gprbuild -PA.gpr
-@end example
-
-this will only rebuild the main programs of project A, not those of the
-imported projects B and C. Therefore you have to spawn several
-@emph{gprbuild} commands, one per project, to build all executables.
-This is a little inconvenient, but more importantly is inefficient
-because @emph{gprbuild} needs to do duplicate work to ensure that sources are
-up-to-date, and cannot easily compile things in parallel when using
-the -j switch.
-
-Also libraries are always rebuilt when building a project.
-
-You could therefore define an aggregate project Agg that groups A, B
-and C. Then, when you build with
-
-@example
-gprbuild -PAgg.gpr
-@end example
-
-this will build all mains from A, B and C.
-
-@example
-aggregate project Agg is
- for Project_Files use ("a.gpr", "b.gpr", "c.gpr");
-end Agg;
-@end example
-
-If B or C do not define any main program (through their Main
-attribute), all their sources are built. When you do not group them
-in the aggregate project, only those sources that are needed by A
-will be built.
-
-If you add a main to a project P not already explicitly referenced in the
-aggregate project, you will need to add "p.gpr" in the list of project
-files for the aggregate project, or the main will not be built when
-building the aggregate project.
-
-@node Building a set of projects with a single command,Define a build environment,Building all main programs from a single project tree,Aggregate Projects
-@anchor{gnat_ugn/gnat_project_manager building-a-set-of-projects-with-a-single-command}@anchor{187}@anchor{gnat_ugn/gnat_project_manager id29}@anchor{188}
-@subsection Building a set of projects with a single command
-
-
-One other case is when you have multiple applications and libraries
-that are built independently from each other (but can be built in
-parallel). For instance, you have a project tree rooted at A, and
-another one (which might share some subprojects) rooted at B.
-
-Using only @emph{gprbuild}, you could do
-
-@example
-gprbuild -PA.gpr
-gprbuild -PB.gpr
-@end example
-
-to build both. But again, @emph{gprbuild} has to do some duplicate work for
-those files that are shared between the two, and cannot truly build
-things in parallel efficiently.
-
-If the two projects are really independent, share no sources other
-than through a common subproject, and have no source files with a
-common basename, you could create a project C that imports A and
-B. But these restrictions are often too strong, and one has to build
-them independently. An aggregate project does not have these
-limitations and can aggregate two project trees that have common
-sources.
-
-This scenario is particularly useful in environments like VxWorks 653
-where the applications running in the multiple partitions can be built
-in parallel through a single @emph{gprbuild} command. This also works nicely
-with Annex E.
-
-@node Define a build environment,Performance improvements in builder,Building a set of projects with a single command,Aggregate Projects
-@anchor{gnat_ugn/gnat_project_manager id30}@anchor{189}@anchor{gnat_ugn/gnat_project_manager define-a-build-environment}@anchor{18a}
-@subsection Define a build environment
-
-
-The environment variables at the time you launch @emph{gprbuild}
-will influence the view these tools have of the project
-(PATH to find the compiler, ADA_PROJECT_PATH or GPR_PROJECT_PATH to find the
-projects, environment variables that are referenced in project files
-through the "external" built-in function, ...). Several command line switches
-can be used to override those (-X or -aP), but on some systems and
-with some projects, this might make the command line too long, and on
-all systems often make it hard to read.
-
-An aggregate project can be used to set the environment for all
-projects built through that aggregate. One of the nice aspects is that
-you can put the aggregate project under configuration management, and
-make sure all your user have a consistent environment when
-building. The syntax looks like
-
-@example
-aggregate project Agg is
- for Project_Files use ("A.gpr", "B.gpr");
- for Project_Path use ("../dir1", "../dir1/dir2");
- for External ("BUILD") use "PRODUCTION";
-
- package Builder is
- for Global_Compilation_Switches ("Ada") use ("-g");
- end Builder;
-end Agg;
-@end example
-
-One of the often requested features in projects is to be able to
-reference external variables in @emph{with} declarations, as in
-
-@example
-with external("SETUP") & "path/prj.gpr"; -- ILLEGAL
-project MyProject is
- ...
-end MyProject;
-@end example
-
-For various reasons, this is not allowed. But using aggregate projects provide
-an elegant solution. For instance, you could use a project file like:
-
-@example
-aggregate project Agg is
- for Project_Path use (external("SETUP") & "path");
- for Project_Files use ("myproject.gpr");
-end Agg;
-
-with "prj.gpr"; -- searched on Agg'Project_Path
-project MyProject is
- ...
-end MyProject;
-@end example
-
-@node Performance improvements in builder,Syntax of aggregate projects,Define a build environment,Aggregate Projects
-@anchor{gnat_ugn/gnat_project_manager performance-improvements-in-builder}@anchor{18b}@anchor{gnat_ugn/gnat_project_manager id31}@anchor{18c}
-@subsection Performance improvements in builder
-
-
-The loading of aggregate projects is optimized in @emph{gprbuild},
-so that all files are searched for only once on the disk
-(thus reducing the number of system calls and contributing to faster
-compilation times, especially on systems with sources on remote
-servers). As part of the loading, @emph{gprbuild}
-computes how and where a source file should be compiled, and even if it is
-found several times in the aggregated projects it will be compiled only
-once.
-
-Since there is no ambiguity as to which switches should be used, files
-can be compiled in parallel (through the usual -j switch) and this can
-be done while maximizing the use of CPUs (compared to launching
-multiple @emph{gprbuild} commands in parallel).
-
-@node Syntax of aggregate projects,package Builder in aggregate projects,Performance improvements in builder,Aggregate Projects
-@anchor{gnat_ugn/gnat_project_manager id32}@anchor{18d}@anchor{gnat_ugn/gnat_project_manager syntax-of-aggregate-projects}@anchor{18e}
-@subsection Syntax of aggregate projects
-
-
-An aggregate project follows the general syntax of project files. The
-recommended extension is still @code{.gpr}. However, a special
-@cite{aggregate} qualifier must be put before the keyword
-@cite{project}.
-
-An aggregate project cannot @emph{with} any other project (standard or
-aggregate), except an abstract project which can be used to share attribute
-values. Also, aggregate projects cannot be extended or imported though a
-@emph{with} clause by any other project. Building other aggregate projects from
-an aggregate project is done through the Project_Files attribute (see below).
-
-An aggregate project does not have any source files directly (only
-through other standard projects). Therefore a number of the standard
-attributes and packages are forbidden in an aggregate project. Here is the
-(non exhaustive) list:
-
-
-@itemize *
-
-@item
-Languages
-
-@item
-Source_Files, Source_List_File and other attributes dealing with
-list of sources.
-
-@item
-Source_Dirs, Exec_Dir and Object_Dir
-
-@item
-Library_Dir, Library_Name and other library-related attributes
-
-@item
-Main
-
-@item
-Roots
-
-@item
-Externally_Built
-
-@item
-Inherit_Source_Path
-
-@item
-Excluded_Source_Dirs
-
-@item
-Locally_Removed_Files
-
-@item
-Excluded_Source_Files
-
-@item
-Excluded_Source_List_File
-
-@item
-Interfaces
-@end itemize
-
-The only package that is authorized (albeit optional) is
-Builder. Other packages (in particular Compiler, Binder and Linker)
-are forbidden.
-
-The following three attributes can be used only in an aggregate project:
-
-@geindex Project_Files (GNAT Project Manager)
-
-@strong{Project_Files}:
-
-@quotation
-
-This attribute is compulsory (or else we are not aggregating any project,
-and thus not doing anything). It specifies a list of @code{.gpr} files
-that are grouped in the aggregate. The list may be empty. The project
-files can be either other aggregate projects, or standard projects. When
-grouping standard projects, you can have both the root of a project tree
-(and you do not need to specify all its imported projects), and any project
-within the tree.
-
-Basically, the idea is to specify all those projects that have
-main programs you want to build and link, or libraries you want to
-build. You can even specify projects that do not use the Main
-attribute nor the @cite{Library_*} attributes, and the result will be to
-build all their source files (not just the ones needed by other
-projects).
-
-The file can include paths (absolute or relative). Paths are relative to
-the location of the aggregate project file itself (if you use a base name,
-we expect to find the .gpr file in the same directory as the aggregate
-project file). The environment variables @cite{ADA_PROJECT_PATH},
-@cite{GPR_PROJECT_PATH} and @cite{GPR_PROJECT_PATH_FILE} are not used to find
-the project files. The extension @code{.gpr} is mandatory, since this attribute
-contains file names, not project names.
-
-Paths can also include the @cite{"*"} and @cite{"**"} globbing patterns. The
-latter indicates that any subdirectory (recursively) will be
-searched for matching files. The latter (@cite{"**"}) can only occur at the
-last position in the directory part (ie @cite{"a/**/*.gpr"} is supported, but
-not @cite{"**/a/*.gpr"}). Starting the pattern with @cite{"**"} is equivalent
-to starting with @cite{"./**"}.
-
-For now, the pattern @cite{"*"} is only allowed in the filename part, not
-in the directory part. This is mostly for efficiency reasons to limit the
-number of system calls that are needed.
-
-Here are a few valid examples:
-
-@example
-for Project_Files use ("a.gpr", "subdir/b.gpr");
--- two specific projects relative to the directory of agg.gpr
-
-for Project_Files use ("/.gpr");
--- all projects recursively
-@end example
-@end quotation
-
-@geindex Project_Path (GNAT Project Manager)
-
-@strong{Project_Path}:
-
-@quotation
-
-This attribute can be used to specify a list of directories in
-which to look for project files in @emph{with} declarations.
-
-When you specify a project in Project_Files (say @cite{x/y/a.gpr}), and
-@cite{a.gpr} imports a project @cite{b.gpr}, only @cite{b.gpr} is searched in
-the project path. @cite{a.gpr} must be exactly at
-@cite{<dir of the aggregate>/x/y/a.gpr}.
-
-This attribute, however, does not affect the search for the aggregated
-project files specified with @cite{Project_Files}.
-
-Each aggregate project has its own @cite{Project_Path} (that is if
-@cite{agg1.gpr} includes @cite{agg2.gpr}, they can potentially both have a
-different @cite{Project_Path}).
-
-This project path is defined as the concatenation, in that order, of:
-
-
-@itemize *
-
-@item
-the current directory;
-
-@item
-followed by the command line -aP switches;
-
-@item
-then the directories from the GPR_PROJECT_PATH and ADA_PROJECT_PATH environment
-variables;
-
-@item
-then the directories from the Project_Path attribute;
-
-@item
-and finally the predefined directories.
-@end itemize
-
-In the example above, agg2.gpr's project path is not influenced by
-the attribute agg1'Project_Path, nor is agg1 influenced by
-agg2'Project_Path.
-
-This can potentially lead to errors. Consider the following example:
-
-@example
---
--- +---------------+ +----------------+
--- | Agg1.gpr |-=--includes--=-->| Agg2.gpr |
--- | 'project_path| | 'project_path |
--- | | | |
--- +---------------+ +----------------+
--- : :
--- includes includes
--- : :
--- v v
--- +-------+ +---------+
--- | P.gpr |<---------- withs --------| Q.gpr |
--- +-------+---------\ +---------+
--- | |
--- withs |
--- | |
--- v v
--- +-------+ +---------+
--- | R.gpr | | R'.gpr |
--- +-------+ +---------+
-@end example
-
-When looking for p.gpr, both aggregates find the same physical file on
-the disk. However, it might happen that with their different project
-paths, both aggregate projects would in fact find a different r.gpr.
-Since we have a common project (p.gpr) "with"ing two different r.gpr,
-this will be reported as an error by the builder.
-
-Directories are relative to the location of the aggregate project file.
-
-Example:
-
-@example
-for Project_Path use ("/usr/local/gpr", "gpr/");
-@end example
-@end quotation
-
-@geindex External (GNAT Project Manager)
-
-@strong{External}:
-
-@quotation
-
-This attribute can be used to set the value of environment
-variables as retrieved through the @cite{external} function
-in projects. It does not affect the environment variables
-themselves (so for instance you cannot use it to change the value
-of your PATH as seen from the spawned compiler).
-
-This attribute affects the external values as seen in the rest of
-the aggregate project, and in the aggregated projects.
-
-The exact value of external a variable comes from one of three
-sources (each level overrides the previous levels):
-
-
-@itemize *
-
-@item
-An External attribute in aggregate project, for instance
-@cite{for External ("BUILD_MODE") use "DEBUG"};
-
-@item
-Environment variables.
-These override the value given by the attribute, so that
-users can override the value set in the (presumably shared
-with others team members) aggregate project.
-
-@item
-The -X command line switch to @emph{gprbuild}.
-This always takes precedence.
-@end itemize
-
-This attribute is only taken into account in the main aggregate
-project (i.e. the one specified on the command line to @emph{gprbuild}),
-and ignored in other aggregate projects. It is invalid
-in standard projects.
-The goal is to have a consistent value in all
-projects that are built through the aggregate, which would not
-be the case in the diamond case: A groups the aggregate
-projects B and C, which both (either directly or indirectly)
-build the project P. If B and C could set different values for
-the environment variables, we would have two different views of
-P, which in particular might impact the list of source files in P.
-@end quotation
-
-@node package Builder in aggregate projects,,Syntax of aggregate projects,Aggregate Projects
-@anchor{gnat_ugn/gnat_project_manager package-builder-in-aggregate-projects}@anchor{18f}@anchor{gnat_ugn/gnat_project_manager id33}@anchor{190}
-@subsection package Builder in aggregate projects
-
-
-As mentioned above, only the package Builder can be specified in
-an aggregate project. In this package, only the following attributes
-are valid:
-
-@geindex Switches (GNAT Project Manager)
-
-@strong{Switches}:
-
-@quotation
-
-This attribute gives the list of switches to use for @emph{gprbuild}.
-Because no mains can be specified for aggregate projects, the only possible
-index for attribute @cite{Switches} is @cite{others}. All other indexes will
-be ignored.
-
-Example:
-
-@example
-for Switches (others) use ("-v", "-k", "-j8");
-@end example
-
-These switches are only read from the main aggregate project (the
-one passed on the command line), and ignored in all other aggregate
-projects or projects.
-
-It can only contain builder switches, not compiler switches.
-@end quotation
-
-@geindex Global_Compilation_Switches (GNAT Project Manager)
-
-@strong{Global_Compilation_Switches}
-
-@quotation
-
-This attribute gives the list of compiler switches for the various
-languages. For instance,
-
-@example
-for Global_Compilation_Switches ("Ada") use ("O1", "-g");
-for Global_Compilation_Switches ("C") use ("-O2");
-@end example
-
-This attribute is only taken into account in the aggregate project
-specified on the command line, not in other aggregate projects.
-
-In the projects grouped by that aggregate, the attribute
-Builder.Global_Compilation_Switches is also ignored. However, the
-attribute Compiler.Default_Switches will be taken into account (but
-that of the aggregate have higher priority). The attribute
-Compiler.Switches is also taken into account and can be used to
-override the switches for a specific file. As a result, it always
-has priority.
-
-The rules are meant to avoid ambiguities when compiling. For
-instance, aggregate project Agg groups the projects A and B, that
-both depend on C. Here is an extra for all of these projects:
-
-@example
-aggregate project Agg is
- for Project_Files use ("a.gpr", "b.gpr");
- package Builder is
- for Global_Compilation_Switches ("Ada") use ("-O2");
- end Builder;
-end Agg;
-
-with "c.gpr";
-project A is
- package Builder is
- for Global_Compilation_Switches ("Ada") use ("-O1");
- -- ignored
- end Builder;
-
- package Compiler is
- for Default_Switches ("Ada")
- use ("-O1", "-g");
- for Switches ("a_file1.adb")
- use ("-O0");
- end Compiler;
-end A;
-
-with "c.gpr";
-project B is
- package Compiler is
- for Default_Switches ("Ada") use ("-O0");
- end Compiler;
-end B;
-
-project C is
- package Compiler is
- for Default_Switches ("Ada")
- use ("-O3",
- "-gnatn");
- for Switches ("c_file1.adb")
- use ("-O0", "-g");
- end Compiler;
-end C;
-@end example
-
-then the following switches are used:
-
-
-@itemize *
-
-@item
-all files from project A except a_file1.adb are compiled
-with "-O2 -g", since the aggregate project has priority.
-
-@item
-the file a_file1.adb is compiled with
-"-O0", since the Compiler.Switches has priority
-
-@item
-all files from project B are compiled with
-"-O2", since the aggregate project has priority
-
-@item
-all files from C are compiled with "-O2 -gnatn", except for
-c_file1.adb which is compiled with "-O0 -g"
-@end itemize
-
-Even though C is seen through two paths (through A and through
-B), the switches used by the compiler are unambiguous.
-@end quotation
-
-@geindex Global_Configuration_Pragmas (GNAT Project Manager)
-
-@strong{Global_Configuration_Pragmas}
-
-@quotation
-
-This attribute can be used to specify a file containing
-configuration pragmas, to be passed to the Ada compiler. Since we
-ignore the package Builder in other aggregate projects and projects,
-only those pragmas defined in the main aggregate project will be
-taken into account.
-
-Projects can locally add to those by using the
-@cite{Compiler.Local_Configuration_Pragmas} attribute if they need.
-@end quotation
-
-@geindex Global_Config_File (GNAT Project Manager)
-
-@strong{Global_Config_File}
-
-@quotation
-
-This attribute, indexed with a language name, can be used to specify a config
-when compiling sources of the language. For Ada, these files are configuration
-pragmas files.
-@end quotation
-
-For projects that are built through the aggregate, the package Builder
-is ignored, except for the Executable attribute which specifies the
-name of the executables resulting from the link of the main programs, and
-for the Executable_Suffix.
-
-@node Aggregate Library Projects,Project File Reference,Aggregate Projects,GNAT Project Manager
-@anchor{gnat_ugn/gnat_project_manager id34}@anchor{191}@anchor{gnat_ugn/gnat_project_manager aggregate-library-projects}@anchor{192}
-@section Aggregate Library Projects
-
-
-Aggregate library projects make it possible to build a single library
-using object files built using other standard or library
-projects. This gives the flexibility to describe an application as
-having multiple modules (a GUI, database access, ...) using different
-project files (so possibly built with different compiler options) and
-yet create a single library (static or relocatable) out of the
-corresponding object files.
-
-@menu
-* Building aggregate library projects::
-* Syntax of aggregate library projects::
-
-@end menu
-
-@node Building aggregate library projects,Syntax of aggregate library projects,,Aggregate Library Projects
-@anchor{gnat_ugn/gnat_project_manager building-aggregate-library-projects}@anchor{193}@anchor{gnat_ugn/gnat_project_manager id35}@anchor{194}
-@subsection Building aggregate library projects
-
-
-For example, we can define an aggregate project Agg that groups A, B
-and C:
-
-@example
-aggregate library project Agg is
- for Project_Files use ("a.gpr", "b.gpr", "c.gpr");
- for Library_Name use ("agg");
- for Library_Dir use ("lagg");
-end Agg;
-@end example
-
-Then, when you build with:
-
-@example
-gprbuild agg.gpr
-@end example
-
-This will build all units from projects A, B and C and will create a
-static library named @code{libagg.a} in the @code{lagg}
-directory. An aggregate library project has the same set of
-restriction as a standard library project.
-
-Note that a shared aggregate library project cannot aggregate a
-static library project. In platforms where a compiler option is
-required to create relocatable object files, a Builder package in the
-aggregate library project may be used:
-
-@example
-aggregate library project Agg is
- for Project_Files use ("a.gpr", "b.gpr", "c.gpr");
- for Library_Name use ("agg");
- for Library_Dir use ("lagg");
- for Library_Kind use "relocatable";
-
- package Builder is
- for Global_Compilation_Switches ("Ada") use ("-fPIC");
- end Builder;
-end Agg;
-@end example
-
-With the above aggregate library Builder package, the @cite{-fPIC}
-option will be passed to the compiler when building any source code
-from projects @code{a.gpr}, @code{b.gpr} and @code{c.gpr}.
-
-@node Syntax of aggregate library projects,,Building aggregate library projects,Aggregate Library Projects
-@anchor{gnat_ugn/gnat_project_manager syntax-of-aggregate-library-projects}@anchor{195}@anchor{gnat_ugn/gnat_project_manager id36}@anchor{196}
-@subsection Syntax of aggregate library projects
-
-
-An aggregate library project follows the general syntax of project
-files. The recommended extension is still @code{.gpr}. However, a special
-@cite{aggregate library} qualifier must be put before the keyword
-@cite{project}.
-
-An aggregate library project cannot @emph{with} any other project
-(standard or aggregate), except an abstract project which can be used
-to share attribute values.
-
-An aggregate library project does not have any source files directly (only
-through other standard projects). Therefore a number of the standard
-attributes and packages are forbidden in an aggregate library
-project. Here is the (non exhaustive) list:
-
-
-@itemize *
-
-@item
-Languages
-
-@item
-Source_Files, Source_List_File and other attributes dealing with
-list of sources.
-
-@item
-Source_Dirs, Exec_Dir and Object_Dir
-
-@item
-Main
-
-@item
-Roots
-
-@item
-Externally_Built
-
-@item
-Inherit_Source_Path
-
-@item
-Excluded_Source_Dirs
-
-@item
-Locally_Removed_Files
-
-@item
-Excluded_Source_Files
-
-@item
-Excluded_Source_List_File
-
-@item
-Interfaces
-@end itemize
-
-The only package that is authorized (albeit optional) is Builder.
-
-The Project_Files attribute (See @ref{171,,Aggregate Projects}) is used to
-described the aggregated projects whose object files have to be
-included into the aggregate library. The environment variables
-@cite{ADA_PROJECT_PATH}, @cite{GPR_PROJECT_PATH} and
-@cite{GPR_PROJECT_PATH_FILE} are not used to find the project files.
-
-@node Project File Reference,,Aggregate Library Projects,GNAT Project Manager
-@anchor{gnat_ugn/gnat_project_manager id37}@anchor{197}@anchor{gnat_ugn/gnat_project_manager project-file-reference}@anchor{150}
-@section Project File Reference
-
-
-This section describes the syntactic structure of project files, the various
-constructs that can be used. Finally, it ends with a summary of all available
-attributes.
-
-@menu
-* Project Declaration::
-* Qualified Projects::
-* Declarations::
-* Packages::
-* Expressions::
-* External Values::
-* Typed String Declaration::
-* Variables::
-* Case Constructions::
-* Attributes::
-
-@end menu
-
-@node Project Declaration,Qualified Projects,,Project File Reference
-@anchor{gnat_ugn/gnat_project_manager id38}@anchor{198}@anchor{gnat_ugn/gnat_project_manager project-declaration}@anchor{199}
-@subsection Project Declaration
-
-
-Project files have an Ada-like syntax. The minimal project file is:
-
-@example
-project Empty is
-end Empty;
-@end example
-
-The identifier @cite{Empty} is the name of the project.
-This project name must be present after the reserved
-word @cite{end} at the end of the project file, followed by a semi-colon.
-
-@strong{Identifiers} (i.e., the user-defined names such as project or variable names)
-have the same syntax as Ada identifiers: they must start with a letter,
-and be followed by zero or more letters, digits or underscore characters;
-it is also illegal to have two underscores next to each other. Identifiers
-are always case-insensitive ("Name" is the same as "name").
-
-@example
-simple_name ::= identifier
-name ::= simple_name @{ . simple_name @}
-@end example
-
-@strong{Strings} are used for values of attributes or as indexes for these
-attributes. They are in general case sensitive, except when noted
-otherwise (in particular, strings representing file names will be case
-insensitive on some systems, so that "file.adb" and "File.adb" both
-represent the same file).
-
-@strong{Reserved words} are the same as for standard Ada 95, and cannot
-be used for identifiers. In particular, the following words are currently
-used in project files, but others could be added later on. In bold are the
-extra reserved words in project files:
-@code{all}, @code{at}, @code{case}, @code{end}, @code{for}, @code{is}, @code{limited},
-@code{null}, @code{others}, @code{package}, @code{renames}, @code{type}, @code{use}, @code{when},
-@code{with}, @strong{extends}, @strong{external}, @strong{project}.
-
-@strong{Comments} in project files have the same syntax as in Ada, two consecutive
-hyphens through the end of the line.
-
-A project may be an @strong{independent project}, entirely defined by a single
-project file. Any source file in an independent project depends only
-on the predefined library and other source files in the same project.
-But a project may also depend on other projects, either by importing them
-through @strong{with clauses}, or by @strong{extending} at most one other project. Both
-types of dependency can be used in the same project.
-
-A path name denotes a project file. It can be absolute or relative.
-An absolute path name includes a sequence of directories, in the syntax of
-the host operating system, that identifies uniquely the project file in the
-file system. A relative path name identifies the project file, relative
-to the directory that contains the current project, or relative to a
-directory listed in the environment variables ADA_PROJECT_PATH and
-GPR_PROJECT_PATH. Path names are case sensitive if file names in the host
-operating system are case sensitive. As a special case, the directory
-separator can always be "/" even on Windows systems, so that project files
-can be made portable across architectures.
-The syntax of the environment variables ADA_PROJECT_PATH and
-GPR_PROJECT_PATH is a list of directory names separated by colons on UNIX and
-semicolons on Windows.
-
-A given project name can appear only once in a context clause.
-
-It is illegal for a project imported by a context clause to refer, directly
-or indirectly, to the project in which this context clause appears (the
-dependency graph cannot contain cycles), except when one of the with clauses
-in the cycle is a @strong{limited with}.
-
-@example
-with "other_project.gpr";
-project My_Project extends "extended.gpr" is
-end My_Project;
-@end example
-
-These dependencies form a @strong{directed graph}, potentially cyclic when using
-@strong{limited with}. The subgraph reflecting the @strong{extends} relations is a tree.
-
-A project's @strong{immediate sources} are the source files directly defined by
-that project, either implicitly by residing in the project source directories,
-or explicitly through any of the source-related attributes.
-More generally, a project's @strong{sources} are the immediate sources of the
-project together with the immediate sources (unless overridden) of any project
-on which it depends directly or indirectly.
-
-A @strong{project hierarchy} can be created, where projects are children of
-other projects. The name of such a child project must be @cite{Parent.Child},
-where @cite{Parent} is the name of the parent project. In particular, this
-makes all @emph{with} clauses of the parent project automatically visible
-in the child project.
-
-@example
-project ::= context_clause project_declaration
-
-context_clause ::= @{with_clause@}
-with_clause ::= *with* path_name @{ , path_name @} ;
-path_name ::= string_literal
-
-project_declaration ::= simple_project_declaration | project_extension
-simple_project_declaration ::=
- project <project_>name is
- @{declarative_item@}
- end <project_>simple_name;
-@end example
-
-@node Qualified Projects,Declarations,Project Declaration,Project File Reference
-@anchor{gnat_ugn/gnat_project_manager qualified-projects}@anchor{176}@anchor{gnat_ugn/gnat_project_manager id39}@anchor{19a}
-@subsection Qualified Projects
-
-
-Before the reserved @cite{project}, there may be one or two @strong{qualifiers}, that
-is identifiers or reserved words, to qualify the project.
-The current list of qualifiers is:
-
-
-@table @asis
-
-@item @strong{abstract}:
-
-Qualifies a project with no sources.
-Such a project must either have no declaration of attributes @cite{Source_Dirs},
-@cite{Source_Files}, @cite{Languages} or @cite{Source_List_File}, or one of
-@cite{Source_Dirs}, @cite{Source_Files}, or @cite{Languages} must be declared
-as empty. If it extends another project, the project it extends must also be a
-qualified abstract project.
-
-@item @strong{standard}:
-
-A standard project is a non library project with sources.
-This is the default (implicit) qualifier.
-
-@item @strong{aggregate}:
-
-A project whose sources are aggregated from other project files.
-
-@item @strong{aggregate library}:
-
-A library whose sources are aggregated from other project
-or library project files.
-
-@item @strong{library}:
-
-A library project must declare both attributes
-Library_Name` and @cite{Library_Dir}.
-
-@item @strong{configuration}:
-
-A configuration project cannot be in a project tree.
-It describes compilers and other tools to @emph{gprbuild}.
-@end table
-
-@node Declarations,Packages,Qualified Projects,Project File Reference
-@anchor{gnat_ugn/gnat_project_manager declarations}@anchor{19b}@anchor{gnat_ugn/gnat_project_manager id40}@anchor{19c}
-@subsection Declarations
-
-
-Declarations introduce new entities that denote types, variables, attributes,
-and packages. Some declarations can only appear immediately within a project
-declaration. Others can appear within a project or within a package.
-
-@example
-declarative_item ::= simple_declarative_item
- | typed_string_declaration
- | package_declaration
-
-simple_declarative_item ::= variable_declaration
- | typed_variable_declaration
- | attribute_declaration
- | case_construction
- | empty_declaration
-
-empty_declaration ::= *null* ;
-@end example
-
-An empty declaration is allowed anywhere a declaration is allowed. It has
-no effect.
-
-@node Packages,Expressions,Declarations,Project File Reference
-@anchor{gnat_ugn/gnat_project_manager packages}@anchor{156}@anchor{gnat_ugn/gnat_project_manager id41}@anchor{19d}
-@subsection Packages
-
-
-A project file may contain @strong{packages}, that group attributes (typically
-all the attributes that are used by one of the GNAT tools).
-
-A package with a given name may only appear once in a project file.
-The following packages are currently supported in project files
-(See @ref{155,,Attributes} for the list of attributes that each can contain).
-
-
-@table @asis
-
-@item @emph{Binder}
-
-This package specifies characteristics useful when invoking the binder either
-directly via the @emph{gnat} driver or when using @emph{gprbuild}.
-See @ref{160,,Main Subprograms}.
-
-@item @emph{Builder}
-
-This package specifies the compilation options used when building an
-executable or a library for a project. Most of the options should be
-set in one of @cite{Compiler}, @cite{Binder} or @cite{Linker} packages,
-but there are some general options that should be defined in this
-package. See @ref{160,,Main Subprograms}, and @ref{165,,Executable File Names} in
-particular.
-@end table
-
-
-
-@table @asis
-
-@item @emph{Clean}
-
-This package specifies the options used when cleaning a project or a project
-tree using the tools @emph{gnatclean} or @emph{gprclean}.
-
-@item @emph{Compiler}
-
-This package specifies the compilation options used by the compiler for
-each languages. See @ref{161,,Tools Options in Project Files}.
-
-@item @emph{Cross_Reference}
-
-This package specifies the options used when calling the library tool
-@emph{gnatxref} via the @emph{gnat} driver. Its attributes
-@strong{Default_Switches} and @strong{Switches} have the same semantics as for the
-package @cite{Builder}.
-@end table
-
-
-
-@table @asis
-
-@item @emph{Finder}
-
-This package specifies the options used when calling the search tool
-@emph{gnatfind} via the @emph{gnat} driver. Its attributes
-@strong{Default_Switches} and @strong{Switches} have the same semantics as for the
-package @cite{Builder}.
-
-@item @emph{Gnatls}
-
-This package specifies the options to use when invoking @emph{gnatls}
-via the @emph{gnat} driver.
-@end table
-
-
-
-@table @asis
-
-@item @emph{IDE}
-
-This package specifies the options used when starting an integrated
-development environment, for instance @emph{GPS} or @emph{Gnatbench}.
-
-@item @emph{Install}
-
-This package specifies the options used when installing a project
-with @emph{gprinstall}. See @ref{16b,,Installation}.
-
-@item @emph{Linker}
-
-This package specifies the options used by the linker.
-See @ref{160,,Main Subprograms}.
-@end table
-
-
-
-@table @asis
-
-@item @emph{Naming}
-
-@quotation
-
-This package specifies the naming conventions that apply
-to the source files in a project. In particular, these conventions are
-used to automatically find all source files in the source directories,
-or given a file name to find out its language for proper processing.
-See @ref{14e,,Naming Schemes}.
-@end quotation
-
-
-@item @emph{Remote}
-
-This package is used by @emph{gprbuild} to describe how distributed
-compilation should be done.
-
-@item @emph{Stack}
-
-This package specifies the options used when calling the tool
-@emph{gnatstack} via the @emph{gnat} driver. Its attributes
-@strong{Default_Switches} and @strong{Switches} have the same semantics as for the
-package @cite{Builder}.
-
-@item @emph{Synchronize}
-
-This package specifies the options used when calling the tool
-@emph{gnatsync} via the @emph{gnat} driver.
-@end table
-
-In its simplest form, a package may be empty:
-
-@example
-project Simple is
- package Builder is
- end Builder;
-end Simple;
-@end example
-
-A package may contain @strong{attribute declarations},
-@strong{variable declarations} and @strong{case constructions}, as will be
-described below.
-
-When there is ambiguity between a project name and a package name,
-the name always designates the project. To avoid possible confusion, it is
-always a good idea to avoid naming a project with one of the
-names allowed for packages or any name that starts with @cite{gnat}.
-
-A package can also be defined by a @strong{renaming declaration}. The new package
-renames a package declared in a different project file, and has the same
-attributes as the package it renames. The name of the renamed package
-must be the same as the name of the renaming package. The project must
-contain a package declaration with this name, and the project
-must appear in the context clause of the current project, or be its parent
-project. It is not possible to add or override attributes to the renaming
-project. If you need to do so, you should use an @strong{extending declaration}
-(see below).
-
-Packages that are renamed in other project files often come from project files
-that have no sources: they are just used as templates. Any modification in the
-template will be reflected automatically in all the project files that rename
-a package from the template. This is a very common way to share settings
-between projects.
-
-Finally, a package can also be defined by an @strong{extending declaration}. This is
-similar to a @strong{renaming declaration}, except that it is possible to add or
-override attributes.
-
-@example
-package_declaration ::= package_spec | package_renaming | package_extension
-package_spec ::=
- package <package_>simple_name is
- @{simple_declarative_item@}
- end package_identifier ;
-package_renaming ::==
- package <package_>simple_name renames <project_>simple_name.package_identifier ;
-package_extension ::==
- package <package_>simple_name extends <project_>simple_name.package_identifier is
- @{simple_declarative_item@}
- end package_identifier ;
-@end example
-
-@node Expressions,External Values,Packages,Project File Reference
-@anchor{gnat_ugn/gnat_project_manager expressions}@anchor{19e}@anchor{gnat_ugn/gnat_project_manager id42}@anchor{19f}
-@subsection Expressions
-
-
-An expression is any value that can be assigned to an attribute or a
-variable. It is either a literal value, or a construct requiring runtime
-computation by the project manager. In a project file, the computed value of
-an expression is either a string or a list of strings.
-
-A string value is one of:
-
-
-@itemize *
-
-@item
-A literal string, for instance @cite{"comm/my_proj.gpr"}
-
-@item
-The name of a variable that evaluates to a string (see @ref{158,,Variables})
-
-@item
-The name of an attribute that evaluates to a string (see @ref{155,,Attributes})
-
-@item
-An external reference (see @ref{157,,External Values})
-
-@item
-A concatenation of the above, as in @cite{"prefix_" & Var}.
-@end itemize
-
-A list of strings is one of the following:
-
-
-@itemize *
-
-@item
-A parenthesized comma-separated list of zero or more string expressions, for
-instance @cite{(File_Name@comma{} "gnat.adc"@comma{} File_Name & ".orig")} or @cite{()}.
-
-@item
-The name of a variable that evaluates to a list of strings
-
-@item
-The name of an attribute that evaluates to a list of strings
-
-@item
-A concatenation of a list of strings and a string (as defined above), for
-instance @cite{("A"@comma{} "B") & "C"}
-
-@item
-A concatenation of two lists of strings
-@end itemize
-
-The following is the grammar for expressions
-
-@example
-string_literal ::= "@{string_element@}" -- Same as Ada
-string_expression ::= string_literal
- | *variable_*name
- | external_value
- | attribute_reference
- | ( string_expression @{ & string_expression @} )
-string_list ::= ( string_expression @{ , string_expression @} )
- | *string_variable*_name
- | *string_*attribute_reference
-term ::= string_expression | string_list
-expression ::= term @{ & term @} -- Concatenation
-@end example
-
-Concatenation involves strings and list of strings. As soon as a list of
-strings is involved, the result of the concatenation is a list of strings. The
-following Ada declarations show the existing operators:
-
-@example
-function "&" (X : String; Y : String) return String;
-function "&" (X : String_List; Y : String) return String_List;
-function "&" (X : String_List; Y : String_List) return String_List;
-@end example
-
-Here are some specific examples:
-
-@example
-List := () & File_Name; -- One string in this list
-List2 := List & (File_Name & ".orig"); -- Two strings
-Big_List := List & Lists2; -- Three strings
-Illegal := "gnat.adc" & List2; -- Illegal, must start with list
-@end example
-
-@node External Values,Typed String Declaration,Expressions,Project File Reference
-@anchor{gnat_ugn/gnat_project_manager external-values}@anchor{157}@anchor{gnat_ugn/gnat_project_manager id43}@anchor{1a0}
-@subsection External Values
-
-
-An external value is an expression whose value is obtained from the command
-that invoked the processing of the current project file (typically a
-@emph{gprbuild} command).
-
-There are two kinds of external values, one that returns a single string, and
-one that returns a string list.
-
-The syntax of a single string external value is:
-
-@example
-external_value ::= *external* ( string_literal [, string_literal] )
-@end example
-
-The first string_literal is the string to be used on the command line or
-in the environment to specify the external value. The second string_literal,
-if present, is the default to use if there is no specification for this
-external value either on the command line or in the environment.
-
-Typically, the external value will either exist in the
-environment variables
-or be specified on the command line through the
-@code{-X@emph{vbl}=@emph{value}} switch. If both
-are specified, then the command line value is used, so that a user can more
-easily override the value.
-
-The function @cite{external} always returns a string. It is an error if the
-value was not found in the environment and no default was specified in the
-call to @cite{external}.
-
-An external reference may be part of a string expression or of a string
-list expression, and can therefore appear in a variable declaration or
-an attribute declaration.
-
-Most of the time, this construct is used to initialize typed variables, which
-are then used in @strong{case} constructions to control the value assigned to
-attributes in various scenarios. Thus such variables are often called
-@strong{scenario variables}.
-
-The syntax for a string list external value is:
-
-@example
-external_value ::= *external_as_list* ( string_literal , string_literal )
-@end example
-
-The first string_literal is the string to be used on the command line or
-in the environment to specify the external value. The second string_literal is
-the separator between each component of the string list.
-
-If the external value does not exist in the environment or on the command line,
-the result is an empty list. This is also the case, if the separator is an
-empty string or if the external value is only one separator.
-
-Any separator at the beginning or at the end of the external value is
-discarded. Then, if there is no separator in the external value, the result is
-a string list with only one string. Otherwise, any string between the beginning
-and the first separator, between two consecutive separators and between the
-last separator and the end are components of the string list.
-
-@example
-*external_as_list* ("SWITCHES", ",")
-@end example
-
-If the external value is "-O2,-g",
-the result is ("-O2", "-g").
-
-If the external value is ",-O2,-g,",
-the result is also ("-O2", "-g").
-
-if the external value is "-gnatv",
-the result is ("-gnatv").
-
-If the external value is ",,", the result is ("").
-
-If the external value is ",", the result is (), the empty string list.
-
-@node Typed String Declaration,Variables,External Values,Project File Reference
-@anchor{gnat_ugn/gnat_project_manager id44}@anchor{1a1}@anchor{gnat_ugn/gnat_project_manager typed-string-declaration}@anchor{1a2}
-@subsection Typed String Declaration
-
-
-A @strong{type declaration} introduces a discrete set of string literals.
-If a string variable is declared to have this type, its value
-is restricted to the given set of literals. These are the only named
-types in project files. A string type may only be declared at the project
-level, not inside a package.
-
-@example
-typed_string_declaration ::=
- *type* *<typed_string_>*_simple_name *is* ( string_literal @{, string_literal@} );
-@end example
-
-The string literals in the list are case sensitive and must all be different.
-They may include any graphic characters allowed in Ada, including spaces.
-Here is an example of a string type declaration:
-
-@example
-type OS is ("NT", "nt", "Unix", "GNU/Linux", "other OS");
-@end example
-
-Variables of a string type are called @strong{typed variables}; all other
-variables are called @strong{untyped variables}. Typed variables are
-particularly useful in @cite{case} constructions, to support conditional
-attribute declarations. (See @ref{1a3,,Case Constructions}).
-
-A string type may be referenced by its name if it has been declared in the same
-project file, or by an expanded name whose prefix is the name of the project
-in which it is declared.
-
-@node Variables,Case Constructions,Typed String Declaration,Project File Reference
-@anchor{gnat_ugn/gnat_project_manager variables}@anchor{158}@anchor{gnat_ugn/gnat_project_manager id45}@anchor{1a4}
-@subsection Variables
-
-
-@strong{Variables} store values (strings or list of strings) and can appear
-as part of an expression. The declaration of a variable creates the
-variable and assigns the value of the expression to it. The name of the
-variable is available immediately after the assignment symbol, if you
-need to reuse its old value to compute the new value. Before the completion
-of its first declaration, the value of a variable defaults to the empty
-string ("").
-
-A @strong{typed} variable can be used as part of a @strong{case} expression to
-compute the value, but it can only be declared once in the project file,
-so that all case constructions see the same value for the variable. This
-provides more consistency and makes the project easier to understand.
-The syntax for its declaration is identical to the Ada syntax for an
-object declaration. In effect, a typed variable acts as a constant.
-
-An @strong{untyped} variable can be declared and overridden multiple times
-within the same project. It is declared implicitly through an Ada
-assignment. The first declaration establishes the kind of the variable
-(string or list of strings) and successive declarations must respect
-the initial kind. Assignments are executed in the order in which they
-appear, so the new value replaces the old one and any subsequent reference
-to the variable uses the new value.
-
-A variable may be declared at the project file level, or within a package.
-
-@example
-typed_variable_declaration ::=
- *<typed_variable_>*simple_name : *<typed_string_>*name := string_expression;
-
-variable_declaration ::= *<variable_>*simple_name := expression;
-@end example
-
-Here are some examples of variable declarations:
-
-@example
-This_OS : OS := external ("OS"); -- a typed variable declaration
-That_OS := "GNU/Linux"; -- an untyped variable declaration
-
-Name := "readme.txt";
-Save_Name := Name & ".saved";
-
-Empty_List := ();
-List_With_One_Element := ("-gnaty");
-List_With_Two_Elements := List_With_One_Element & "-gnatg";
-Long_List := ("main.ada", "pack1_.ada", "pack1.ada", "pack2_.ada");
-@end example
-
-A @strong{variable reference} may take several forms:
-
-
-@itemize *
-
-@item
-The simple variable name, for a variable in the current package (if any)
-or in the current project
-
-@item
-An expanded name, whose prefix is a context name.
-@end itemize
-
-A @strong{context} may be one of the following:
-
-
-@itemize *
-
-@item
-The name of an existing package in the current project
-
-@item
-The name of an imported project of the current project
-
-@item
-The name of an ancestor project (i.e., a project extended by the current
-project, either directly or indirectly)
-
-@item
-An expanded name whose prefix is an imported/parent project name, and
-whose selector is a package name in that project.
-@end itemize
-
-@node Case Constructions,Attributes,Variables,Project File Reference
-@anchor{gnat_ugn/gnat_project_manager id46}@anchor{1a5}@anchor{gnat_ugn/gnat_project_manager case-constructions}@anchor{1a3}
-@subsection Case Constructions
-
-
-A @strong{case} construction is used in a project file to effect conditional
-behavior. Through this construction, you can set the value of attributes
-and variables depending on the value previously assigned to a typed
-variable.
-
-All choices in a choice list must be distinct. Unlike Ada, the choice
-lists of all alternatives do not need to include all values of the type.
-An @cite{others} choice must appear last in the list of alternatives.
-
-The syntax of a @cite{case} construction is based on the Ada case construction
-(although the @cite{null} declaration for empty alternatives is optional).
-
-The case expression must be a string variable, either typed or not, whose value
-is often given by an external reference (see @ref{157,,External Values}).
-
-Each alternative starts with the reserved word @cite{when}, either a list of
-literal strings separated by the @cite{"|"} character or the reserved word
-@cite{others}, and the @cite{"=>"} token.
-When the case expression is a typed string variable, each literal string must
-belong to the string type that is the type of the case variable.
-After each @cite{=>}, there are zero or more declarations. The only
-declarations allowed in a case construction are other case constructions,
-attribute declarations and variable declarations. String type declarations and
-package declarations are not allowed. Variable declarations are restricted to
-variables that have already been declared before the case construction.
-
-@example
-case_construction ::=
- *case* *<variable_>*name *is* @{case_item@} *end case* ;
-
-case_item ::=
- *when* discrete_choice_list =>
- @{case_declaration
- | attribute_declaration
- | variable_declaration
- | empty_declaration@}
-
-discrete_choice_list ::= string_literal @{| string_literal@} | *others*
-@end example
-
-Here is a typical example, with a typed string variable:
-
-@example
-project MyProj is
- type OS_Type is ("GNU/Linux", "Unix", "NT", "VMS");
- OS : OS_Type := external ("OS", "GNU/Linux");
-
- package Compiler is
- case OS is
- when "GNU/Linux" | "Unix" =>
- for Switches ("Ada")
- use ("-gnath");
- when "NT" =>
- for Switches ("Ada")
- use ("-gnatP");
- when others =>
- null;
- end case;
- end Compiler;
-end MyProj;
-@end example
-
-@node Attributes,,Case Constructions,Project File Reference
-@anchor{gnat_ugn/gnat_project_manager id47}@anchor{1a6}@anchor{gnat_ugn/gnat_project_manager attributes}@anchor{155}
-@subsection Attributes
-
-
-A project (and its packages) may have @strong{attributes} that define
-the project's properties. Some attributes have values that are strings;
-others have values that are string lists.
-
-@example
-attribute_declaration ::=
- simple_attribute_declaration | indexed_attribute_declaration
-
-simple_attribute_declaration ::= *for* attribute_designator *use* expression ;
-
-indexed_attribute_declaration ::=
- *for* *<indexed_attribute_>*simple_name ( string_literal) *use* expression ;
-
-attribute_designator ::=
- *<simple_attribute_>*simple_name
- | *<indexed_attribute_>*simple_name ( string_literal )
-@end example
-
-There are two categories of attributes: @strong{simple attributes}
-and @strong{indexed attributes}.
-Each simple attribute has a default value: the empty string (for string
-attributes) and the empty list (for string list attributes).
-An attribute declaration defines a new value for an attribute, and overrides
-the previous value. The syntax of a simple attribute declaration is similar to
-that of an attribute definition clause in Ada.
-
-Some attributes are indexed. These attributes are mappings whose
-domain is a set of strings. They are declared one association
-at a time, by specifying a point in the domain and the corresponding image
-of the attribute.
-Like untyped variables and simple attributes, indexed attributes
-may be declared several times. Each declaration supplies a new value for the
-attribute, and replaces the previous setting.
-
-Here are some examples of attribute declarations:
-
-@example
--- simple attributes
-for Object_Dir use "objects";
-for Source_Dirs use ("units", "test/drivers");
-
--- indexed attributes
-for Body ("main") use "Main.ada";
-for Switches ("main.ada")
- use ("-v", "-gnatv");
-for Switches ("main.ada") use Builder'Switches ("main.ada") & "-g";
-
--- indexed attributes copy (from package Builder in project Default)
--- The package name must always be specified, even if it is the current
--- package.
-for Default_Switches use Default.Builder'Default_Switches;
-@end example
-
-Attributes references may appear anywhere in expressions, and are used
-to retrieve the value previously assigned to the attribute. If an attribute
-has not been set in a given package or project, its value defaults to the
-empty string or the empty list, with some exceptions.
-
-@example
-attribute_reference ::=
- attribute_prefix ' *<simple_attribute>_*simple_name [ (string_literal) ]
-attribute_prefix ::= *project*
- | *<project_>*simple_name
- | package_identifier
- | *<project_>*simple_name . package_identifier
-@end example
-
-Examples are:
-
-@example
-<project>'Object_Dir
-Naming'Dot_Replacement
-Imported_Project'Source_Dirs
-Imported_Project.Naming'Casing
-Builder'Default_Switches ("Ada")
-@end example
-
-The exceptions to the empty defaults are:
-
-
-@itemize *
-
-@item
-Object_Dir: default is "."
-
-@item
-Exec_Dir: default is 'Object_Dir, that is the value of attribute
-Object_Dir in the same project, declared or defaulted.
-
-@item
-Source_Dirs: default is (".")
-@end itemize
-
-The prefix of an attribute may be:
-
-
-@itemize *
-
-@item
-@cite{project} for an attribute of the current project
-
-@item
-The name of an existing package of the current project
-
-@item
-The name of an imported project
-
-@item
-The name of a parent project that is extended by the current project
-
-@item
-An expanded name whose prefix is imported/parent project name,
-and whose selector is a package name
-@end itemize
-
-In the following sections, all predefined attributes are succinctly described,
-first the project level attributes, that is those attributes that are not in a
-package, then the attributes in the different packages.
-
-It is possible for different tools to dynamically create new packages with
-attributes, or new attributes in predefined packages. These attributes are
-not documented here.
-
-The attributes under Configuration headings are usually found only in
-configuration project files.
-
-The characteristics of each attribute are indicated as follows:
-
-
-@itemize *
-
-@item
-@strong{Type of value}
-
-The value of an attribute may be a single string, indicated by the word
-"single", or a string list, indicated by the word "list".
-
-@item
-@strong{Read-only}
-
-When the attribute is read-only, that is when it is not allowed to declare
-the attribute, this is indicated by the words "read-only".
-
-@item
-@strong{Optional index}
-
-If it is allowed in the value of the attribute (both single and list) to have
-an optional index, this is indicated by the words "optional index".
-
-@item
-@strong{Indexed attribute}
-
-When it is an indexed attribute, this is indicated by the word "indexed".
-
-@item
-@strong{Case-sensitivity of the index}
-
-For an indexed attribute, if the index is case-insensitive, this is indicated
-by the words "case-insensitive index".
-
-@item
-@strong{File name index}
-
-For an indexed attribute, when the index is a file name, this is indicated by
-the words "file name index". The index may or may not be case-sensitive,
-depending on the platform.
-
-@item
-@strong{others allowed in index}
-
-For an indexed attribute, if it is allowed to use @strong{others} as the index,
-this is indicated by the words "others allowed".
-
-When @strong{others} is used as the index of an indexed attribute, the value of
-the attribute indexed by @strong{others} is used when no other index would apply.
-@end itemize
-
-@menu
-* Project Level Attributes::
-* Package Binder Attributes::
-* Package Builder Attributes::
-* Package Clean Attributes::
-* Package Compiler Attributes::
-* Package Cross_Reference Attributes::
-* Package Finder Attributes::
-* Package gnatls Attributes::
-* Package IDE Attributes::
-* Package Install Attributes::
-* Package Linker Attributes::
-* Package Naming Attributes::
-* Package Remote Attributes::
-* Package Stack Attributes::
-* Package Synchronize Attributes::
-
-@end menu
-
-@node Project Level Attributes,Package Binder Attributes,,Attributes
-@anchor{gnat_ugn/gnat_project_manager project-level-attributes}@anchor{1a7}@anchor{gnat_ugn/gnat_project_manager id48}@anchor{1a8}
-@subsubsection Project Level Attributes
-
-
-
-@itemize *
-
-@item
-@strong{General}
-
-
-@itemize *
-
-@item
-@strong{Name}: single, read-only
-
-The name of the project.
-
-@item
-@strong{Project_Dir}: single, read-only
-
-The path name of the project directory.
-
-@item
-@strong{Main}: list, optional index
-
-The list of main sources for the executables.
-
-@item
-@strong{Languages}: list
-
-The list of languages of the sources of the project.
-
-@item
-@strong{Roots}: list, indexed, file name index
-
-The index is the file name of an executable source. Indicates the list of units
-from the main project that need to be bound and linked with their closures
-with the executable. The index is either a file name, a language name or "*".
-The roots for an executable source are those in @strong{Roots} with an index that
-is the executable source file name, if declared. Otherwise, they are those in
-@strong{Roots} with an index that is the language name of the executable source,
-if present. Otherwise, they are those in @strong{Roots ("*")}, if declared. If none
-of these three possibilities are declared, then there are no roots for the
-executable source.
-
-@item
-@strong{Externally_Built}: single
-
-Indicates if the project is externally built.
-Only case-insensitive values allowed are "true" and "false", the default.
-@end itemize
-
-@item
-@strong{Directories}
-
-
-@itemize *
-
-@item
-@strong{Object_Dir}: single
-
-Indicates the object directory for the project.
-
-@item
-@strong{Exec_Dir}: single
-
-Indicates the exec directory for the project, that is the directory where the
-executables are.
-
-@item
-@strong{Source_Dirs}: list
-
-The list of source directories of the project.
-
-@item
-@strong{Inherit_Source_Path}: list, indexed, case-insensitive index
-
-Index is a language name. Value is a list of language names. Indicates that
-in the source search path of the index language the source directories of
-the languages in the list should be included.
-
-Example:
-
-@example
-for Inherit_Source_Path ("C++") use ("C");
-@end example
-
-@item
-@strong{Exclude_Source_Dirs}: list
-
-The list of directories that are included in Source_Dirs but are not source
-directories of the project.
-
-@item
-@strong{Ignore_Source_Sub_Dirs}: list
-
-Value is a list of simple names for subdirectories that are removed from the
-list of source directories, including theur subdirectories.
-@end itemize
-
-@item
-@strong{Source Files}
-
-
-@itemize *
-
-@item
-@strong{Source_Files}: list
-
-Value is a list of source file simple names.
-
-@item
-@strong{Locally_Removed_Files}: list
-
-Obsolescent. Equivalent to Excluded_Source_Files.
-
-@item
-@strong{Excluded_Source_Files}: list
-
-Value is a list of simple file names that are not sources of the project.
-Allows to remove sources that are inherited or found in the source directories
-and that match the naming scheme.
-
-@item
-@strong{Source_List_File}: single
-
-Value is a text file name that contains a list of source file simple names,
-one on each line.
-
-@item
-@strong{Excluded_Source_List_File}: single
-
-Value is a text file name that contains a list of file simple names that
-are not sources of the project.
-
-@item
-@strong{Interfaces}: list
-
-Value is a list of file names that constitutes the interfaces of the project.
-@end itemize
-
-@item
-@strong{Aggregate Projects}
-
-
-@itemize *
-
-@item
-@strong{Project_Files}: list
-
-Value is the list of aggregated projects.
-
-@item
-@strong{Project_Path}: list
-
-Value is a list of directories that are added to the project search path when
-looking for the aggregated projects.
-
-@item
-@strong{External}: single, indexed
-
-Index is the name of an external reference. Value is the value of the
-external reference to be used when parsing the aggregated projects.
-@end itemize
-
-@item
-@strong{Libraries}
-
-
-@itemize *
-
-@item
-@strong{Library_Dir}: single
-
-Value is the name of the library directory. This attribute needs to be
-declared for each library project.
-
-@item
-@strong{Library_Name}: single
-
-Value is the name of the library. This attribute needs to be declared or
-inherited for each library project.
-
-@item
-@strong{Library_Kind}: single
-
-Specifies the kind of library: static library (archive) or shared library.
-Case-insensitive values must be one of "static" for archives (the default) or
-"dynamic" or "relocatable" for shared libraries.
-
-@item
-@strong{Library_Version}: single
-
-Value is the name of the library file.
-
-@item
-@strong{Library_Interface}: list
-
-Value is the list of unit names that constitutes the interfaces
-of a Stand-Alone Library project.
-
-@item
-@strong{Library_Standalone}: single
-
-Specifies if a Stand-Alone Library (SAL) is encapsulated or not.
-Only authorized case-insensitive values are "standard" for non encapsulated
-SALs, "encapsulated" for encapsulated SALs or "no" for non SAL library project.
-
-@item
-@strong{Library_Encapsulated_Options}: list
-
-Value is a list of options that need to be used when linking an encapsulated
-Stand-Alone Library.
-
-@item
-@strong{Library_Encapsulated_Supported}: single
-
-Indicates if encapsulated Stand-Alone Libraries are supported. Only
-authorized case-insensitive values are "true" and "false" (the default).
-
-@item
-@strong{Library_Auto_Init}: single
-
-Indicates if a Stand-Alone Library is auto-initialized. Only authorized
-case-insentive values are "true" and "false".
-
-@item
-@strong{Leading_Library_Options}: list
-
-Value is a list of options that are to be used at the beginning of
-the command line when linking a shared library.
-
-@item
-@strong{Library_Options}: list
-
-Value is a list of options that are to be used when linking a shared library.
-
-@item
-@strong{Library_Rpath_Options}: list, indexed, case-insensitive index
-
-Index is a language name. Value is a list of options for an invocation of the
-compiler of the language. This invocation is done for a shared library project
-with sources of the language. The output of the invocation is the path name
-of a shared library file. The directory name is to be put in the run path
-option switch when linking the shared library for the project.
-
-@item
-@strong{Library_Src_Dir}: single
-
-Value is the name of the directory where copies of the sources of the
-interfaces of a Stand-Alone Library are to be copied.
-
-@item
-@strong{Library_ALI_Dir}: single
-
-Value is the name of the directory where the ALI files of the interfaces
-of a Stand-Alone Library are to be copied. When this attribute is not declared,
-the directory is the library directory.
-
-@item
-@strong{Library_gcc}: single
-
-Obsolescent attribute. Specify the linker driver used to link a shared library.
-Use instead attribute Linker'Driver.
-
-@item
-@strong{Library_Symbol_File}: single
-
-Value is the name of the library symbol file.
-
-@item
-@strong{Library_Symbol_Policy}: single
-
-Indicates the symbol policy kind. Only authorized case-insensitive values are
-"autonomous", "default", "compliant", "controlled" or "direct".
-
-@item
-@strong{Library_Reference_Symbol_File}: single
-
-Value is the name of the reference symbol file.
-@end itemize
-
-@item
-@strong{Configuration - General}
-
-
-@itemize *
-
-@item
-@strong{Default_Language}: single
-
-Value is the case-insensitive name of the language of a project when attribute
-Languages is not specified.
-
-@item
-@strong{Run_Path_Option}: list
-
-Value is the list of switches to be used when specifying the run path option
-in an executable.
-
-@item
-@strong{Run_Path_Origin}: single
-
-Value is the the string that may replace the path name of the executable
-directory in the run path options.
-
-@item
-@strong{Separate_Run_Path_Options}: single
-
-Indicates if there may be several run path options specified when linking an
-executable. Only authorized case-insensitive values are "true" or "false" (the
-default).
-
-@item
-@strong{Toolchain_Version}: single, indexed, case-insensitive index
-
-Index is a language name. Specify the version of a toolchain for a language.
-
-@item
-@strong{Toolchain_Description}: single, indexed, case-insensitive index
-
-Obsolescent. No longer used.
-
-@item
-@strong{Object_Generated}: single, indexed, case-insensitive index
-
-Index is a language name. Indicates if invoking the compiler for a language
-produces an object file. Only authorized case-insensitive values are "false"
-and "true" (the default).
-
-@item
-@strong{Objects_Linked}: single, indexed, case-insensitive index
-
-Index is a language name. Indicates if the object files created by the compiler
-for a language need to be linked in the executable. Only authorized
-case-insensitive values are "false" and "true" (the default).
-
-@item
-@strong{Target}: single
-
-Value is the name of the target platform. Taken into account only in the main
-project.
-
-Note that when the target is specified on the command line (usually with
-a switch --target=), the value of attribute reference 'Target is the one
-specified on the command line.
-
-@item
-@strong{Runtime}: single, indexed, case-insensitive index
-
-Index is a language name. Indicates the runtime directory that is to be used
-when using the compiler of the language. Taken into account only in the main
-project.
-
-Note that when the runtime is specified for a language on the command line
-(usually with a switch --RTS), the value of attribute reference 'Runtime
-for this language is the one specified on the command line.
-@end itemize
-
-@item
-@strong{Configuration - Libraries}
-
-
-@itemize *
-
-@item
-@strong{Library_Builder}: single
-
-Value is the path name of the application that is to be used to build
-libraries. Usually the path name of "gprlib".
-
-@item
-@strong{Library_Support}: single
-
-Indicates the level of support of libraries. Only authorized case-insensitive
-values are "static_only", "full" or "none" (the default).
-@end itemize
-
-@item
-@strong{Configuration - Archives}
-
-
-@itemize *
-
-@item
-@strong{Archive_Builder}: list
-
-Value is the name of the application to be used to create a static library
-(archive), followed by the options to be used.
-
-@item
-@strong{Archive_Builder_Append_Option}: list
-
-Value is the list of options to be used when invoking the archive builder
-to add project files into an archive.
-
-@item
-@strong{Archive_Indexer}: list
-
-Value is the name of the archive indexer, followed by the required options.
-
-@item
-@strong{Archive_Suffix}: single
-
-Value is the extension of archives. When not declared, the extension is ".a".
-
-@item
-@strong{Library_Partial_Linker}: list
-
-Value is the name of the partial linker executable, followed by the required
-options.
-@end itemize
-
-@item
-@strong{Configuration - Shared Libraries}
-
-
-@itemize *
-
-@item
-@strong{Shared_Library_Prefix}: single
-
-Value is the prefix in the name of shared library files. When not declared,
-the prefix is "lib".
-
-@item
-@strong{Shared_Library_Suffix}: single
-
-Value is the the extension of the name of shared library files. When not
-declared, the extension is ".so".
-
-@item
-@strong{Symbolic_Link_Supported}: single
-
-Indicates if symbolic links are supported on the platform. Only authorized
-case-insensitive values are "true" and "false" (the default).
-
-@item
-@strong{Library_Major_Minor_Id_Supported}: single
-
-Indicates if major and minor ids for shared library names are supported on
-the platform. Only authorized case-insensitive values are "true" and "false"
-(the default).
-
-@item
-@strong{Library_Auto_Init_Supported}: single
-
-Indicates if auto-initialization of Stand-Alone Libraries is supported. Only
-authorized case-insensitive values are "true" and "false" (the default).
-
-@item
-@strong{Shared_Library_Minimum_Switches}: list
-
-Value is the list of required switches when linking a shared library.
-
-@item
-@strong{Library_Version_Switches}: list
-
-Value is the list of switches to specify a internal name for a shared library.
-
-@item
-@strong{Library_Install_Name_Option}: single
-
-Value is the name of the option that needs to be used, concatenated with the
-path name of the library file, when linking a shared library.
-
-@item
-@strong{Runtime_Library_Dir}: single, indexed, case-insensitive index
-
-Index is a language name. Value is the path name of the directory where the
-runtime libraries are located.
-
-@item
-@strong{Runtime_Source_Dir}: single, indexed, case-insensitive index
-
-Index is a language name. Value is the path name of the directory where the
-sources of runtime libraries are located.
-@end itemize
-@end itemize
-
-@node Package Binder Attributes,Package Builder Attributes,Project Level Attributes,Attributes
-@anchor{gnat_ugn/gnat_project_manager package-binder-attributes}@anchor{1a9}@anchor{gnat_ugn/gnat_project_manager id49}@anchor{1aa}
-@subsubsection Package Binder Attributes
-
-
-
-@itemize *
-
-@item
-@strong{General}
-
-
-@itemize *
-
-@item
-@strong{Default_Switches}: list, indexed, case-insensitive index
-
-Index is a language name. Value is the list of switches to be used when binding
-code of the language, if there is no applicable attribute Switches.
-
-@item
-@strong{Switches}: list, optional index, indexed,
-case-insensitive index, others allowed
-
-Index is either a language name or a source file name. Value is the list of
-switches to be used when binding code. Index is either the source file name
-of the executable to be bound or the language name of the code to be bound.
-@end itemize
-
-@item
-@strong{Configuration - Binding}
-
-
-@itemize *
-
-@item
-@strong{Driver}: single, indexed, case-insensitive index
-
-Index is a language name. Value is the name of the application to be used when
-binding code of the language.
-
-@item
-@strong{Required_Switches}: list, indexed, case-insensitive index
-
-Index is a language name. Value is the list of the required switches to be
-used when binding code of the language.
-
-@item
-@strong{Prefix}: single, indexed, case-insensitive index
-
-Index is a language name. Value is a prefix to be used for the binder exchange
-file name for the language. Used to have different binder exchange file names
-when binding different languages.
-
-@item
-@strong{Objects_Path}: single,indexed, case-insensitive index
-
-Index is a language name. Value is the name of the environment variable that
-contains the path for the object directories.
-
-@item
-@strong{Object_Path_File}: single,indexed, case-insensitive index
-
-Index is a language name. Value is the name of the environment variable. The
-value of the environment variable is the path name of a text file that
-contains the list of object directories.
-@end itemize
-@end itemize
-
-@node Package Builder Attributes,Package Clean Attributes,Package Binder Attributes,Attributes
-@anchor{gnat_ugn/gnat_project_manager package-builder-attributes}@anchor{1ab}@anchor{gnat_ugn/gnat_project_manager id50}@anchor{1ac}
-@subsubsection Package Builder Attributes
-
-
-
-@itemize *
-
-@item
-@strong{Default_Switches}: list, indexed, case-insensitive index
-
-Index is a language name. Value is the list of builder switches to be used when
-building an executable of the language, if there is no applicable attribute
-Switches.
-
-@item
-@strong{Switches}: list, optional index, indexed, case-insensitive index,
-others allowed
-
-Index is either a language name or a source file name. Value is the list of
-builder switches to be used when building an executable. Index is either the
-source file name of the executable to be built or its language name.
-
-@item
-@strong{Global_Compilation_Switches}: list, optional index, indexed,
-case-insensitive index
-
-Index is either a language name or a source file name. Value is the list of
-compilation switches to be used when building an executable. Index is either
-the source file name of the executable to be built or its language name.
-
-@item
-@strong{Executable}: single, indexed, case-insensitive index
-
-Index is an executable source file name. Value is the simple file name of the
-executable to be built.
-
-@item
-@strong{Executable_Suffix}: single
-
-Value is the extension of the file names of executable. When not specified,
-the extension is the default extension of executables on the platform.
-
-@item
-@strong{Global_Configuration_Pragmas}: single
-
-Value is the file name of a configuration pragmas file that is specified to
-the Ada compiler when compiling any Ada source in the project tree.
-
-@item
-@strong{Global_Config_File}: single, indexed, case-insensitive index
-
-Index is a language name. Value is the file name of a configuration file that
-is specified to the compiler when compiling any source of the language in the
-project tree.
-@end itemize
-
-
-@node Package Clean Attributes,Package Compiler Attributes,Package Builder Attributes,Attributes
-@anchor{gnat_ugn/gnat_project_manager package-clean-attributes}@anchor{1ad}@anchor{gnat_ugn/gnat_project_manager id52}@anchor{1ae}
-@subsubsection Package Clean Attributes
-
-
-
-@itemize *
-
-@item
-@strong{Switches}: list
-
-Value is a list of switches to be used by the cleaning application.
-
-@item
-@strong{Source_Artifact_Extensions}: list, indexed, case-insensitive index
-
-Index is a language names. Value is the list of extensions for file names
-derived from object file names that need to be cleaned in the object
-directory of the project.
-
-@item
-@strong{Object_Artifact_Extensions}: list, indexed, case-insensitive index
-
-Index is a language names. Value is the list of extensions for file names
-derived from source file names that need to be cleaned in the object
-directory of the project.
-
-@item
-@strong{Artifacts_In_Object_Dir}: single
-
-Value is a list of file names expressed as regular expressions that are to be
-deleted by gprclean in the object directory of the project.
-
-@item
-@strong{Artifacts_In_Exec_Dir}: single
-
-Value is list of file names expressed as regular expressions that are to be
-deleted by gprclean in the exec directory of the main project.
-@end itemize
-
-@node Package Compiler Attributes,Package Cross_Reference Attributes,Package Clean Attributes,Attributes
-@anchor{gnat_ugn/gnat_project_manager id53}@anchor{1af}@anchor{gnat_ugn/gnat_project_manager package-compiler-attributes}@anchor{1b0}
-@subsubsection Package Compiler Attributes
-
-
-
-@itemize *
-
-@item
-@strong{General}
-
-
-@itemize *
-
-@item
-@strong{Default_Switches}: list, indexed, case-insensitive index
-
-Index is a language name. Value is a list of switches to be used when invoking
-the compiler for the language for a source of the project, if there is no
-applicable attribute Switches.
-
-@item
-@strong{Switches}: list, optional index, indexed, case-insensitive index,
-others allowed
-
-Index is a source file name or a language name. Value is the list of switches
-to be used when invoking the compiler for the source or for its language.
-
-@item
-@strong{Local_Configuration_Pragmas}: single
-
-Value is the file name of a configuration pragmas file that is specified to
-the Ada compiler when compiling any Ada source in the project.
-
-@item
-@strong{Local_Config_File}: single, indexed, case-insensitive index
-
-Index is a language name. Value is the file name of a configuration file that
-is specified to the compiler when compiling any source of the language in the
-project.
-@end itemize
-
-@item
-@strong{Configuration - Compiling}
-
-
-@itemize *
-
-@item
-@strong{Driver}: single, indexed, case-insensitive index
-
-Index is a language name. Value is the name of the executable for the compiler
-of the language.
-
-@item
-@strong{Language_Kind}: single, indexed, case-insensitive index
-
-Index is a language name. Indicates the kind of the language, either file based
-or unit based. Only authorized case-insensitive values are "unit_based" and
-"file_based" (the default).
-
-@item
-@strong{Dependency_Kind}: single, indexed, case-insensitive index
-
-Index is a language name. Indicates how the dependencies are handled for the
-language. Only authorized case-insensitive values are "makefile", "ali_file",
-"ali_closure" or "none" (the default).
-
-@item
-@strong{Required_Switches}: list, indexed, case-insensitive index
-
-Equivalent to attribute Leading_Required_Switches.
-
-@item
-@strong{Leading_Required_Switches}: list, indexed, case-insensitive index
-
-Index is a language name. Value is the list of the minimum switches to be used
-at the beginning of the command line when invoking the compiler for the
-language.
-
-@item
-@strong{Trailing_Required_Switches}: list, indexed, case-insensitive index
-
-Index is a language name. Value is the list of the minimum switches to be used
-at the end of the command line when invoking the compiler for the language.
-
-@item
-@strong{PIC_Option}: list, indexed, case-insensitive index
-
-Index is a language name. Value is the list of switches to be used when
-compiling a source of the language when the project is a shared library
-project.
-
-@item
-@strong{Path_Syntax}: single, indexed, case-insensitive index
-
-Index is a language name. Value is the kind of path syntax to be used when
-invoking the compiler for the language. Only authorized case-insensitive
-values are "canonical" and "host" (the default).
-
-@item
-@strong{Source_File_Switches}: single, indexed, case-insensitive index
-
-Index is a language name. Value is a list of switches to be used just before
-the path name of the source to compile when invoking the compiler for a source
-of the language.
-
-@item
-@strong{Object_File_Suffix}: single, indexed, case-insensitive index
-
-Index is a language name. Value is the extension of the object files created
-by the compiler of the language. When not specified, the extension is the
-default one for the platform.
-
-@item
-@strong{Object_File_Switches}: list, indexed, case-insensitive index
-
-Index is a language name. Value is the list of switches to be used by the
-compiler of the language to specify the path name of the object file. When not
-specified, the switch used is "-o".
-
-@item
-@strong{Multi_Unit_Switches}: list, indexed, case-insensitive index
-
-Index is a language name. Value is the list of switches to be used to compile
-a unit in a multi unit source of the language. The index of the unit in the
-source is concatenated with the last switches in the list.
-
-@item
-@strong{Multi_Unit_Object_Separator}: single, indexed, case-insensitive index
-
-Index is a language name. Value is the string to be used in the object file
-name before the index of the unit, when compiling a unit in a multi unit source
-of the language.
-@end itemize
-
-@item
-@strong{Configuration - Mapping Files}
-
-
-@itemize *
-
-@item
-@strong{Mapping_File_Switches}: list, indexed, case-insensitive index
-
-Index is a language name. Value is the list of switches to be used to specify
-a mapping file when invoking the compiler for a source of the language.
-
-@item
-@strong{Mapping_Spec_Suffix}: single, indexed, case-insensitive index
-
-Index is a language name. Value is the suffix to be used in a mapping file
-to indicate that the source is a spec.
-
-@item
-@strong{Mapping_Body_Suffix}: single, indexed, case-insensitive index
-
-Index is a language name. Value is the suffix to be used in a mapping file
-to indicate that the source is a body.
-@end itemize
-
-@item
-@strong{Configuration - Config Files}
-
-
-@itemize *
-
-@item
-@strong{Config_File_Switches}: list: single, indexed, case-insensitive index
-
-Index is a language name. Value is the list of switches to specify to the
-compiler of the language a configuration file.
-
-@item
-@strong{Config_Body_File_Name}: single, indexed, case-insensitive index
-
-Index is a language name. Value is the template to be used to indicate a
-configuration specific to a body of the language in a configuration
-file.
-
-@item
-@strong{Config_Body_File_Name_Index}: single, indexed, case-insensitive index
-
-Index is a language name. Value is the template to be used to indicate a
-configuration specific to the body a unit in a multi unit source of the
-language in a configuration file.
-
-@item
-@strong{Config_Body_File_Name_Pattern}: single, indexed,
-case-insensitive index
-
-Index is a language name. Value is the template to be used to indicate a
-configuration for all bodies of the languages in a configuration file.
-
-@item
-@strong{Config_Spec_File_Name}: single, indexed, case-insensitive index
-
-Index is a language name. Value is the template to be used to indicate a
-configuration specific to a spec of the language in a configuration
-file.
-
-@item
-@strong{Config_Spec_File_Name_Index}: single, indexed, case-insensitive index
-
-Index is a language name. Value is the template to be used to indicate a
-configuration specific to the spec a unit in a multi unit source of the
-language in a configuration file.
-
-@item
-@strong{Config_Spec_File_Name_Pattern}: single, indexed,
-case-insensitive index
-
-Index is a language name. Value is the template to be used to indicate a
-configuration for all specs of the languages in a configuration file.
-
-@item
-@strong{Config_File_Unique}: single, indexed, case-insensitive index
-
-Index is a language name. Indicates if there should be only one configuration
-file specified to the compiler of the language. Only authorized
-case-insensitive values are "true" and "false" (the default).
-@end itemize
-
-@item
-@strong{Configuration - Dependencies}
-
-
-@itemize *
-
-@item
-@strong{Dependency_Switches}: list, indexed, case-insensitive index
-
-Index is a language name. Value is the list of switches to be used to specify
-to the compiler the dependency file when the dependency kind of the language is
-file based, and when Dependency_Driver is not specified for the language.
-
-@item
-@strong{Dependency_Driver}: list, indexed, case-insensitive index
-
-Index is a language name. Value is the name of the executable to be used to
-create the dependency file for a source of the language, followed by the
-required switches.
-@end itemize
-
-@item
-@strong{Configuration - Search Paths}
-
-
-@itemize *
-
-@item
-@strong{Include_Switches}: list, indexed, case-insensitive index
-
-Index is a language name. Value is the list of switches to specify to the
-compiler of the language to indicate a directory to look for sources.
-
-@item
-@strong{Include_Path}: single, indexed, case-insensitive index
-
-Index is a language name. Value is the name of an environment variable that
-contains the path of all the directories that the compiler of the language
-may search for sources.
-
-@item
-@strong{Include_Path_File}: single, indexed, case-insensitive index
-
-Index is a language name. Value is the name of an environment variable the
-value of which is the path name of a text file that contains the directories
-that the compiler of the language may search for sources.
-
-@item
-@strong{Object_Path_Switches}: list, indexed, case-insensitive index
-
-Index is a language name. Value is the list of switches to specify to the
-compiler of the language the name of a text file that contains the list of
-object directories. When this attribute is not declared, the text file is
-not created.
-@end itemize
-@end itemize
-
-@node Package Cross_Reference Attributes,Package Finder Attributes,Package Compiler Attributes,Attributes
-@anchor{gnat_ugn/gnat_project_manager id54}@anchor{1b1}@anchor{gnat_ugn/gnat_project_manager package-cross-reference-attributes}@anchor{1b2}
-@subsubsection Package Cross_Reference Attributes
-
-
-
-@itemize *
-
-@item
-@strong{Default_Switches}: list, indexed, case-insensitive index
-
-Index is a language name. Value is a list of switches to be used when invoking
-@cite{gnatxref} for a source of the language, if there is no applicable
-attribute Switches.
-
-@item
-@strong{Switches}: list, optional index, indexed, case-insensitive index,
-others allowed
-
-Index is a source file name. Value is the list of switches to be used when
-invoking @cite{gnatxref} for the source.
-@end itemize
-
-
-@node Package Finder Attributes,Package gnatls Attributes,Package Cross_Reference Attributes,Attributes
-@anchor{gnat_ugn/gnat_project_manager id56}@anchor{1b3}@anchor{gnat_ugn/gnat_project_manager package-finder-attributes}@anchor{1b4}
-@subsubsection Package Finder Attributes
-
-
-
-@itemize *
-
-@item
-@strong{Default_Switches}: list, indexed, case-insensitive index
-
-Index is a language name. Value is a list of switches to be used when invoking
-@cite{gnatfind} for a source of the language, if there is no applicable
-attribute Switches.
-
-@item
-@strong{Switches}: list, optional index, indexed, case-insensitive index,
-others allowed
-
-Index is a source file name. Value is the list of switches to be used when
-invoking @cite{gnatfind} for the source.
-@end itemize
-
-@node Package gnatls Attributes,Package IDE Attributes,Package Finder Attributes,Attributes
-@anchor{gnat_ugn/gnat_project_manager package-gnatls-attributes}@anchor{1b5}@anchor{gnat_ugn/gnat_project_manager id57}@anchor{1b6}
-@subsubsection Package gnatls Attributes
-
-
-
-@itemize *
-
-@item
-@strong{Switches}: list
-
-Value is a list of switches to be used when invoking @cite{gnatls}.
-@end itemize
-
-
-@node Package IDE Attributes,Package Install Attributes,Package gnatls Attributes,Attributes
-@anchor{gnat_ugn/gnat_project_manager id58}@anchor{1b7}@anchor{gnat_ugn/gnat_project_manager package-ide-attributes}@anchor{1b8}
-@subsubsection Package IDE Attributes
-
-
-
-@itemize *
-
-@item
-@strong{Default_Switches}: list, indexed
-
-Index is the name of an external tool that the GNAT Programming System (GPS)
-is supporting. Value is a list of switches to use when invoking that tool.
-
-@item
-@strong{Remote_Host}: single
-
-Value is a string that designates the remote host in a cross-compilation
-environment, to be used for remote compilation and debugging. This attribute
-should not be specified when running on the local machine.
-
-@item
-@strong{Program_Host}: single
-
-Value is a string that specifies the name of IP address of the embedded target
-in a cross-compilation environment, on which the program should execute.
-
-@item
-@strong{Communication_Protocol}: single
-
-Value is the name of the protocol to use to communicate with the target
-in a cross-compilation environment, for example @cite{"wtx"} or
-@cite{"vxworks"}.
-
-@item
-@strong{Compiler_Command}: single, indexed, case-insensitive index
-
-Index is a language Name. Value is a string that denotes the command to be
-used to invoke the compiler. For historical reasons, the value of
-@cite{Compiler_Command ("Ada")} is expected to be a reference to @emph{gnatmake} or
-@emph{cross-gnatmake}.
-
-@item
-@strong{Debugger_Command}: single
-
-Value is a string that specifies the name of the debugger to be used, such as
-gdb, powerpc-wrs-vxworks-gdb or gdb-4.
-
-@item
-@strong{gnatlist}: single
-
-Value is a string that specifies the name of the @emph{gnatls} utility
-to be used to retrieve information about the predefined path; for example,
-@cite{"gnatls"}, @cite{"powerpc-wrs-vxworks-gnatls"}.
-
-@item
-@strong{VCS_Kind}: single
-
-Value is a string used to specify the Version Control System (VCS) to be used
-for this project, for example "Subversion", "ClearCase". If the
-value is set to "Auto", the IDE will try to detect the actual VCS used
-on the list of supported ones.
-
-@item
-@strong{VCS_File_Check}: single
-
-Value is a string that specifies the command used by the VCS to check
-the validity of a file, either when the user explicitly asks for a check,
-or as a sanity check before doing the check-in.
-
-@item
-@strong{VCS_Log_Check}: single
-
-Value is a string that specifies the command used by the VCS to check
-the validity of a log file.
-
-@item
-@strong{Documentation_Dir}: single
-
-Value is the directory used to generate the documentation of source code.
-@end itemize
-
-@node Package Install Attributes,Package Linker Attributes,Package IDE Attributes,Attributes
-@anchor{gnat_ugn/gnat_project_manager package-install-attributes}@anchor{1b9}@anchor{gnat_ugn/gnat_project_manager id59}@anchor{1ba}
-@subsubsection Package Install Attributes
-
-
-
-@itemize *
-
-@item
-@strong{Artifacts}: list, indexed
-
-An array attribute to declare a set of files not part of the sources
-to be installed. The array discriminant is the directory where the
-file is to be installed. If a relative directory then Prefix (see
-below) is prepended. Note also that if the same file name occurs
-multiple time in the attribute list, the last one will be the one
-installed.
-
-@item
-@strong{Prefix}: single
-
-Value is the install destination directory.
-
-@item
-@strong{Sources_Subdir}: single
-
-Value is the sources directory or subdirectory of Prefix.
-
-@item
-@strong{Exec_Subdir}: single
-
-Value is the executables directory or subdirectory of Prefix.
-
-@item
-@strong{Lib_Subdir}: single
-
-Value is library directory or subdirectory of Prefix.
-
-@item
-@strong{Project_Subdir}: single
-
-Value is the project directory or subdirectory of Prefix.
-
-@item
-@strong{Active}: single
-
-Indicates that the project is to be installed or not. Case-insensitive value
-"false" means that the project is not to be installed, all other values mean
-that the project is to be installed.
-
-@item
-@strong{Mode}: single
-
-Value is the installation mode, it is either @strong{dev} (default) or @strong{usage}.
-
-@item
-@strong{Install_Name}: single
-
-Specify the name to use for recording the installation. The default is
-the project name without the extension.
-@end itemize
-
-@node Package Linker Attributes,Package Naming Attributes,Package Install Attributes,Attributes
-@anchor{gnat_ugn/gnat_project_manager id60}@anchor{1bb}@anchor{gnat_ugn/gnat_project_manager package-linker-attributes}@anchor{1bc}
-@subsubsection Package Linker Attributes
-
-
-
-@itemize *
-
-@item
-@strong{General}
-
-
-@itemize *
-
-@item
-@strong{Required_Switches}: list
-
-Value is a list of switches that are required when invoking the linker to link
-an executable.
-
-@item
-@strong{Default_Switches}: list, indexed, case-insensitive index
-
-Index is a language name. Value is a list of switches for the linker when
-linking an executable for a main source of the language, when there is no
-applicable Switches.
-
-@item
-@strong{Leading_Switches}: list, optional index, indexed,
-case-insensitive index, others allowed
-
-Index is a source file name or a language name. Value is the list of switches
-to be used at the beginning of the command line when invoking the linker to
-build an executable for the source or for its language.
-
-@item
-@strong{Switches}: list, optional index, indexed, case-insensitive index,
-others allowed
-
-Index is a source file name or a language name. Value is the list of switches
-to be used when invoking the linker to build an executable for the source or
-for its language.
-
-@item
-@strong{Trailing_Switches}: list, optional index, indexed,
-case-insensitive index, others allowed
-
-Index is a source file name or a language name. Value is the list of switches
-to be used at the end of the command line when invoking the linker to
-build an executable for the source or for its language. These switches may
-override the Required_Switches.
-
-@item
-@strong{Linker_Options}: list
-
-Value is a list of switches/options that are to be added when linking an
-executable from a project importing the current project directly or indirectly.
-Linker_Options are not used when linking an executable from the current
-project.
-
-@item
-@strong{Map_File_Option}: single
-
-Value is the switch to specify the map file name that the linker needs to
-create.
-@end itemize
-
-@item
-@strong{Configuration - Linking}
-
-
-@itemize *
-
-@item
-@strong{Driver}: single
-
-Value is the name of the linker executable.
-@end itemize
-
-@item
-@strong{Configuration - Response Files}
-
-
-@itemize *
-
-@item
-@strong{Max_Command_Line_Length}: single
-
-Value is the maximum number of character in the command line when invoking
-the linker to link an executable.
-
-@item
-@strong{Response_File_Format}: single
-
-Indicates the kind of response file to create when the length of the linking
-command line is too large. Only authorized case-insensitive values are "none",
-"gnu", "object_list", "gcc_gnu", "gcc_option_list" and "gcc_object_list".
-
-@item
-@strong{Response_File_Switches}: list
-
-Value is the list of switches to specify a response file to the linker.
-@end itemize
-@end itemize
-
-@c only PRO or GPL
-@c
-@c .. _Package_Metrics_Attribute:
-@c
-@c Package Metrics Attribute
-@c ^^^^^^^^^^^^^^^^^^^^^^^^^
-@c
-@c * **Default_Switches**: list, indexed, case-insensitive index
-@c
-@c Index is a language name. Value is a list of switches to be used when invoking
-@c `gnatmetric` for a source of the language, if there is no applicable
-@c attribute Switches.
-@c
-@c * **Switches**: list, optional index, indexed, case-insensitive index,
-@c others allowed
-@c
-@c Index is a source file name. Value is the list of switches to be used when
-@c invoking `gnatmetric` for the source.
-
-@node Package Naming Attributes,Package Remote Attributes,Package Linker Attributes,Attributes
-@anchor{gnat_ugn/gnat_project_manager package-naming-attributes}@anchor{1bd}@anchor{gnat_ugn/gnat_project_manager id61}@anchor{1be}
-@subsubsection Package Naming Attributes
-
-
-
-@itemize *
-
-@item
-@strong{Specification_Suffix}: single, indexed, case-insensitive index
-
-Equivalent to attribute Spec_Suffix.
-
-@item
-@strong{Spec_Suffix}: single, indexed, case-insensitive index
-
-Index is a language name. Value is the extension of file names for specs of
-the language.
-
-@item
-@strong{Implementation_Suffix}: single, indexed, case-insensitive index
-
-Equivalent to attribute Body_Suffix.
-
-@item
-@strong{Body_Suffix}: single, indexed, case-insensitive index
-
-Index is a language name. Value is the extension of file names for bodies of
-the language.
-
-@item
-@strong{Separate_Suffix}: single
-
-Value is the extension of file names for subunits of Ada.
-
-@item
-@strong{Casing}: single
-
-Indicates the casing of sources of the Ada language. Only authorized
-case-insensitive values are "lowercase", "uppercase" and "mixedcase".
-
-@item
-@strong{Dot_Replacement}: single
-
-Value is the string that replace the dot of unit names in the source file names
-of the Ada language.
-
-@item
-@strong{Specification}: single, optional index, indexed,
-case-insensitive index
-
-Equivalent to attribute Spec.
-
-@item
-@strong{Spec}: single, optional index, indexed, case-insensitive index
-
-Index is a unit name. Value is the file name of the spec of the unit.
-
-@item
-@strong{Implementation}: single, optional index, indexed,
-case-insensitive index
-
-Equivalent to attribute Body.
-
-@item
-@strong{Body}: single, optional index, indexed, case-insensitive index
-
-Index is a unit name. Value is the file name of the body of the unit.
-
-@item
-@strong{Specification_Exceptions}: list, indexed, case-insensitive index
-
-Index is a language name. Value is a list of specs for the language that do not
-necessarily follow the naming scheme for the language and that may or may not
-be found in the source directories of the project.
-
-@item
-@strong{Implementation_Exceptions}: list, indexed, case-insensitive index
-
-Index is a language name. Value is a list of bodies for the language that do not
-necessarily follow the naming scheme for the language and that may or may not
-be found in the source directories of the project.
-@end itemize
-
-
-@node Package Remote Attributes,Package Stack Attributes,Package Naming Attributes,Attributes
-@anchor{gnat_ugn/gnat_project_manager package-remote-attributes}@anchor{1bf}@anchor{gnat_ugn/gnat_project_manager id63}@anchor{1c0}
-@subsubsection Package Remote Attributes
-
-
-
-@itemize *
-
-@item
-@strong{Included_Patterns}: list
-
-If this attribute is defined it sets the patterns to
-synchronized from the master to the slaves. It is exclusive
-with Excluded_Patterns, that is it is an error to define
-both.
-
-@item
-@strong{Included_Artifact_Patterns}: list
-
-If this attribute is defined it sets the patterns of compilation
-artifacts to synchronized from the slaves to the build master.
-This attribute replace the default hard-coded patterns.
-
-@item
-@strong{Excluded_Patterns}: list
-
-Set of patterns to ignore when synchronizing sources from the build
-master to the slaves. A set of predefined patterns are supported
-(e.g. *.o, *.ali, *.exe, etc.), this attributes make it possible to
-add some more patterns.
-
-@item
-@strong{Root_Dir}: single
-
-Value is the root directory used by the slave machines.
-@end itemize
-
-@node Package Stack Attributes,Package Synchronize Attributes,Package Remote Attributes,Attributes
-@anchor{gnat_ugn/gnat_project_manager id64}@anchor{1c1}@anchor{gnat_ugn/gnat_project_manager package-stack-attributes}@anchor{1c2}
-@subsubsection Package Stack Attributes
-
-
-
-@itemize *
-
-@item
-@strong{Switches}: list
-
-Value is the list of switches to be used when invoking @cite{gnatstack}.
-@end itemize
-
-@node Package Synchronize Attributes,,Package Stack Attributes,Attributes
-@anchor{gnat_ugn/gnat_project_manager package-synchronize-attributes}@anchor{1c3}
-@subsubsection Package Synchronize Attributes
-
-
-
-@itemize *
-
-@item
-@strong{Default_Switches}: list, indexed, case-insensitive index
-
-Index is a language name. Value is a list of switches to be used when invoking
-@cite{gnatsync} for a source of the language, if there is no applicable
-attribute Switches.
-
-@item
-@strong{Switches}: list, optional index, indexed, case-insensitive index,
-others allowed
-
-Index is a source file name. Value is the list of switches to be used when
-invoking @cite{gnatsync} for the source.
-@end itemize
-
-@node Tools Supporting Project Files,GNAT Utility Programs,GNAT Project Manager,Top
-@anchor{gnat_ugn/tools_supporting_project_files doc}@anchor{1c4}@anchor{gnat_ugn/tools_supporting_project_files tools-supporting-project-files}@anchor{c}@anchor{gnat_ugn/tools_supporting_project_files id1}@anchor{1c5}
-@chapter Tools Supporting Project Files
-
-
-This section describes how project files can be used in conjunction with a number of
-GNAT tools.
-
-@menu
-* gnatmake and Project Files::
-* The GNAT Driver and Project Files::
-
-@end menu
-
-@node gnatmake and Project Files,The GNAT Driver and Project Files,,Tools Supporting Project Files
-@anchor{gnat_ugn/tools_supporting_project_files id2}@anchor{1c6}@anchor{gnat_ugn/tools_supporting_project_files gnatmake-and-project-files}@anchor{e4}
-@section gnatmake and Project Files
-
-
-This section covers several topics related to @emph{gnatmake} and
-project files: defining switches for @emph{gnatmake}
-and for the tools that it invokes; specifying configuration pragmas;
-the use of the @cite{Main} attribute; building and rebuilding library project
-files.
-
-@menu
-* Switches Related to Project Files::
-* Switches and Project Files::
-* Specifying Configuration Pragmas::
-* Project Files and Main Subprograms::
-* Library Project Files::
-
-@end menu
-
-@node Switches Related to Project Files,Switches and Project Files,,gnatmake and Project Files
-@anchor{gnat_ugn/tools_supporting_project_files switches-related-to-project-files}@anchor{e6}@anchor{gnat_ugn/tools_supporting_project_files id3}@anchor{1c7}
-@subsection Switches Related to Project Files
-
-
-The following switches are used by GNAT tools that support project files:
-
-@quotation
-
-@geindex -P (any project-aware tool)
-@end quotation
-
-
-@table @asis
-
-@item @code{-P@emph{project}}
-
-Indicates the name of a project file. This project file will be parsed with
-the verbosity indicated by @emph{-vP*x*},
-if any, and using the external references indicated
-by @emph{-X} switches, if any.
-There may zero, one or more spaces between @emph{-P} and @cite{project}.
-
-There must be only one @emph{-P} switch on the command line.
-
-Since the Project Manager parses the project file only after all the switches
-on the command line are checked, the order of the switches
-@emph{-P},
-@emph{-vP*x*}
-or @emph{-X} is not significant.
-
-@geindex -X (any project-aware tool)
-
-@item @code{-X@emph{name}=@emph{value}}
-
-Indicates that external variable @cite{name} has the value @cite{value}.
-The Project Manager will use this value for occurrences of
-@cite{external(name)} when parsing the project file.
-
-If @cite{name} or @cite{value} includes a space, then @cite{name=value} should be
-put between quotes.
-
-@example
--XOS=NT
--X"user=John Doe"
-@end example
-
-Several @emph{-X} switches can be used simultaneously.
-If several @emph{-X} switches specify the same
-@cite{name}, only the last one is used.
-
-An external variable specified with a @emph{-X} switch
-takes precedence over the value of the same name in the environment.
-
-@geindex -vP (any project-aware tool)
-
-@item @code{-vP@emph{x}}
-
-Indicates the verbosity of the parsing of GNAT project files.
-
-@emph{-vP0} means Default;
-@emph{-vP1} means Medium;
-@emph{-vP2} means High.
-
-The default is Default: no output for syntactically correct
-project files.
-If several @emph{-vP*x*} switches are present,
-only the last one is used.
-
-@geindex -aP (any project-aware tool)
-
-@item @code{-aP@emph{dir}}
-
-Add directory @cite{dir} at the beginning of the project search path, in order,
-after the current working directory.
-
-@geindex -eL (any project-aware tool)
-
-@item @code{-eL}
-
-Follow all symbolic links when processing project files.
-
-@geindex --subdirs= (gnatmake and gnatclean)
-
-@item @code{--subdirs=@emph{subdir}}
-
-This switch is recognized by @emph{gnatmake} and @emph{gnatclean}. It
-indicate that the real directories (except the source directories) are the
-subdirectories @cite{subdir} of the directories specified in the project files.
-This applies in particular to object directories, library directories and
-exec directories. If the subdirectories do not exist, they are created
-automatically.
-@end table
-
-@node Switches and Project Files,Specifying Configuration Pragmas,Switches Related to Project Files,gnatmake and Project Files
-@anchor{gnat_ugn/tools_supporting_project_files id4}@anchor{1c8}@anchor{gnat_ugn/tools_supporting_project_files switches-and-project-files}@anchor{1c9}
-@subsection Switches and Project Files
-
-
-For each of the packages @cite{Builder}, @cite{Compiler}, @cite{Binder}, and
-@cite{Linker}, you can specify a @cite{Default_Switches}
-attribute, a @cite{Switches} attribute, or both;
-as their names imply, these switch-related
-attributes affect the switches that are used for each of these GNAT
-components when
-@emph{gnatmake} is invoked. As will be explained below, these
-component-specific switches precede
-the switches provided on the @emph{gnatmake} command line.
-
-The @cite{Default_Switches} attribute is an attribute
-indexed by language name (case insensitive) whose value is a string list.
-For example:
-
-@quotation
-
-@example
-package Compiler is
- for Default_Switches ("Ada")
- use ("-gnaty",
- "-v");
-end Compiler;
-@end example
-@end quotation
-
-The @cite{Switches} attribute is indexed on a file name (which may or may
-not be case sensitive, depending
-on the operating system) whose value is a string list. For example:
-
-@quotation
-
-@example
-package Builder is
- for Switches ("main1.adb")
- use ("-O2");
- for Switches ("main2.adb")
- use ("-g");
-end Builder;
-@end example
-@end quotation
-
-For the @cite{Builder} package, the file names must designate source files
-for main subprograms. For the @cite{Binder} and @cite{Linker} packages, the
-file names must designate @code{ALI} or source files for main subprograms.
-In each case just the file name without an explicit extension is acceptable.
-
-For each tool used in a program build (@emph{gnatmake}, the compiler, the
-binder, and the linker), the corresponding package @@dfn@{contributes@} a set of
-switches for each file on which the tool is invoked, based on the
-switch-related attributes defined in the package.
-In particular, the switches
-that each of these packages contributes for a given file @cite{f} comprise:
-
-
-@itemize *
-
-@item
-the value of attribute @cite{Switches (`f})`,
-if it is specified in the package for the given file,
-
-@item
-otherwise, the value of @cite{Default_Switches ("Ada")},
-if it is specified in the package.
-@end itemize
-
-If neither of these attributes is defined in the package, then the package does
-not contribute any switches for the given file.
-
-When @emph{gnatmake} is invoked on a file, the switches comprise
-two sets, in the following order: those contributed for the file
-by the @cite{Builder} package;
-and the switches passed on the command line.
-
-When @emph{gnatmake} invokes a tool (compiler, binder, linker) on a file,
-the switches passed to the tool comprise three sets,
-in the following order:
-
-
-@itemize *
-
-@item
-the applicable switches contributed for the file
-by the @cite{Builder} package in the project file supplied on the command line;
-
-@item
-those contributed for the file by the package (in the relevant project file --
-see below) corresponding to the tool; and
-
-@item
-the applicable switches passed on the command line.
-@end itemize
-
-The term @emph{applicable switches} reflects the fact that
-@emph{gnatmake} switches may or may not be passed to individual
-tools, depending on the individual switch.
-
-@emph{gnatmake} may invoke the compiler on source files from different
-projects. The Project Manager will use the appropriate project file to
-determine the @cite{Compiler} package for each source file being compiled.
-Likewise for the @cite{Binder} and @cite{Linker} packages.
-
-As an example, consider the following package in a project file:
-
-@quotation
-
-@example
-project Proj1 is
- package Compiler is
- for Default_Switches ("Ada")
- use ("-g");
- for Switches ("a.adb")
- use ("-O1");
- for Switches ("b.adb")
- use ("-O2",
- "-gnaty");
- end Compiler;
-end Proj1;
-@end example
-@end quotation
-
-If @emph{gnatmake} is invoked with this project file, and it needs to
-compile, say, the files @code{a.adb}, @code{b.adb}, and @code{c.adb}, then
-@code{a.adb} will be compiled with the switch @emph{-O1},
-@code{b.adb} with switches @emph{-O2} and @emph{-gnaty},
-and @code{c.adb} with @emph{-g}.
-
-The following example illustrates the ordering of the switches
-contributed by different packages:
-
-@quotation
-
-@example
-project Proj2 is
- package Builder is
- for Switches ("main.adb")
- use ("-g",
- "-O1",
- "-f");
- end Builder;
-
- package Compiler is
- for Switches ("main.adb")
- use ("-O2");
- end Compiler;
-end Proj2;
-@end example
-@end quotation
-
-If you issue the command:
-
-@quotation
-
-@example
-$ gnatmake -Pproj2 -O0 main
-@end example
-@end quotation
-
-then the compiler will be invoked on @code{main.adb} with the following
-sequence of switches
-
-@quotation
-
-@example
--g -O1 -O2 -O0
-@end example
-@end quotation
-
-with the last @emph{-O}
-switch having precedence over the earlier ones;
-several other switches
-(such as @emph{-c}) are added implicitly.
-
-The switches @emph{-g}
-and @emph{-O1} are contributed by package
-@cite{Builder}, @emph{-O2} is contributed
-by the package @cite{Compiler}
-and @emph{-O0} comes from the command line.
-
-The @emph{-g} switch will also be passed in the invocation of
-@emph{Gnatlink.}
-
-A final example illustrates switch contributions from packages in different
-project files:
-
-@quotation
-
-@example
-project Proj3 is
- for Source_Files use ("pack.ads", "pack.adb");
- package Compiler is
- for Default_Switches ("Ada")
- use ("-gnata");
- end Compiler;
-end Proj3;
-
-with "Proj3";
-project Proj4 is
- for Source_Files use ("foo_main.adb", "bar_main.adb");
- package Builder is
- for Switches ("foo_main.adb")
- use ("-s",
- "-g");
- end Builder;
-end Proj4;
-@end example
-
-@example
--- Ada source file:
-with Pack;
-procedure Foo_Main is
- ...
-end Foo_Main;
-@end example
-@end quotation
-
-If the command is
-
-@quotation
-
-@example
-$ gnatmake -PProj4 foo_main.adb -cargs -gnato
-@end example
-@end quotation
-
-then the switches passed to the compiler for @code{foo_main.adb} are
-@emph{-g} (contributed by the package @cite{Proj4.Builder}) and
-@emph{-gnato} (passed on the command line).
-When the imported package @cite{Pack} is compiled, the switches used
-are @emph{-g} from @cite{Proj4.Builder},
-@emph{-gnata} (contributed from package @cite{Proj3.Compiler},
-and @emph{-gnato} from the command line.
-
-When using @emph{gnatmake} with project files, some switches or
-arguments may be expressed as relative paths. As the working directory where
-compilation occurs may change, these relative paths are converted to absolute
-paths. For the switches found in a project file, the relative paths
-are relative to the project file directory, for the switches on the command
-line, they are relative to the directory where @emph{gnatmake} is invoked.
-The switches for which this occurs are:
--I,
--A,
--L,
--aO,
--aL,
--aI, as well as all arguments that are not switches (arguments to
-switch
--o, object files specified in package @cite{Linker} or after
--largs on the command line). The exception to this rule is the switch
---RTS= for which a relative path argument is never converted.
-
-@node Specifying Configuration Pragmas,Project Files and Main Subprograms,Switches and Project Files,gnatmake and Project Files
-@anchor{gnat_ugn/tools_supporting_project_files id5}@anchor{1ca}@anchor{gnat_ugn/tools_supporting_project_files specifying-configuration-pragmas}@anchor{7d}
-@subsection Specifying Configuration Pragmas
-
-
-When using @emph{gnatmake} with project files, if there exists a file
-@code{gnat.adc} that contains configuration pragmas, this file will be
-ignored.
-
-Configuration pragmas can be defined by means of the following attributes in
-project files: @cite{Global_Configuration_Pragmas} in package @cite{Builder}
-and @cite{Local_Configuration_Pragmas} in package @cite{Compiler}.
-
-Both these attributes are single string attributes. Their values is the path
-name of a file containing configuration pragmas. If a path name is relative,
-then it is relative to the project directory of the project file where the
-attribute is defined.
-
-When compiling a source, the configuration pragmas used are, in order,
-those listed in the file designated by attribute
-@cite{Global_Configuration_Pragmas} in package @cite{Builder} of the main
-project file, if it is specified, and those listed in the file designated by
-attribute @cite{Local_Configuration_Pragmas} in package @cite{Compiler} of
-the project file of the source, if it exists.
-
-@node Project Files and Main Subprograms,Library Project Files,Specifying Configuration Pragmas,gnatmake and Project Files
-@anchor{gnat_ugn/tools_supporting_project_files id6}@anchor{1cb}@anchor{gnat_ugn/tools_supporting_project_files project-files-and-main-subprograms}@anchor{e5}
-@subsection Project Files and Main Subprograms
-
-
-When using a project file, you can invoke @emph{gnatmake}
-with one or several main subprograms, by specifying their source files on the
-command line.
-
-@quotation
-
-@example
-$ gnatmake -Pprj main1.adb main2.adb main3.adb
-@end example
-@end quotation
-
-Each of these needs to be a source file of the same project, except
-when the switch @cite{-u} is used.
-
-When @cite{-u} is not used, all the mains need to be sources of the
-same project, one of the project in the tree rooted at the project specified
-on the command line. The package @cite{Builder} of this common project, the
-"main project" is the one that is considered by @emph{gnatmake}.
-
-When @cite{-u} is used, the specified source files may be in projects
-imported directly or indirectly by the project specified on the command line.
-Note that if such a source file is not part of the project specified on the
-command line, the switches found in package @cite{Builder} of the
-project specified on the command line, if any, that are transmitted
-to the compiler will still be used, not those found in the project file of
-the source file.
-
-When using a project file, you can also invoke @emph{gnatmake} without
-explicitly specifying any main, and the effect depends on whether you have
-defined the @cite{Main} attribute. This attribute has a string list value,
-where each element in the list is the name of a source file (the file
-extension is optional) that contains a unit that can be a main subprogram.
-
-If the @cite{Main} attribute is defined in a project file as a non-empty
-string list and the switch @emph{-u} is not used on the command
-line, then invoking @emph{gnatmake} with this project file but without any
-main on the command line is equivalent to invoking @emph{gnatmake} with all
-the file names in the @cite{Main} attribute on the command line.
-
-Example:
-
-@quotation
-
-@example
-project Prj is
- for Main use ("main1.adb", "main2.adb", "main3.adb");
-end Prj;
-@end example
-@end quotation
-
-With this project file, @cite{"gnatmake -Pprj"}
-is equivalent to
-@cite{"gnatmake -Pprj main1.adb main2.adb main3.adb"}.
-
-When the project attribute @cite{Main} is not specified, or is specified
-as an empty string list, or when the switch @emph{-u} is used on the command
-line, then invoking @emph{gnatmake} with no main on the command line will
-result in all immediate sources of the project file being checked, and
-potentially recompiled. Depending on the presence of the switch @emph{-u},
-sources from other project files on which the immediate sources of the main
-project file depend are also checked and potentially recompiled. In other
-words, the @emph{-u} switch is applied to all of the immediate sources of the
-main project file.
-
-When no main is specified on the command line and attribute @cite{Main} exists
-and includes several mains, or when several mains are specified on the
-command line, the default switches in package @cite{Builder} will
-be used for all mains, even if there are specific switches
-specified for one or several mains.
-
-But the switches from package @cite{Binder} or @cite{Linker} will be
-the specific switches for each main, if they are specified.
-
-@node Library Project Files,,Project Files and Main Subprograms,gnatmake and Project Files
-@anchor{gnat_ugn/tools_supporting_project_files id7}@anchor{1cc}@anchor{gnat_ugn/tools_supporting_project_files library-project-files}@anchor{1cd}
-@subsection Library Project Files
-
-
-When @emph{gnatmake} is invoked with a main project file that is a library
-project file, it is not allowed to specify one or more mains on the command
-line.
-
-When a library project file is specified, switches @cite{-b} and
-@cite{-l} have special meanings.
-
-
-@itemize *
-
-@item
-@cite{-b} is only allowed for stand-alone libraries. It indicates
-to @emph{gnatmake} that @emph{gnatbind} should be invoked for the
-library.
-
-@item
-@cite{-l} may be used for all library projects. It indicates
-to @emph{gnatmake} that the binder generated file should be compiled
-(in the case of a stand-alone library) and that the library should be built.
-@end itemize
-
-@node The GNAT Driver and Project Files,,gnatmake and Project Files,Tools Supporting Project Files
-@anchor{gnat_ugn/tools_supporting_project_files id8}@anchor{1ce}@anchor{gnat_ugn/tools_supporting_project_files the-gnat-driver-and-project-files}@anchor{122}
-@section The GNAT Driver and Project Files
-
-
-A number of GNAT tools beyond @emph{gnatmake}
-can benefit from project files:
-
-
-
-@itemize *
-
-@item
-@emph{gnatbind}
-
-@item
-@emph{gnatclean}
-
-@item
-@emph{gnatfind}
-
-@item
-@emph{gnatlink}
-
-@item
-@emph{gnatls}
-
-@item
-@emph{gnatxref}
-@end itemize
-
-However, none of these tools can be invoked
-directly with a project file switch (@emph{-P}).
-They must be invoked through the @emph{gnat} driver.
-
-The @emph{gnat} driver is a wrapper that accepts a number of commands and
-calls the corresponding tool. It was designed initially for VMS platforms (to
-convert VMS qualifiers to Unix-style switches), but it is now available on all
-GNAT platforms.
-
-On non-VMS platforms, the @emph{gnat} driver accepts the following commands
-(case insensitive):
-
-
-
-@itemize *
-
-@item
-BIND to invoke @emph{gnatbind}
-
-@item
-CHOP to invoke @emph{gnatchop}
-
-@item
-CLEAN to invoke @emph{gnatclean}
-
-@item
-COMP or COMPILE to invoke the compiler
-
-@item
-FIND to invoke @emph{gnatfind}
-
-@item
-KR or KRUNCH to invoke @emph{gnatkr}
-
-@item
-LINK to invoke @emph{gnatlink}
-
-@item
-LS or LIST to invoke @emph{gnatls}
-
-@item
-MAKE to invoke @emph{gnatmake}
-
-@item
-NAME to invoke @emph{gnatname}
-
-@item
-PREP or PREPROCESS to invoke @emph{gnatprep}
-
-@item
-XREF to invoke @emph{gnatxref}
-@end itemize
-
-Note that the command
-@emph{gnatmake -c -f -u} is used to invoke the compiler.
-
-On non-VMS platforms, between @emph{gnat} and the command, two
-special switches may be used:
-
-
-@itemize *
-
-@item
-@emph{-v} to display the invocation of the tool.
-
-@item
-@emph{-dn} to prevent the @emph{gnat} driver from removing
-the temporary files it has created. These temporary files are
-configuration files and temporary file list files.
-@end itemize
-
-The command may be followed by switches and arguments for the invoked
-tool.
-
-@quotation
-
-@example
-$ gnat bind -C main.ali
-$ gnat ls -a main
-$ gnat chop foo.txt
-@end example
-@end quotation
-
-Switches may also be put in text files, one switch per line, and the text
-files may be specified with their path name preceded by '@@'.
-
-@quotation
-
-@example
-$ gnat bind @@args.txt main.ali
-@end example
-@end quotation
-
-In addition, for the following commands the project file related switches
-(@emph{-P}, @emph{-X} and @emph{-vPx}) may be used in addition to
-the switches of the invoking tool:
-
-
-
-@itemize *
-
-@item
-BIND
-
-@item
-COMP or COMPILE
-
-@item
-FIND
-
-@item
-LS or LIST
-
-@item
-LINK
-
-@item
-XREF
-@end itemize
-
-
-For each of the following commands, there is optionally a corresponding
-package in the main project.
-
-
-
-@itemize *
-
-@item
-package @cite{Binder} for command BIND (invoking @cite{gnatbind})
-
-@item
-package @cite{Compiler} for command COMP or COMPILE (invoking the compiler)
-
-@item
-package @cite{Cross_Reference} for command XREF (invoking @cite{gnatxref})
-
-@item
-package @cite{Finder} for command FIND (invoking @cite{gnatfind})
-
-@item
-package @cite{Gnatls} for command LS or LIST (invoking @cite{gnatls})
-
-@item
-package @cite{Linker} for command LINK (invoking @cite{gnatlink})
-@end itemize
-
-Package @cite{Gnatls} has a unique attribute @cite{Switches},
-a simple variable with a string list value. It contains switches
-for the invocation of @cite{gnatls}.
-
-@quotation
-
-@example
-project Proj1 is
- package gnatls is
- for Switches
- use ("-a",
- "-v");
- end gnatls;
-end Proj1;
-@end example
-@end quotation
-
-All other packages have two attribute @cite{Switches} and
-@cite{Default_Switches}.
-
-@cite{Switches} is an indexed attribute, indexed by the
-source file name, that has a string list value: the switches to be
-used when the tool corresponding to the package is invoked for the specific
-source file.
-
-@cite{Default_Switches} is an attribute,
-indexed by the programming language that has a string list value.
-@cite{Default_Switches ("Ada")} contains the
-switches for the invocation of the tool corresponding
-to the package, except if a specific @cite{Switches} attribute
-is specified for the source file.
-
-@quotation
-
-@example
-project Proj is
-
- for Source_Dirs use ("");
-
- package gnatls is
- for Switches use
- ("-a",
- "-v");
- end gnatls;
-
- package Compiler is
- for Default_Switches ("Ada")
- use ("-gnatv",
- "-gnatwa");
- end Binder;
-
- package Binder is
- for Default_Switches ("Ada")
- use ("-C",
- "-e");
- end Binder;
-
- package Linker is
- for Default_Switches ("Ada")
- use ("-C");
- for Switches ("main.adb")
- use ("-C",
- "-v",
- "-v");
- end Linker;
-
- package Finder is
- for Default_Switches ("Ada")
- use ("-a",
- "-f");
- end Finder;
-
- package Cross_Reference is
- for Default_Switches ("Ada")
- use ("-a",
- "-f",
- "-d",
- "-u");
- end Cross_Reference;
-end Proj;
-@end example
-@end quotation
-
-With the above project file, commands such as
-
-@quotation
-
-@example
-$ gnat comp -Pproj main
-$ gnat ls -Pproj main
-$ gnat xref -Pproj main
-$ gnat bind -Pproj main.ali
-$ gnat link -Pproj main.ali
-@end example
-@end quotation
-
-will set up the environment properly and invoke the tool with the switches
-found in the package corresponding to the tool:
-@cite{Default_Switches ("Ada")} for all tools,
-except @cite{Switches ("main.adb")}
-for @cite{gnatlink}.
-
-
-@node GNAT Utility Programs,GNAT and Program Execution,Tools Supporting Project Files,Top
-@anchor{gnat_ugn/gnat_utility_programs doc}@anchor{1cf}@anchor{gnat_ugn/gnat_utility_programs gnat-utility-programs}@anchor{d}@anchor{gnat_ugn/gnat_utility_programs id1}@anchor{1d0}
+@node GNAT Utility Programs,GNAT and Program Execution,Building Executable Programs with GNAT,Top
+@anchor{gnat_ugn/gnat_utility_programs doc}@anchor{143}@anchor{gnat_ugn/gnat_utility_programs gnat-utility-programs}@anchor{b}@anchor{gnat_ugn/gnat_utility_programs id1}@anchor{144}
@chapter GNAT Utility Programs
@@ -23290,16 +16923,16 @@ This chapter describes a number of utility programs:
@itemize *
@item
-@ref{22,,The File Cleanup Utility gnatclean}
+@ref{20,,The File Cleanup Utility gnatclean}
@item
-@ref{23,,The GNAT Library Browser gnatls}
+@ref{21,,The GNAT Library Browser gnatls}
@item
-@ref{24,,The Cross-Referencing Tools gnatxref and gnatfind}
+@ref{22,,The Cross-Referencing Tools gnatxref and gnatfind}
@item
-@ref{25,,The Ada to HTML Converter gnathtml}
+@ref{23,,The Ada to HTML Converter gnathtml}
@end itemize
Other GNAT utilities are described elsewhere in this manual:
@@ -23308,16 +16941,16 @@ Other GNAT utilities are described elsewhere in this manual:
@itemize *
@item
-@ref{5b,,Handling Arbitrary File Naming Conventions with gnatname}
+@ref{59,,Handling Arbitrary File Naming Conventions with gnatname}
@item
-@ref{65,,File Name Krunching with gnatkr}
+@ref{63,,File Name Krunching with gnatkr}
@item
-@ref{38,,Renaming Files with gnatchop}
+@ref{36,,Renaming Files with gnatchop}
@item
-@ref{19,,Preprocessing with gnatprep}
+@ref{17,,Preprocessing with gnatprep}
@end itemize
@menu
@@ -23329,7 +16962,7 @@ Other GNAT utilities are described elsewhere in this manual:
@end menu
@node The File Cleanup Utility gnatclean,The GNAT Library Browser gnatls,,GNAT Utility Programs
-@anchor{gnat_ugn/gnat_utility_programs id2}@anchor{1d1}@anchor{gnat_ugn/gnat_utility_programs the-file-cleanup-utility-gnatclean}@anchor{22}
+@anchor{gnat_ugn/gnat_utility_programs id2}@anchor{145}@anchor{gnat_ugn/gnat_utility_programs the-file-cleanup-utility-gnatclean}@anchor{20}
@section The File Cleanup Utility @emph{gnatclean}
@@ -23349,7 +16982,7 @@ generated files and executable files.
@end menu
@node Running gnatclean,Switches for gnatclean,,The File Cleanup Utility gnatclean
-@anchor{gnat_ugn/gnat_utility_programs running-gnatclean}@anchor{1d2}@anchor{gnat_ugn/gnat_utility_programs id3}@anchor{1d3}
+@anchor{gnat_ugn/gnat_utility_programs running-gnatclean}@anchor{146}@anchor{gnat_ugn/gnat_utility_programs id3}@anchor{147}
@subsection Running @cite{gnatclean}
@@ -23373,7 +17006,7 @@ the linker. In informative-only mode, specified by switch
normal mode is listed, but no file is actually deleted.
@node Switches for gnatclean,,Running gnatclean,The File Cleanup Utility gnatclean
-@anchor{gnat_ugn/gnat_utility_programs id4}@anchor{1d4}@anchor{gnat_ugn/gnat_utility_programs switches-for-gnatclean}@anchor{1d5}
+@anchor{gnat_ugn/gnat_utility_programs id4}@anchor{148}@anchor{gnat_ugn/gnat_utility_programs switches-for-gnatclean}@anchor{149}
@subsection Switches for @cite{gnatclean}
@@ -23524,7 +17157,7 @@ Verbose mode.
@item @code{-vP@emph{x}}
Indicates the verbosity of the parsing of GNAT project files.
-@ref{e6,,Switches Related to Project Files}.
+@ref{de,,Switches Related to Project Files}.
@end table
@geindex -X (gnatclean)
@@ -23537,7 +17170,7 @@ Indicates the verbosity of the parsing of GNAT project files.
Indicates that external variable @cite{name} has the value @cite{value}.
The Project Manager will use this value for occurrences of
@cite{external(name)} when parsing the project file.
-@ref{e6,,Switches Related to Project Files}.
+@ref{de,,Switches Related to Project Files}.
@end table
@geindex -aO (gnatclean)
@@ -23575,7 +17208,7 @@ where @cite{gnatclean} was invoked.
@end table
@node The GNAT Library Browser gnatls,The Cross-Referencing Tools gnatxref and gnatfind,The File Cleanup Utility gnatclean,GNAT Utility Programs
-@anchor{gnat_ugn/gnat_utility_programs the-gnat-library-browser-gnatls}@anchor{23}@anchor{gnat_ugn/gnat_utility_programs id5}@anchor{1d6}
+@anchor{gnat_ugn/gnat_utility_programs the-gnat-library-browser-gnatls}@anchor{21}@anchor{gnat_ugn/gnat_utility_programs id5}@anchor{14a}
@section The GNAT Library Browser @cite{gnatls}
@@ -23589,7 +17222,7 @@ files. It can also be used to check the source dependencies of a unit
as well as various characteristics.
Note: to invoke @cite{gnatls} with a project file, use the @cite{gnat}
-driver (see @ref{122,,The GNAT Driver and Project Files}).
+driver (see @emph{The_GNAT_Driver_and_Project_Files}).
@menu
* Running gnatls::
@@ -23599,7 +17232,7 @@ driver (see @ref{122,,The GNAT Driver and Project Files}).
@end menu
@node Running gnatls,Switches for gnatls,,The GNAT Library Browser gnatls
-@anchor{gnat_ugn/gnat_utility_programs id6}@anchor{1d7}@anchor{gnat_ugn/gnat_utility_programs running-gnatls}@anchor{1d8}
+@anchor{gnat_ugn/gnat_utility_programs id6}@anchor{14b}@anchor{gnat_ugn/gnat_utility_programs running-gnatls}@anchor{14c}
@subsection Running @cite{gnatls}
@@ -23613,7 +17246,7 @@ $ gnatls switches `object_or_ali_file`
@end quotation
The main argument is the list of object or @code{ali} files
-(see @ref{44,,The Ada Library Information Files})
+(see @ref{42,,The Ada Library Information Files})
for which information is requested.
In normal mode, without additional option, @cite{gnatls} produces a
@@ -23679,7 +17312,7 @@ version of the same source that has been modified.
@end table
@node Switches for gnatls,Example of gnatls Usage,Running gnatls,The GNAT Library Browser gnatls
-@anchor{gnat_ugn/gnat_utility_programs id7}@anchor{1d9}@anchor{gnat_ugn/gnat_utility_programs switches-for-gnatls}@anchor{1da}
+@anchor{gnat_ugn/gnat_utility_programs id7}@anchor{14d}@anchor{gnat_ugn/gnat_utility_programs switches-for-gnatls}@anchor{14e}
@subsection Switches for @cite{gnatls}
@@ -23794,7 +17427,7 @@ Several such switches may be specified simultaneously.
@item @code{-aO@emph{dir}}, @code{-aI@emph{dir}}, @code{-I@emph{dir}}, @code{-I-}, @code{-nostdinc}
Source path manipulation. Same meaning as the equivalent @emph{gnatmake}
-flags (@ref{e2,,Switches for gnatmake}).
+flags (@ref{dc,,Switches for gnatmake}).
@end table
@geindex -aP (gnatls)
@@ -23815,7 +17448,7 @@ Add @cite{dir} at the beginning of the project search dir.
@item @code{--RTS=@emph{rts-path}`}
Specifies the default location of the runtime library. Same meaning as the
-equivalent @emph{gnatmake} flag (@ref{e2,,Switches for gnatmake}).
+equivalent @emph{gnatmake} flag (@ref{dc,,Switches for gnatmake}).
@end table
@geindex -v (gnatls)
@@ -23861,7 +17494,7 @@ by the user.
@end table
@node Example of gnatls Usage,,Switches for gnatls,The GNAT Library Browser gnatls
-@anchor{gnat_ugn/gnat_utility_programs id8}@anchor{1db}@anchor{gnat_ugn/gnat_utility_programs example-of-gnatls-usage}@anchor{1dc}
+@anchor{gnat_ugn/gnat_utility_programs id8}@anchor{14f}@anchor{gnat_ugn/gnat_utility_programs example-of-gnatls-usage}@anchor{150}
@subsection Example of @cite{gnatls} Usage
@@ -23941,7 +17574,7 @@ instr.ads
@end quotation
@node The Cross-Referencing Tools gnatxref and gnatfind,The Ada to HTML Converter gnathtml,The GNAT Library Browser gnatls,GNAT Utility Programs
-@anchor{gnat_ugn/gnat_utility_programs the-cross-referencing-tools-gnatxref-and-gnatfind}@anchor{24}@anchor{gnat_ugn/gnat_utility_programs id9}@anchor{1dd}
+@anchor{gnat_ugn/gnat_utility_programs the-cross-referencing-tools-gnatxref-and-gnatfind}@anchor{22}@anchor{gnat_ugn/gnat_utility_programs id9}@anchor{151}
@section The Cross-Referencing Tools @cite{gnatxref} and @cite{gnatfind}
@@ -23969,11 +17602,11 @@ cross-references.
To use these tools, you must not compile your application using the
@emph{-gnatx} switch on the @emph{gnatmake} command line
-(see @ref{1d,,Building with gnatmake}). Otherwise, cross-referencing
+(see @ref{1b,,Building with gnatmake}). Otherwise, cross-referencing
information will not be generated.
Note: to invoke @cite{gnatxref} or @cite{gnatfind} with a project file,
-use the @cite{gnat} driver (see @ref{122,,The GNAT Driver and Project Files}).
+use the @cite{gnat} driver (see @emph{The_GNAT_Driver_and_Project_Files}).
@menu
* gnatxref Switches::
@@ -23986,7 +17619,7 @@ use the @cite{gnat} driver (see @ref{122,,The GNAT Driver and Project Files}).
@end menu
@node gnatxref Switches,gnatfind Switches,,The Cross-Referencing Tools gnatxref and gnatfind
-@anchor{gnat_ugn/gnat_utility_programs id10}@anchor{1de}@anchor{gnat_ugn/gnat_utility_programs gnatxref-switches}@anchor{1df}
+@anchor{gnat_ugn/gnat_utility_programs id10}@anchor{152}@anchor{gnat_ugn/gnat_utility_programs gnatxref-switches}@anchor{153}
@subsection @cite{gnatxref} Switches
@@ -24121,7 +17754,7 @@ default, which means that only the new extension will be considered.
@item @code{-RTS=@emph{rts-path}}
Specifies the default location of the runtime library. Same meaning as the
-equivalent @emph{gnatmake} flag (@ref{e2,,Switches for gnatmake}).
+equivalent @emph{gnatmake} flag (@ref{dc,,Switches for gnatmake}).
@end table
@geindex -d (gnatxref)
@@ -24176,10 +17809,7 @@ Equivalent to @code{-aODIR -aIDIR}.
@item @code{p@emph{FILE}}
-Specify a project file to use @ref{b,,GNAT Project Manager}.
-If you need to use the @code{.gpr}
-project files, you should use gnatxref through the GNAT driver
-(@emph{gnat xref -Pproject}).
+Specify a project file to use.
By default, @cite{gnatxref} and @cite{gnatfind} will try to locate a
project file in the current directory.
@@ -24199,7 +17829,7 @@ display every unused entity and 'with'ed package.
Instead of producing the default output, @cite{gnatxref} will generate a
@code{tags} file that can be used by vi. For examples how to use this
-feature, see @ref{1e0,,Examples of gnatxref Usage}. The tags file is output
+feature, see @ref{154,,Examples of gnatxref Usage}. The tags file is output
to the standard output, thus you will have to redirect it to a file.
@end table
@@ -24208,7 +17838,7 @@ appear after the file names. They need not be separated by spaces, thus
you can say @code{gnatxref -ag} instead of @code{gnatxref -a -g}.
@node gnatfind Switches,Project Files for gnatxref and gnatfind,gnatxref Switches,The Cross-Referencing Tools gnatxref and gnatfind
-@anchor{gnat_ugn/gnat_utility_programs id11}@anchor{1e1}@anchor{gnat_ugn/gnat_utility_programs gnatfind-switches}@anchor{1e2}
+@anchor{gnat_ugn/gnat_utility_programs id11}@anchor{155}@anchor{gnat_ugn/gnat_utility_programs gnatfind-switches}@anchor{156}
@subsection @cite{gnatfind} Switches
@@ -24230,7 +17860,7 @@ with the following iterpretation of the command arguments:
@item @emph{pattern}
An entity will be output only if it matches the regular expression found
-in @cite{pattern}, see @ref{1e3,,Regular Expressions in gnatfind and gnatxref}.
+in @cite{pattern}, see @ref{157,,Regular Expressions in gnatfind and gnatxref}.
Omitting the pattern is equivalent to specifying @code{*}, which
will match any entity. Note that if you do not provide a pattern, you
@@ -24244,7 +17874,7 @@ for matching purposes. At the current time there is no support for
@cite{gnatfind} will look for references, bodies or declarations
of symbols referenced in @code{sourcefile}, at line @cite{line}
-and column @cite{column}. See @ref{1e4,,Examples of gnatfind Usage}
+and column @cite{column}. See @ref{158,,Examples of gnatfind Usage}
for syntax examples.
@item @emph{line}
@@ -24383,7 +18013,7 @@ default, which means that only the new extension will be considered.
@item @code{-RTS=@emph{rts-path}}
Specifies the default location of the runtime library. Same meaning as the
-equivalent @emph{gnatmake} flag (@ref{e2,,Switches for gnatmake}).
+equivalent @emph{gnatmake} flag (@ref{dc,,Switches for gnatmake}).
@end table
@geindex -d (gnatfind)
@@ -24450,7 +18080,7 @@ Equivalent to @code{-aODIR -aIDIR}.
@item @code{p@emph{FILE}}
-Specify a project file (@ref{b,,GNAT Project Manager}) to use.
+Specify a project file.
By default, @cite{gnatxref} and @cite{gnatfind} will try to locate a
project file in the current directory.
@@ -24508,7 +18138,7 @@ search path. You can force it to look only in the current directory if
you specify @cite{*} at the end of the command line.
@node Project Files for gnatxref and gnatfind,Regular Expressions in gnatfind and gnatxref,gnatfind Switches,The Cross-Referencing Tools gnatxref and gnatfind
-@anchor{gnat_ugn/gnat_utility_programs project-files-for-gnatxref-and-gnatfind}@anchor{1e5}@anchor{gnat_ugn/gnat_utility_programs id12}@anchor{1e6}
+@anchor{gnat_ugn/gnat_utility_programs project-files-for-gnatxref-and-gnatfind}@anchor{159}@anchor{gnat_ugn/gnat_utility_programs id12}@anchor{15a}
@subsection Project Files for @emph{gnatxref} and @emph{gnatfind}
@@ -24649,7 +18279,7 @@ Specifies the command used to debug the application
@cite{src_dir} and @cite{obj_dir} lines, and ignore the others.
@node Regular Expressions in gnatfind and gnatxref,Examples of gnatxref Usage,Project Files for gnatxref and gnatfind,The Cross-Referencing Tools gnatxref and gnatfind
-@anchor{gnat_ugn/gnat_utility_programs id13}@anchor{1e7}@anchor{gnat_ugn/gnat_utility_programs regular-expressions-in-gnatfind-and-gnatxref}@anchor{1e3}
+@anchor{gnat_ugn/gnat_utility_programs id13}@anchor{15b}@anchor{gnat_ugn/gnat_utility_programs regular-expressions-in-gnatfind-and-gnatxref}@anchor{157}
@subsection Regular Expressions in @cite{gnatfind} and @cite{gnatxref}
@@ -24742,7 +18372,7 @@ least one character.
@end itemize
@node Examples of gnatxref Usage,Examples of gnatfind Usage,Regular Expressions in gnatfind and gnatxref,The Cross-Referencing Tools gnatxref and gnatfind
-@anchor{gnat_ugn/gnat_utility_programs examples-of-gnatxref-usage}@anchor{1e0}@anchor{gnat_ugn/gnat_utility_programs id14}@anchor{1e8}
+@anchor{gnat_ugn/gnat_utility_programs examples-of-gnatxref-usage}@anchor{154}@anchor{gnat_ugn/gnat_utility_programs id14}@anchor{15c}
@subsection Examples of @cite{gnatxref} Usage
@@ -24753,7 +18383,7 @@ least one character.
@end menu
@node General Usage,Using gnatxref with vi,,Examples of gnatxref Usage
-@anchor{gnat_ugn/gnat_utility_programs general-usage}@anchor{1e9}
+@anchor{gnat_ugn/gnat_utility_programs general-usage}@anchor{15d}
@subsubsection General Usage
@@ -24853,7 +18483,7 @@ of these.
@end quotation
@node Using gnatxref with vi,,General Usage,Examples of gnatxref Usage
-@anchor{gnat_ugn/gnat_utility_programs using-gnatxref-with-vi}@anchor{1ea}
+@anchor{gnat_ugn/gnat_utility_programs using-gnatxref-with-vi}@anchor{15e}
@subsubsection Using gnatxref with vi
@@ -24884,7 +18514,7 @@ From @emph{vi}, you can then use the command @code{:tag @emph{entity}}
display a new file with the corresponding declaration of entity.
@node Examples of gnatfind Usage,,Examples of gnatxref Usage,The Cross-Referencing Tools gnatxref and gnatfind
-@anchor{gnat_ugn/gnat_utility_programs id15}@anchor{1eb}@anchor{gnat_ugn/gnat_utility_programs examples-of-gnatfind-usage}@anchor{1e4}
+@anchor{gnat_ugn/gnat_utility_programs id15}@anchor{15f}@anchor{gnat_ugn/gnat_utility_programs examples-of-gnatfind-usage}@anchor{158}
@subsection Examples of @cite{gnatfind} Usage
@@ -24959,14 +18589,14 @@ point to any character in the middle of the identifier.
@end itemize
@node The Ada to HTML Converter gnathtml,,The Cross-Referencing Tools gnatxref and gnatfind,GNAT Utility Programs
-@anchor{gnat_ugn/gnat_utility_programs the-ada-to-html-converter-gnathtml}@anchor{25}@anchor{gnat_ugn/gnat_utility_programs id16}@anchor{1ec}
+@anchor{gnat_ugn/gnat_utility_programs the-ada-to-html-converter-gnathtml}@anchor{23}@anchor{gnat_ugn/gnat_utility_programs id16}@anchor{160}
@section The Ada to HTML Converter @cite{gnathtml}
@geindex gnathtml
@emph{gnathtml} is a Perl script that allows Ada source files to be browsed using
-standard Web browsers. For installation information, see @ref{1ed,,Installing gnathtml}.
+standard Web browsers. For installation information, see @ref{161,,Installing gnathtml}.
Ada reserved keywords are highlighted in a bold font and Ada comments in
a blue font. Unless your program was compiled with the gcc @emph{-gnatx}
@@ -24981,7 +18611,7 @@ be able to click on any identifier and go to its declaration.
@end menu
@node Invoking gnathtml,Installing gnathtml,,The Ada to HTML Converter gnathtml
-@anchor{gnat_ugn/gnat_utility_programs invoking-gnathtml}@anchor{1ee}@anchor{gnat_ugn/gnat_utility_programs id17}@anchor{1ef}
+@anchor{gnat_ugn/gnat_utility_programs invoking-gnathtml}@anchor{162}@anchor{gnat_ugn/gnat_utility_programs id17}@anchor{163}
@subsection Invoking @emph{gnathtml}
@@ -25147,7 +18777,7 @@ systems.
@end table
@node Installing gnathtml,,Invoking gnathtml,The Ada to HTML Converter gnathtml
-@anchor{gnat_ugn/gnat_utility_programs installing-gnathtml}@anchor{1ed}@anchor{gnat_ugn/gnat_utility_programs id18}@anchor{1f0}
+@anchor{gnat_ugn/gnat_utility_programs installing-gnathtml}@anchor{161}@anchor{gnat_ugn/gnat_utility_programs id18}@anchor{164}
@subsection Installing @cite{gnathtml}
@@ -25187,10 +18817,11 @@ $ perl gnathtml.pl [`switches`] `files`
+
@c -- Example: A |withing| unit has a |with| clause, it |withs| a |withed| unit
@node GNAT and Program Execution,Platform-Specific Information,GNAT Utility Programs,Top
-@anchor{gnat_ugn/gnat_and_program_execution gnat-and-program-execution}@anchor{e}@anchor{gnat_ugn/gnat_and_program_execution doc}@anchor{1f1}@anchor{gnat_ugn/gnat_and_program_execution id1}@anchor{1f2}
+@anchor{gnat_ugn/gnat_and_program_execution gnat-and-program-execution}@anchor{c}@anchor{gnat_ugn/gnat_and_program_execution doc}@anchor{165}@anchor{gnat_ugn/gnat_and_program_execution id1}@anchor{166}
@chapter GNAT and Program Execution
@@ -25200,25 +18831,25 @@ This chapter covers several topics:
@itemize *
@item
-@ref{1f3,,Running and Debugging Ada Programs}
+@ref{167,,Running and Debugging Ada Programs}
@item
-@ref{1f4,,Code Coverage and Profiling}
+@ref{168,,Code Coverage and Profiling}
@item
-@ref{1f5,,Improving Performance}
+@ref{169,,Improving Performance}
@item
-@ref{1f6,,Overflow Check Handling in GNAT}
+@ref{16a,,Overflow Check Handling in GNAT}
@item
-@ref{1f7,,Performing Dimensionality Analysis in GNAT}
+@ref{16b,,Performing Dimensionality Analysis in GNAT}
@item
-@ref{1f8,,Stack Related Facilities}
+@ref{16c,,Stack Related Facilities}
@item
-@ref{1f9,,Memory Management Issues}
+@ref{16d,,Memory Management Issues}
@end itemize
@menu
@@ -25233,7 +18864,7 @@ This chapter covers several topics:
@end menu
@node Running and Debugging Ada Programs,Code Coverage and Profiling,,GNAT and Program Execution
-@anchor{gnat_ugn/gnat_and_program_execution id2}@anchor{1f3}@anchor{gnat_ugn/gnat_and_program_execution running-and-debugging-ada-programs}@anchor{26}
+@anchor{gnat_ugn/gnat_and_program_execution id2}@anchor{167}@anchor{gnat_ugn/gnat_and_program_execution running-and-debugging-ada-programs}@anchor{24}
@section Running and Debugging Ada Programs
@@ -25286,7 +18917,7 @@ the incorrect user program.
@end menu
@node The GNAT Debugger GDB,Running GDB,,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution the-gnat-debugger-gdb}@anchor{1fa}@anchor{gnat_ugn/gnat_and_program_execution id3}@anchor{1fb}
+@anchor{gnat_ugn/gnat_and_program_execution the-gnat-debugger-gdb}@anchor{16e}@anchor{gnat_ugn/gnat_and_program_execution id3}@anchor{16f}
@subsection The GNAT Debugger GDB
@@ -25343,7 +18974,7 @@ the debugging information and can respond to user commands to inspect
variables, and more generally to report on the state of execution.
@node Running GDB,Introduction to GDB Commands,The GNAT Debugger GDB,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution id4}@anchor{1fc}@anchor{gnat_ugn/gnat_and_program_execution running-gdb}@anchor{1fd}
+@anchor{gnat_ugn/gnat_and_program_execution id4}@anchor{170}@anchor{gnat_ugn/gnat_and_program_execution running-gdb}@anchor{171}
@subsection Running GDB
@@ -25370,7 +19001,7 @@ exactly as if the debugger were not present. The following section
describes some of the additional commands that can be given to @cite{GDB}.
@node Introduction to GDB Commands,Using Ada Expressions,Running GDB,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution introduction-to-gdb-commands}@anchor{1fe}@anchor{gnat_ugn/gnat_and_program_execution id5}@anchor{1ff}
+@anchor{gnat_ugn/gnat_and_program_execution introduction-to-gdb-commands}@anchor{172}@anchor{gnat_ugn/gnat_and_program_execution id5}@anchor{173}
@subsection Introduction to GDB Commands
@@ -25578,7 +19209,7 @@ Note that most commands can be abbreviated
(for example, c for continue, bt for backtrace).
@node Using Ada Expressions,Calling User-Defined Subprograms,Introduction to GDB Commands,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution id6}@anchor{200}@anchor{gnat_ugn/gnat_and_program_execution using-ada-expressions}@anchor{201}
+@anchor{gnat_ugn/gnat_and_program_execution id6}@anchor{174}@anchor{gnat_ugn/gnat_and_program_execution using-ada-expressions}@anchor{175}
@subsection Using Ada Expressions
@@ -25616,7 +19247,7 @@ their packages, regardless of context. Where this causes ambiguity,
For details on the supported Ada syntax, see @cite{Debugging with GDB}.
@node Calling User-Defined Subprograms,Using the next Command in a Function,Using Ada Expressions,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution id7}@anchor{202}@anchor{gnat_ugn/gnat_and_program_execution calling-user-defined-subprograms}@anchor{203}
+@anchor{gnat_ugn/gnat_and_program_execution id7}@anchor{176}@anchor{gnat_ugn/gnat_and_program_execution calling-user-defined-subprograms}@anchor{177}
@subsection Calling User-Defined Subprograms
@@ -25675,7 +19306,7 @@ elements directly from GDB, you can write a callable procedure that prints
the elements in the desired format.
@node Using the next Command in a Function,Stopping When Ada Exceptions Are Raised,Calling User-Defined Subprograms,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution using-the-next-command-in-a-function}@anchor{204}@anchor{gnat_ugn/gnat_and_program_execution id8}@anchor{205}
+@anchor{gnat_ugn/gnat_and_program_execution using-the-next-command-in-a-function}@anchor{178}@anchor{gnat_ugn/gnat_and_program_execution id8}@anchor{179}
@subsection Using the @emph{next} Command in a Function
@@ -25698,7 +19329,7 @@ The value returned is always that from the first return statement
that was stepped through.
@node Stopping When Ada Exceptions Are Raised,Ada Tasks,Using the next Command in a Function,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution stopping-when-ada-exceptions-are-raised}@anchor{206}@anchor{gnat_ugn/gnat_and_program_execution id9}@anchor{207}
+@anchor{gnat_ugn/gnat_and_program_execution stopping-when-ada-exceptions-are-raised}@anchor{17a}@anchor{gnat_ugn/gnat_and_program_execution id9}@anchor{17b}
@subsection Stopping When Ada Exceptions Are Raised
@@ -25755,7 +19386,7 @@ argument, prints out only those exceptions whose name matches @cite{regexp}.
@geindex Tasks (in gdb)
@node Ada Tasks,Debugging Generic Units,Stopping When Ada Exceptions Are Raised,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution ada-tasks}@anchor{208}@anchor{gnat_ugn/gnat_and_program_execution id10}@anchor{209}
+@anchor{gnat_ugn/gnat_and_program_execution ada-tasks}@anchor{17c}@anchor{gnat_ugn/gnat_and_program_execution id10}@anchor{17d}
@subsection Ada Tasks
@@ -25842,7 +19473,7 @@ see @cite{Debugging with GDB}.
@geindex Generics
@node Debugging Generic Units,Remote Debugging with gdbserver,Ada Tasks,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution debugging-generic-units}@anchor{20a}@anchor{gnat_ugn/gnat_and_program_execution id11}@anchor{20b}
+@anchor{gnat_ugn/gnat_and_program_execution debugging-generic-units}@anchor{17e}@anchor{gnat_ugn/gnat_and_program_execution id11}@anchor{17f}
@subsection Debugging Generic Units
@@ -25901,7 +19532,7 @@ other units.
@geindex Remote Debugging with gdbserver
@node Remote Debugging with gdbserver,GNAT Abnormal Termination or Failure to Terminate,Debugging Generic Units,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution remote-debugging-with-gdbserver}@anchor{20c}@anchor{gnat_ugn/gnat_and_program_execution id12}@anchor{20d}
+@anchor{gnat_ugn/gnat_and_program_execution remote-debugging-with-gdbserver}@anchor{180}@anchor{gnat_ugn/gnat_and_program_execution id12}@anchor{181}
@subsection Remote Debugging with gdbserver
@@ -25959,7 +19590,7 @@ GNAT provides support for gdbserver on x86-linux, x86-windows and x86_64-linux.
@geindex Abnormal Termination or Failure to Terminate
@node GNAT Abnormal Termination or Failure to Terminate,Naming Conventions for GNAT Source Files,Remote Debugging with gdbserver,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution gnat-abnormal-termination-or-failure-to-terminate}@anchor{20e}@anchor{gnat_ugn/gnat_and_program_execution id13}@anchor{20f}
+@anchor{gnat_ugn/gnat_and_program_execution gnat-abnormal-termination-or-failure-to-terminate}@anchor{182}@anchor{gnat_ugn/gnat_and_program_execution id13}@anchor{183}
@subsection GNAT Abnormal Termination or Failure to Terminate
@@ -26014,7 +19645,7 @@ Finally, you can start
@cite{gdb} directly on the @cite{gnat1} executable. @cite{gnat1} is the
front-end of GNAT, and can be run independently (normally it is just
called from @emph{gcc}). You can use @cite{gdb} on @cite{gnat1} as you
-would on a C program (but @ref{1fa,,The GNAT Debugger GDB} for caveats). The
+would on a C program (but @ref{16e,,The GNAT Debugger GDB} for caveats). The
@cite{where} command is the first line of attack; the variable
@cite{lineno} (seen by @cite{print lineno}), used by the second phase of
@cite{gnat1} and by the @emph{gcc} backend, indicates the source line at
@@ -26023,7 +19654,7 @@ the source file.
@end itemize
@node Naming Conventions for GNAT Source Files,Getting Internal Debugging Information,GNAT Abnormal Termination or Failure to Terminate,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution naming-conventions-for-gnat-source-files}@anchor{210}@anchor{gnat_ugn/gnat_and_program_execution id14}@anchor{211}
+@anchor{gnat_ugn/gnat_and_program_execution naming-conventions-for-gnat-source-files}@anchor{184}@anchor{gnat_ugn/gnat_and_program_execution id14}@anchor{185}
@subsection Naming Conventions for GNAT Source Files
@@ -26104,7 +19735,7 @@ the other @code{.c} files are modifications of common @emph{gcc} files.
@end itemize
@node Getting Internal Debugging Information,Stack Traceback,Naming Conventions for GNAT Source Files,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution id15}@anchor{212}@anchor{gnat_ugn/gnat_and_program_execution getting-internal-debugging-information}@anchor{213}
+@anchor{gnat_ugn/gnat_and_program_execution id15}@anchor{186}@anchor{gnat_ugn/gnat_and_program_execution getting-internal-debugging-information}@anchor{187}
@subsection Getting Internal Debugging Information
@@ -26132,7 +19763,7 @@ are replaced with run-time calls.
@geindex stack unwinding
@node Stack Traceback,,Getting Internal Debugging Information,Running and Debugging Ada Programs
-@anchor{gnat_ugn/gnat_and_program_execution stack-traceback}@anchor{214}@anchor{gnat_ugn/gnat_and_program_execution id16}@anchor{215}
+@anchor{gnat_ugn/gnat_and_program_execution stack-traceback}@anchor{188}@anchor{gnat_ugn/gnat_and_program_execution id16}@anchor{189}
@subsection Stack Traceback
@@ -26161,7 +19792,7 @@ is enabled, and no exception is raised during program execution.
@end menu
@node Non-Symbolic Traceback,Symbolic Traceback,,Stack Traceback
-@anchor{gnat_ugn/gnat_and_program_execution non-symbolic-traceback}@anchor{216}@anchor{gnat_ugn/gnat_and_program_execution id17}@anchor{217}
+@anchor{gnat_ugn/gnat_and_program_execution non-symbolic-traceback}@anchor{18a}@anchor{gnat_ugn/gnat_and_program_execution id17}@anchor{18b}
@subsubsection Non-Symbolic Traceback
@@ -26288,7 +19919,7 @@ From this traceback we can see that the exception was raised in
@code{stb.adb} at line 5, which was reached from a procedure call in
@code{stb.adb} at line 10, and so on. The @code{b~std.adb} is the binder file,
which contains the call to the main program.
-@ref{123,,Running gnatbind}. The remaining entries are assorted runtime routines,
+@ref{11c,,Running gnatbind}. The remaining entries are assorted runtime routines,
and the output will vary from platform to platform.
It is also possible to use @cite{GDB} with these traceback addresses to debug
@@ -26446,7 +20077,7 @@ need to be specified in C format, with a leading '0x').
@geindex symbolic
@node Symbolic Traceback,,Non-Symbolic Traceback,Stack Traceback
-@anchor{gnat_ugn/gnat_and_program_execution id18}@anchor{218}@anchor{gnat_ugn/gnat_and_program_execution symbolic-traceback}@anchor{219}
+@anchor{gnat_ugn/gnat_and_program_execution id18}@anchor{18c}@anchor{gnat_ugn/gnat_and_program_execution symbolic-traceback}@anchor{18d}
@subsubsection Symbolic Traceback
@@ -26578,7 +20209,7 @@ program.
@geindex Profiling
@node Code Coverage and Profiling,Improving Performance,Running and Debugging Ada Programs,GNAT and Program Execution
-@anchor{gnat_ugn/gnat_and_program_execution id19}@anchor{1f4}@anchor{gnat_ugn/gnat_and_program_execution code-coverage-and-profiling}@anchor{27}
+@anchor{gnat_ugn/gnat_and_program_execution id19}@anchor{168}@anchor{gnat_ugn/gnat_and_program_execution code-coverage-and-profiling}@anchor{25}
@section Code Coverage and Profiling
@@ -26594,7 +20225,7 @@ the @cite{gprof} profiler tool on Ada programs.
@end menu
@node Code Coverage of Ada Programs with gcov,Profiling an Ada Program with gprof,,Code Coverage and Profiling
-@anchor{gnat_ugn/gnat_and_program_execution id20}@anchor{21a}@anchor{gnat_ugn/gnat_and_program_execution code-coverage-of-ada-programs-with-gcov}@anchor{21b}
+@anchor{gnat_ugn/gnat_and_program_execution id20}@anchor{18e}@anchor{gnat_ugn/gnat_and_program_execution code-coverage-of-ada-programs-with-gcov}@anchor{18f}
@subsection Code Coverage of Ada Programs with gcov
@@ -26616,7 +20247,7 @@ details some GNAT-specific features.
@end menu
@node Quick startup guide,GNAT specifics,,Code Coverage of Ada Programs with gcov
-@anchor{gnat_ugn/gnat_and_program_execution id21}@anchor{21c}@anchor{gnat_ugn/gnat_and_program_execution quick-startup-guide}@anchor{21d}
+@anchor{gnat_ugn/gnat_and_program_execution id21}@anchor{190}@anchor{gnat_ugn/gnat_and_program_execution quick-startup-guide}@anchor{191}
@subsubsection Quick startup guide
@@ -26675,7 +20306,7 @@ This will create annotated source files with a @code{.gcov} extension:
@code{my_main.adb} file will be analyzed in @code{my_main.adb.gcov}.
@node GNAT specifics,,Quick startup guide,Code Coverage of Ada Programs with gcov
-@anchor{gnat_ugn/gnat_and_program_execution gnat-specifics}@anchor{21e}@anchor{gnat_ugn/gnat_and_program_execution id22}@anchor{21f}
+@anchor{gnat_ugn/gnat_and_program_execution gnat-specifics}@anchor{192}@anchor{gnat_ugn/gnat_and_program_execution id22}@anchor{193}
@subsubsection GNAT specifics
@@ -26700,7 +20331,7 @@ not supported as there can be unresolved symbols during the final link.
@geindex Profiling
@node Profiling an Ada Program with gprof,,Code Coverage of Ada Programs with gcov,Code Coverage and Profiling
-@anchor{gnat_ugn/gnat_and_program_execution profiling-an-ada-program-with-gprof}@anchor{220}@anchor{gnat_ugn/gnat_and_program_execution id23}@anchor{221}
+@anchor{gnat_ugn/gnat_and_program_execution profiling-an-ada-program-with-gprof}@anchor{194}@anchor{gnat_ugn/gnat_and_program_execution id23}@anchor{195}
@subsection Profiling an Ada Program with gprof
@@ -26757,7 +20388,7 @@ to interpret the results.
@end menu
@node Compilation for profiling,Program execution,,Profiling an Ada Program with gprof
-@anchor{gnat_ugn/gnat_and_program_execution id24}@anchor{222}@anchor{gnat_ugn/gnat_and_program_execution compilation-for-profiling}@anchor{223}
+@anchor{gnat_ugn/gnat_and_program_execution id24}@anchor{196}@anchor{gnat_ugn/gnat_and_program_execution compilation-for-profiling}@anchor{197}
@subsubsection Compilation for profiling
@@ -26785,7 +20416,7 @@ be profiled; if you need to profile your whole project, use the @code{-f}
gnatmake switch to force full recompilation.
@node Program execution,Running gprof,Compilation for profiling,Profiling an Ada Program with gprof
-@anchor{gnat_ugn/gnat_and_program_execution program-execution}@anchor{224}@anchor{gnat_ugn/gnat_and_program_execution id25}@anchor{225}
+@anchor{gnat_ugn/gnat_and_program_execution program-execution}@anchor{198}@anchor{gnat_ugn/gnat_and_program_execution id25}@anchor{199}
@subsubsection Program execution
@@ -26800,7 +20431,7 @@ generated in the directory where the program was launched from. If this file
already exists, it will be overwritten.
@node Running gprof,Interpretation of profiling results,Program execution,Profiling an Ada Program with gprof
-@anchor{gnat_ugn/gnat_and_program_execution running-gprof}@anchor{226}@anchor{gnat_ugn/gnat_and_program_execution id26}@anchor{227}
+@anchor{gnat_ugn/gnat_and_program_execution running-gprof}@anchor{19a}@anchor{gnat_ugn/gnat_and_program_execution id26}@anchor{19b}
@subsubsection Running gprof
@@ -26913,7 +20544,7 @@ may be given; only one @cite{function_name} may be indicated with each
@end table
@node Interpretation of profiling results,,Running gprof,Profiling an Ada Program with gprof
-@anchor{gnat_ugn/gnat_and_program_execution id27}@anchor{228}@anchor{gnat_ugn/gnat_and_program_execution interpretation-of-profiling-results}@anchor{229}
+@anchor{gnat_ugn/gnat_and_program_execution id27}@anchor{19c}@anchor{gnat_ugn/gnat_and_program_execution interpretation-of-profiling-results}@anchor{19d}
@subsubsection Interpretation of profiling results
@@ -26930,7 +20561,7 @@ and the subprograms that it calls. It also provides an estimate of the time
spent in each of those callers/called subprograms.
@node Improving Performance,Overflow Check Handling in GNAT,Code Coverage and Profiling,GNAT and Program Execution
-@anchor{gnat_ugn/gnat_and_program_execution improving-performance}@anchor{28}@anchor{gnat_ugn/gnat_and_program_execution id28}@anchor{1f5}
+@anchor{gnat_ugn/gnat_and_program_execution improving-performance}@anchor{26}@anchor{gnat_ugn/gnat_and_program_execution id28}@anchor{169}
@section Improving Performance
@@ -26952,7 +20583,7 @@ which can reduce the size of program executables.
@end menu
@node Performance Considerations,Text_IO Suggestions,,Improving Performance
-@anchor{gnat_ugn/gnat_and_program_execution id29}@anchor{22a}@anchor{gnat_ugn/gnat_and_program_execution performance-considerations}@anchor{22b}
+@anchor{gnat_ugn/gnat_and_program_execution id29}@anchor{19e}@anchor{gnat_ugn/gnat_and_program_execution performance-considerations}@anchor{19f}
@subsection Performance Considerations
@@ -27013,7 +20644,7 @@ some guidelines on debugging optimized code.
@end menu
@node Controlling Run-Time Checks,Use of Restrictions,,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution controlling-run-time-checks}@anchor{22c}@anchor{gnat_ugn/gnat_and_program_execution id30}@anchor{22d}
+@anchor{gnat_ugn/gnat_and_program_execution controlling-run-time-checks}@anchor{1a0}@anchor{gnat_ugn/gnat_and_program_execution id30}@anchor{1a1}
@subsubsection Controlling Run-Time Checks
@@ -27027,7 +20658,7 @@ necessary checking is done at compile time.
@geindex -gnato (gcc)
The gnat switch, @emph{-gnatp} allows this default to be modified. See
-@ref{101,,Run-Time Checks}.
+@ref{f9,,Run-Time Checks}.
Our experience is that the default is suitable for most development
purposes.
@@ -27065,7 +20696,7 @@ remove checks) or @cite{pragma Unsuppress} (to add back suppressed
checks) in the program source.
@node Use of Restrictions,Optimization Levels,Controlling Run-Time Checks,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution use-of-restrictions}@anchor{22e}@anchor{gnat_ugn/gnat_and_program_execution id31}@anchor{22f}
+@anchor{gnat_ugn/gnat_and_program_execution use-of-restrictions}@anchor{1a2}@anchor{gnat_ugn/gnat_and_program_execution id31}@anchor{1a3}
@subsubsection Use of Restrictions
@@ -27100,7 +20731,7 @@ that this also means that you can write code without worrying about the
possibility of an immediate abort at any point.
@node Optimization Levels,Debugging Optimized Code,Use of Restrictions,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution id32}@anchor{230}@anchor{gnat_ugn/gnat_and_program_execution optimization-levels}@anchor{104}
+@anchor{gnat_ugn/gnat_and_program_execution id32}@anchor{1a4}@anchor{gnat_ugn/gnat_and_program_execution optimization-levels}@anchor{fc}
@subsubsection Optimization Levels
@@ -27182,7 +20813,7 @@ the slowest compilation time.
Full optimization as in @emph{-O2};
also uses more aggressive automatic inlining of subprograms within a unit
-(@ref{117,,Inlining of Subprograms}) and attempts to vectorize loops.
+(@ref{10f,,Inlining of Subprograms}) and attempts to vectorize loops.
@end table
@item
@@ -27222,10 +20853,10 @@ levels.
Note regarding the use of @emph{-O3}: The use of this optimization level
is generally discouraged with GNAT, since it often results in larger
executables which may run more slowly. See further discussion of this point
-in @ref{117,,Inlining of Subprograms}.
+in @ref{10f,,Inlining of Subprograms}.
@node Debugging Optimized Code,Inlining of Subprograms,Optimization Levels,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution id33}@anchor{231}@anchor{gnat_ugn/gnat_and_program_execution debugging-optimized-code}@anchor{232}
+@anchor{gnat_ugn/gnat_and_program_execution id33}@anchor{1a5}@anchor{gnat_ugn/gnat_and_program_execution debugging-optimized-code}@anchor{1a6}
@subsubsection Debugging Optimized Code
@@ -27353,7 +20984,7 @@ on the resulting executable,
which removes both debugging information and global symbols.
@node Inlining of Subprograms,Floating_Point_Operations,Debugging Optimized Code,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution id34}@anchor{233}@anchor{gnat_ugn/gnat_and_program_execution inlining-of-subprograms}@anchor{117}
+@anchor{gnat_ugn/gnat_and_program_execution id34}@anchor{1a7}@anchor{gnat_ugn/gnat_and_program_execution inlining-of-subprograms}@anchor{10f}
@subsubsection Inlining of Subprograms
@@ -27377,10 +21008,9 @@ subprograms.
@item
Any one of the following applies: @cite{pragma Inline} is applied to the
-subprogram and the @emph{-gnatn} switch is specified; the
-subprogram is local to the unit and called once from within it; the
-subprogram is small and optimization level @emph{-O2} is specified;
-optimization level @emph{-O3} is specified.
+subprogram; the subprogram is local to the unit and called once from
+within it; the subprogram is small and optimization level @emph{-O2} is
+specified; optimization level @emph{-O3} is specified.
@end itemize
Calls to subprograms in @emph{with}ed units are normally not inlined.
@@ -27399,9 +21029,6 @@ and not contain something that @emph{gcc} cannot support in inlined
subprograms.
@item
-The call appears in a body (not in a package spec).
-
-@item
There is a @cite{pragma Inline} for the subprogram.
@item
@@ -27456,7 +21083,7 @@ additional dependencies.
@geindex -fno-inline (gcc)
Note: The @emph{-fno-inline} switch overrides all other conditions and ensures that
-no inlining occurs, unless requested with pragma Inline_Always for gcc
+no inlining occurs, unless requested with pragma Inline_Always for @emph{gcc}
back-ends. The extra dependences resulting from @emph{-gnatn} will still be active,
even if this switch is used to suppress the resulting inlining actions.
@@ -27496,7 +21123,7 @@ indeed you should use @emph{-O3} only if tests show that it actually
improves performance for your program.
@node Floating_Point_Operations,Vectorization of loops,Inlining of Subprograms,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution floating-point-operations}@anchor{234}@anchor{gnat_ugn/gnat_and_program_execution id35}@anchor{235}
+@anchor{gnat_ugn/gnat_and_program_execution floating-point-operations}@anchor{1a8}@anchor{gnat_ugn/gnat_and_program_execution id35}@anchor{1a9}
@subsubsection Floating_Point_Operations
@@ -27544,7 +21171,7 @@ so it is permissible to mix units compiled with and without these
switches.
@node Vectorization of loops,Other Optimization Switches,Floating_Point_Operations,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution id36}@anchor{236}@anchor{gnat_ugn/gnat_and_program_execution vectorization-of-loops}@anchor{237}
+@anchor{gnat_ugn/gnat_and_program_execution id36}@anchor{1aa}@anchor{gnat_ugn/gnat_and_program_execution vectorization-of-loops}@anchor{1ab}
@subsubsection Vectorization of loops
@@ -27695,7 +21322,7 @@ placed immediately within the loop will tell the compiler that it can safely
omit the non-vectorized version of the loop as well as the run-time test.
@node Other Optimization Switches,Optimization and Strict Aliasing,Vectorization of loops,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution id37}@anchor{238}@anchor{gnat_ugn/gnat_and_program_execution other-optimization-switches}@anchor{239}
+@anchor{gnat_ugn/gnat_and_program_execution id37}@anchor{1ac}@anchor{gnat_ugn/gnat_and_program_execution other-optimization-switches}@anchor{1ad}
@subsubsection Other Optimization Switches
@@ -27712,7 +21339,7 @@ the @cite{Submodel Options} section in the @cite{Hardware Models and Configurati
chapter of @cite{Using the GNU Compiler Collection (GCC)}.
@node Optimization and Strict Aliasing,Aliased Variables and Optimization,Other Optimization Switches,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution optimization-and-strict-aliasing}@anchor{fb}@anchor{gnat_ugn/gnat_and_program_execution id38}@anchor{23a}
+@anchor{gnat_ugn/gnat_and_program_execution optimization-and-strict-aliasing}@anchor{f3}@anchor{gnat_ugn/gnat_and_program_execution id38}@anchor{1ae}
@subsubsection Optimization and Strict Aliasing
@@ -27952,7 +21579,7 @@ review any uses of unchecked conversion of access types,
particularly if you are getting the warnings described above.
@node Aliased Variables and Optimization,Atomic Variables and Optimization,Optimization and Strict Aliasing,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution aliased-variables-and-optimization}@anchor{23b}@anchor{gnat_ugn/gnat_and_program_execution id39}@anchor{23c}
+@anchor{gnat_ugn/gnat_and_program_execution aliased-variables-and-optimization}@anchor{1af}@anchor{gnat_ugn/gnat_and_program_execution id39}@anchor{1b0}
@subsubsection Aliased Variables and Optimization
@@ -28010,7 +21637,7 @@ This means that the above example will in fact "work" reliably,
that is, it will produce the expected results.
@node Atomic Variables and Optimization,Passive Task Optimization,Aliased Variables and Optimization,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution atomic-variables-and-optimization}@anchor{23d}@anchor{gnat_ugn/gnat_and_program_execution id40}@anchor{23e}
+@anchor{gnat_ugn/gnat_and_program_execution atomic-variables-and-optimization}@anchor{1b1}@anchor{gnat_ugn/gnat_and_program_execution id40}@anchor{1b2}
@subsubsection Atomic Variables and Optimization
@@ -28091,7 +21718,7 @@ such synchronization code is not required, it may be
useful to disable it.
@node Passive Task Optimization,,Atomic Variables and Optimization,Performance Considerations
-@anchor{gnat_ugn/gnat_and_program_execution id41}@anchor{23f}@anchor{gnat_ugn/gnat_and_program_execution passive-task-optimization}@anchor{240}
+@anchor{gnat_ugn/gnat_and_program_execution id41}@anchor{1b3}@anchor{gnat_ugn/gnat_and_program_execution passive-task-optimization}@anchor{1b4}
@subsubsection Passive Task Optimization
@@ -28136,7 +21763,7 @@ that typically clients of the tasks who call entries, will not have
to be modified, only the task definition itself.
@node Text_IO Suggestions,Reducing Size of Executables with Unused Subprogram/Data Elimination,Performance Considerations,Improving Performance
-@anchor{gnat_ugn/gnat_and_program_execution text-io-suggestions}@anchor{241}@anchor{gnat_ugn/gnat_and_program_execution id42}@anchor{242}
+@anchor{gnat_ugn/gnat_and_program_execution text-io-suggestions}@anchor{1b5}@anchor{gnat_ugn/gnat_and_program_execution id42}@anchor{1b6}
@subsection @cite{Text_IO} Suggestions
@@ -28159,7 +21786,7 @@ of the standard output file, or change the standard output file to
be buffered using @cite{Interfaces.C_Streams.setvbuf}.
@node Reducing Size of Executables with Unused Subprogram/Data Elimination,,Text_IO Suggestions,Improving Performance
-@anchor{gnat_ugn/gnat_and_program_execution id43}@anchor{243}@anchor{gnat_ugn/gnat_and_program_execution reducing-size-of-executables-with-unused-subprogram-data-elimination}@anchor{244}
+@anchor{gnat_ugn/gnat_and_program_execution id43}@anchor{1b7}@anchor{gnat_ugn/gnat_and_program_execution reducing-size-of-executables-with-unused-subprogram-data-elimination}@anchor{1b8}
@subsection Reducing Size of Executables with Unused Subprogram/Data Elimination
@@ -28176,7 +21803,7 @@ your executable just by setting options at compilation time.
@end menu
@node About unused subprogram/data elimination,Compilation options,,Reducing Size of Executables with Unused Subprogram/Data Elimination
-@anchor{gnat_ugn/gnat_and_program_execution id44}@anchor{245}@anchor{gnat_ugn/gnat_and_program_execution about-unused-subprogram-data-elimination}@anchor{246}
+@anchor{gnat_ugn/gnat_and_program_execution id44}@anchor{1b9}@anchor{gnat_ugn/gnat_and_program_execution about-unused-subprogram-data-elimination}@anchor{1ba}
@subsubsection About unused subprogram/data elimination
@@ -28192,7 +21819,7 @@ architecture and on all cross platforms using the ELF binary file format.
In both cases GNU binutils version 2.16 or later are required to enable it.
@node Compilation options,Example of unused subprogram/data elimination,About unused subprogram/data elimination,Reducing Size of Executables with Unused Subprogram/Data Elimination
-@anchor{gnat_ugn/gnat_and_program_execution id45}@anchor{247}@anchor{gnat_ugn/gnat_and_program_execution compilation-options}@anchor{248}
+@anchor{gnat_ugn/gnat_and_program_execution id45}@anchor{1bb}@anchor{gnat_ugn/gnat_and_program_execution compilation-options}@anchor{1bc}
@subsubsection Compilation options
@@ -28231,7 +21858,7 @@ The GNAT static library is now compiled with -ffunction-sections and
and data of the GNAT library from your executable.
@node Example of unused subprogram/data elimination,,Compilation options,Reducing Size of Executables with Unused Subprogram/Data Elimination
-@anchor{gnat_ugn/gnat_and_program_execution id46}@anchor{249}@anchor{gnat_ugn/gnat_and_program_execution example-of-unused-subprogram-data-elimination}@anchor{24a}
+@anchor{gnat_ugn/gnat_and_program_execution id46}@anchor{1bd}@anchor{gnat_ugn/gnat_and_program_execution example-of-unused-subprogram-data-elimination}@anchor{1be}
@subsubsection Example of unused subprogram/data elimination
@@ -28302,7 +21929,7 @@ appropriate options.
@node Overflow Check Handling in GNAT,Performing Dimensionality Analysis in GNAT,Improving Performance,GNAT and Program Execution
-@anchor{gnat_ugn/gnat_and_program_execution id54}@anchor{1f6}@anchor{gnat_ugn/gnat_and_program_execution overflow-check-handling-in-gnat}@anchor{29}
+@anchor{gnat_ugn/gnat_and_program_execution id54}@anchor{16a}@anchor{gnat_ugn/gnat_and_program_execution overflow-check-handling-in-gnat}@anchor{27}
@section Overflow Check Handling in GNAT
@@ -28318,7 +21945,7 @@ This section explains how to control the handling of overflow checks.
@end menu
@node Background,Management of Overflows in GNAT,,Overflow Check Handling in GNAT
-@anchor{gnat_ugn/gnat_and_program_execution id55}@anchor{24b}@anchor{gnat_ugn/gnat_and_program_execution background}@anchor{24c}
+@anchor{gnat_ugn/gnat_and_program_execution id55}@anchor{1bf}@anchor{gnat_ugn/gnat_and_program_execution background}@anchor{1c0}
@subsection Background
@@ -28444,7 +22071,7 @@ exception raised because of the intermediate overflow (and we really
would prefer this precondition to be considered True at run time).
@node Management of Overflows in GNAT,Specifying the Desired Mode,Background,Overflow Check Handling in GNAT
-@anchor{gnat_ugn/gnat_and_program_execution id56}@anchor{24d}@anchor{gnat_ugn/gnat_and_program_execution management-of-overflows-in-gnat}@anchor{24e}
+@anchor{gnat_ugn/gnat_and_program_execution id56}@anchor{1c1}@anchor{gnat_ugn/gnat_and_program_execution management-of-overflows-in-gnat}@anchor{1c2}
@subsection Management of Overflows in GNAT
@@ -28541,7 +22168,7 @@ but overflow is impossible.
Note that these modes apply only to the evaluation of predefined
arithmetic, membership, and comparison operators for signed integer
-aritmetic.
+arithmetic.
For fixed-point arithmetic, checks can be suppressed. But if checks
are enabled
@@ -28558,7 +22185,7 @@ out in the normal manner (with infinite values always failing all
range checks).
@node Specifying the Desired Mode,Default Settings,Management of Overflows in GNAT,Overflow Check Handling in GNAT
-@anchor{gnat_ugn/gnat_and_program_execution specifying-the-desired-mode}@anchor{100}@anchor{gnat_ugn/gnat_and_program_execution id57}@anchor{24f}
+@anchor{gnat_ugn/gnat_and_program_execution specifying-the-desired-mode}@anchor{f8}@anchor{gnat_ugn/gnat_and_program_execution id57}@anchor{1c3}
@subsection Specifying the Desired Mode
@@ -28683,7 +22310,7 @@ causing all intermediate operations to be computed using the base
type (@cite{STRICT} mode).
@node Default Settings,Implementation Notes,Specifying the Desired Mode,Overflow Check Handling in GNAT
-@anchor{gnat_ugn/gnat_and_program_execution id58}@anchor{250}@anchor{gnat_ugn/gnat_and_program_execution default-settings}@anchor{251}
+@anchor{gnat_ugn/gnat_and_program_execution id58}@anchor{1c4}@anchor{gnat_ugn/gnat_and_program_execution default-settings}@anchor{1c5}
@subsection Default Settings
@@ -28730,7 +22357,7 @@ checking, but it has no effect on the method used for computing
intermediate results.
@node Implementation Notes,,Default Settings,Overflow Check Handling in GNAT
-@anchor{gnat_ugn/gnat_and_program_execution implementation-notes}@anchor{252}@anchor{gnat_ugn/gnat_and_program_execution id59}@anchor{253}
+@anchor{gnat_ugn/gnat_and_program_execution implementation-notes}@anchor{1c6}@anchor{gnat_ugn/gnat_and_program_execution id59}@anchor{1c7}
@subsection Implementation Notes
@@ -28778,7 +22405,7 @@ platforms for which @cite{Long_Long_Integer} is 64-bits (nearly all GNAT
platforms).
@node Performing Dimensionality Analysis in GNAT,Stack Related Facilities,Overflow Check Handling in GNAT,GNAT and Program Execution
-@anchor{gnat_ugn/gnat_and_program_execution performing-dimensionality-analysis-in-gnat}@anchor{2a}@anchor{gnat_ugn/gnat_and_program_execution id60}@anchor{1f7}
+@anchor{gnat_ugn/gnat_and_program_execution performing-dimensionality-analysis-in-gnat}@anchor{28}@anchor{gnat_ugn/gnat_and_program_execution id60}@anchor{16b}
@section Performing Dimensionality Analysis in GNAT
@@ -28980,7 +22607,7 @@ Final velocity: 98.10 m.s**(-1)
@end quotation
@node Stack Related Facilities,Memory Management Issues,Performing Dimensionality Analysis in GNAT,GNAT and Program Execution
-@anchor{gnat_ugn/gnat_and_program_execution id61}@anchor{1f8}@anchor{gnat_ugn/gnat_and_program_execution stack-related-facilities}@anchor{2b}
+@anchor{gnat_ugn/gnat_and_program_execution id61}@anchor{16c}@anchor{gnat_ugn/gnat_and_program_execution stack-related-facilities}@anchor{29}
@section Stack Related Facilities
@@ -28996,7 +22623,7 @@ particular, it deals with dynamic and static stack usage measurements.
@end menu
@node Stack Overflow Checking,Static Stack Usage Analysis,,Stack Related Facilities
-@anchor{gnat_ugn/gnat_and_program_execution id62}@anchor{254}@anchor{gnat_ugn/gnat_and_program_execution stack-overflow-checking}@anchor{fc}
+@anchor{gnat_ugn/gnat_and_program_execution id62}@anchor{1c8}@anchor{gnat_ugn/gnat_and_program_execution stack-overflow-checking}@anchor{f4}
@subsection Stack Overflow Checking
@@ -29033,7 +22660,7 @@ If the space is exceeded, then a @cite{Storage_Error} exception is raised.
For declared tasks, the stack size is controlled by the size
given in an applicable @cite{Storage_Size} pragma or by the value specified
-at bind time with @code{-d} (@ref{126,,Switches for gnatbind}) or is set to
+at bind time with @code{-d} (@ref{11f,,Switches for gnatbind}) or is set to
the default size as defined in the GNAT runtime otherwise.
@geindex GNAT_STACK_LIMIT
@@ -29065,7 +22692,7 @@ is an operating systems issue, and must be addressed with the
appropriate operating systems commands.
@node Static Stack Usage Analysis,Dynamic Stack Usage Analysis,Stack Overflow Checking,Stack Related Facilities
-@anchor{gnat_ugn/gnat_and_program_execution static-stack-usage-analysis}@anchor{fd}@anchor{gnat_ugn/gnat_and_program_execution id63}@anchor{255}
+@anchor{gnat_ugn/gnat_and_program_execution static-stack-usage-analysis}@anchor{f5}@anchor{gnat_ugn/gnat_and_program_execution id63}@anchor{1c9}
@subsection Static Stack Usage Analysis
@@ -29114,7 +22741,7 @@ subprogram whose stack usage might be larger than the specified amount of
bytes. The wording is in keeping with the qualifier documented above.
@node Dynamic Stack Usage Analysis,,Static Stack Usage Analysis,Stack Related Facilities
-@anchor{gnat_ugn/gnat_and_program_execution id64}@anchor{256}@anchor{gnat_ugn/gnat_and_program_execution dynamic-stack-usage-analysis}@anchor{128}
+@anchor{gnat_ugn/gnat_and_program_execution id64}@anchor{1ca}@anchor{gnat_ugn/gnat_and_program_execution dynamic-stack-usage-analysis}@anchor{121}
@subsection Dynamic Stack Usage Analysis
@@ -29181,7 +22808,7 @@ The package @cite{GNAT.Task_Stack_Usage} provides facilities to get
stack usage reports at run-time. See its body for the details.
@node Memory Management Issues,,Stack Related Facilities,GNAT and Program Execution
-@anchor{gnat_ugn/gnat_and_program_execution id65}@anchor{1f9}@anchor{gnat_ugn/gnat_and_program_execution memory-management-issues}@anchor{2c}
+@anchor{gnat_ugn/gnat_and_program_execution id65}@anchor{16d}@anchor{gnat_ugn/gnat_and_program_execution memory-management-issues}@anchor{2a}
@section Memory Management Issues
@@ -29197,7 +22824,7 @@ incorrect uses of access values (including 'dangling references').
@end menu
@node Some Useful Memory Pools,The GNAT Debug Pool Facility,,Memory Management Issues
-@anchor{gnat_ugn/gnat_and_program_execution id66}@anchor{257}@anchor{gnat_ugn/gnat_and_program_execution some-useful-memory-pools}@anchor{258}
+@anchor{gnat_ugn/gnat_and_program_execution id66}@anchor{1cb}@anchor{gnat_ugn/gnat_and_program_execution some-useful-memory-pools}@anchor{1cc}
@subsection Some Useful Memory Pools
@@ -29278,7 +22905,7 @@ for T1'Storage_Size use 10_000;
@end quotation
@node The GNAT Debug Pool Facility,,Some Useful Memory Pools,Memory Management Issues
-@anchor{gnat_ugn/gnat_and_program_execution id67}@anchor{259}@anchor{gnat_ugn/gnat_and_program_execution the-gnat-debug-pool-facility}@anchor{25a}
+@anchor{gnat_ugn/gnat_and_program_execution id67}@anchor{1cd}@anchor{gnat_ugn/gnat_and_program_execution the-gnat-debug-pool-facility}@anchor{1ce}
@subsection The GNAT Debug Pool Facility
@@ -29441,7 +23068,7 @@ Debug Pool info:
@c -- E.g. Ada |nbsp| 95
@node Platform-Specific Information,Example of Binder Output File,GNAT and Program Execution,Top
-@anchor{gnat_ugn/platform_specific_information platform-specific-information}@anchor{f}@anchor{gnat_ugn/platform_specific_information doc}@anchor{25b}@anchor{gnat_ugn/platform_specific_information id1}@anchor{25c}
+@anchor{gnat_ugn/platform_specific_information platform-specific-information}@anchor{d}@anchor{gnat_ugn/platform_specific_information doc}@anchor{1cf}@anchor{gnat_ugn/platform_specific_information id1}@anchor{1d0}
@chapter Platform-Specific Information
@@ -29458,7 +23085,7 @@ topics related to the GNAT implementation on Windows and Mac OS.
@end menu
@node Run-Time Libraries,Specifying a Run-Time Library,,Platform-Specific Information
-@anchor{gnat_ugn/platform_specific_information id2}@anchor{25d}@anchor{gnat_ugn/platform_specific_information run-time-libraries}@anchor{2d}
+@anchor{gnat_ugn/platform_specific_information id2}@anchor{1d1}@anchor{gnat_ugn/platform_specific_information run-time-libraries}@anchor{2b}
@section Run-Time Libraries
@@ -29530,7 +23157,7 @@ information about several specific platforms.
@end menu
@node Summary of Run-Time Configurations,,,Run-Time Libraries
-@anchor{gnat_ugn/platform_specific_information summary-of-run-time-configurations}@anchor{25e}@anchor{gnat_ugn/platform_specific_information id3}@anchor{25f}
+@anchor{gnat_ugn/platform_specific_information summary-of-run-time-configurations}@anchor{1d2}@anchor{gnat_ugn/platform_specific_information id3}@anchor{1d3}
@subsection Summary of Run-Time Configurations
@@ -29781,7 +23408,7 @@ SJLJ
@node Specifying a Run-Time Library,Microsoft Windows Topics,Run-Time Libraries,Platform-Specific Information
-@anchor{gnat_ugn/platform_specific_information specifying-a-run-time-library}@anchor{260}@anchor{gnat_ugn/platform_specific_information id4}@anchor{261}
+@anchor{gnat_ugn/platform_specific_information specifying-a-run-time-library}@anchor{1d4}@anchor{gnat_ugn/platform_specific_information id4}@anchor{1d5}
@section Specifying a Run-Time Library
@@ -29828,6 +23455,27 @@ For example on x86-linux:
-- +--- adalib
@end example
+
+@example
+ $(target-dir)
+ __/ / \ \___
+ _______/ / \ \_________________
+ / / \ \
+ / / \ \
+ADAINCLUDE ADALIB rts-native rts-sjlj
+ : : / \ / \
+ : : / \ / \
+ : : / \ / \
+ : : / \ / \
+ +-------------> adainclude adalib adainclude adalib
+ : ^
+ : :
+ +---------------------+
+
+ Run-Time Library Directory Structure
+ (Upper-case names and dotted/dashed arrows represent soft links)
+@end example
+
If the @emph{rts-sjlj} library is to be selected on a permanent basis,
these soft links can be modified with the following commands:
@@ -29849,7 +23497,7 @@ Alternatively, you can specify @code{rts-sjlj/adainclude} in the file
Selecting another run-time library temporarily can be
achieved by using the @emph{--RTS} switch, e.g., @emph{--RTS=sjlj}
-@anchor{gnat_ugn/platform_specific_information choosing-the-scheduling-policy}@anchor{262}
+@anchor{gnat_ugn/platform_specific_information choosing-the-scheduling-policy}@anchor{1d6}
@geindex SCHED_FIFO scheduling policy
@geindex SCHED_RR scheduling policy
@@ -29865,7 +23513,7 @@ achieved by using the @emph{--RTS} switch, e.g., @emph{--RTS=sjlj}
@end menu
@node Choosing the Scheduling Policy,Solaris-Specific Considerations,,Specifying a Run-Time Library
-@anchor{gnat_ugn/platform_specific_information id5}@anchor{263}
+@anchor{gnat_ugn/platform_specific_information id5}@anchor{1d7}
@subsection Choosing the Scheduling Policy
@@ -29906,7 +23554,7 @@ binder option.
@geindex Solaris Sparc threads libraries
@node Solaris-Specific Considerations,Solaris Threads Issues,Choosing the Scheduling Policy,Specifying a Run-Time Library
-@anchor{gnat_ugn/platform_specific_information id6}@anchor{264}@anchor{gnat_ugn/platform_specific_information solaris-specific-considerations}@anchor{265}
+@anchor{gnat_ugn/platform_specific_information id6}@anchor{1d8}@anchor{gnat_ugn/platform_specific_information solaris-specific-considerations}@anchor{1d9}
@subsection Solaris-Specific Considerations
@@ -29916,7 +23564,7 @@ on Sparc Solaris.
@geindex rts-pthread threads library
@node Solaris Threads Issues,AIX-Specific Considerations,Solaris-Specific Considerations,Specifying a Run-Time Library
-@anchor{gnat_ugn/platform_specific_information id7}@anchor{266}@anchor{gnat_ugn/platform_specific_information solaris-threads-issues}@anchor{267}
+@anchor{gnat_ugn/platform_specific_information id7}@anchor{1da}@anchor{gnat_ugn/platform_specific_information solaris-threads-issues}@anchor{1db}
@subsection Solaris Threads Issues
@@ -30005,7 +23653,7 @@ Run the program on the specified processor.
@end quotation
@node AIX-Specific Considerations,,Solaris Threads Issues,Specifying a Run-Time Library
-@anchor{gnat_ugn/platform_specific_information aix-specific-considerations}@anchor{268}@anchor{gnat_ugn/platform_specific_information id8}@anchor{269}
+@anchor{gnat_ugn/platform_specific_information aix-specific-considerations}@anchor{1dc}@anchor{gnat_ugn/platform_specific_information id8}@anchor{1dd}
@subsection AIX-Specific Considerations
@@ -30032,7 +23680,7 @@ this call.
@geindex Windows 98
@node Microsoft Windows Topics,Mac OS Topics,Specifying a Run-Time Library,Platform-Specific Information
-@anchor{gnat_ugn/platform_specific_information microsoft-windows-topics}@anchor{2e}@anchor{gnat_ugn/platform_specific_information id9}@anchor{26a}
+@anchor{gnat_ugn/platform_specific_information microsoft-windows-topics}@anchor{2c}@anchor{gnat_ugn/platform_specific_information id9}@anchor{1de}
@section Microsoft Windows Topics
@@ -30048,13 +23696,14 @@ platforms.
* Using a network installation of GNAT::
* CONSOLE and WINDOWS subsystems::
* Temporary Files::
+* Disabling Command Line Argument Expansion::
* Mixed-Language Programming on Windows::
* Windows Specific Add-Ons::
@end menu
@node Using GNAT on Windows,Using a network installation of GNAT,,Microsoft Windows Topics
-@anchor{gnat_ugn/platform_specific_information using-gnat-on-windows}@anchor{26b}@anchor{gnat_ugn/platform_specific_information id10}@anchor{26c}
+@anchor{gnat_ugn/platform_specific_information using-gnat-on-windows}@anchor{1df}@anchor{gnat_ugn/platform_specific_information id10}@anchor{1e0}
@subsection Using GNAT on Windows
@@ -30131,7 +23780,7 @@ uninstall or integrate different GNAT products.
@end itemize
@node Using a network installation of GNAT,CONSOLE and WINDOWS subsystems,Using GNAT on Windows,Microsoft Windows Topics
-@anchor{gnat_ugn/platform_specific_information id11}@anchor{26d}@anchor{gnat_ugn/platform_specific_information using-a-network-installation-of-gnat}@anchor{26e}
+@anchor{gnat_ugn/platform_specific_information id11}@anchor{1e1}@anchor{gnat_ugn/platform_specific_information using-a-network-installation-of-gnat}@anchor{1e2}
@subsection Using a network installation of GNAT
@@ -30158,7 +23807,7 @@ transfer of large amounts of data across the network and will likely cause
serious performance penalty.
@node CONSOLE and WINDOWS subsystems,Temporary Files,Using a network installation of GNAT,Microsoft Windows Topics
-@anchor{gnat_ugn/platform_specific_information id12}@anchor{26f}@anchor{gnat_ugn/platform_specific_information console-and-windows-subsystems}@anchor{270}
+@anchor{gnat_ugn/platform_specific_information id12}@anchor{1e3}@anchor{gnat_ugn/platform_specific_information console-and-windows-subsystems}@anchor{1e4}
@subsection CONSOLE and WINDOWS subsystems
@@ -30182,8 +23831,8 @@ $ gnatmake winprog -largs -mwindows
@end example
@end quotation
-@node Temporary Files,Mixed-Language Programming on Windows,CONSOLE and WINDOWS subsystems,Microsoft Windows Topics
-@anchor{gnat_ugn/platform_specific_information id13}@anchor{271}@anchor{gnat_ugn/platform_specific_information temporary-files}@anchor{272}
+@node Temporary Files,Disabling Command Line Argument Expansion,CONSOLE and WINDOWS subsystems,Microsoft Windows Topics
+@anchor{gnat_ugn/platform_specific_information id13}@anchor{1e5}@anchor{gnat_ugn/platform_specific_information temporary-files}@anchor{1e6}
@subsection Temporary Files
@@ -30221,8 +23870,79 @@ file will be created. This is particularly useful in networked
environments where you may not have write access to some
directories.
-@node Mixed-Language Programming on Windows,Windows Specific Add-Ons,Temporary Files,Microsoft Windows Topics
-@anchor{gnat_ugn/platform_specific_information mixed-language-programming-on-windows}@anchor{273}@anchor{gnat_ugn/platform_specific_information id14}@anchor{274}
+@node Disabling Command Line Argument Expansion,Mixed-Language Programming on Windows,Temporary Files,Microsoft Windows Topics
+@anchor{gnat_ugn/platform_specific_information disabling-command-line-argument-expansion}@anchor{1e7}
+@subsection Disabling Command Line Argument Expansion
+
+
+@geindex Command Line Argument Expansion
+
+By default, an executable compiled for the @strong{Windows} platform will do
+the following postprocessing on the arguments passed on the command
+line:
+
+
+@itemize *
+
+@item
+If the argument contains the characters @code{*} and/or @code{?}, then
+file expansion will be attempted. For example, if the current directory
+contains @code{a.txt} and @code{b.txt}, then when calling:
+
+@example
+$ my_ada_program *.txt
+@end example
+
+The following arguments will effectively be passed to the main program
+(for example when using @code{Ada.Command_Line.Argument}):
+
+@example
+Ada.Command_Line.Argument (1) -> "a.txt"
+Ada.Command_Line.Argument (2) -> "b.txt"
+@end example
+
+@item
+Filename expansion can be disabled for a given argument by using single
+quotes. Thus, calling:
+
+@example
+$ my_ada_program '*.txt'
+@end example
+
+will result in:
+
+@example
+Ada.Command_Line.Argument (1) -> "*.txt"
+@end example
+@end itemize
+
+Note that if the program is launched from a shell such as @strong{Cygwin} @strong{Bash}
+then quote removal might be performed by the shell.
+
+In some contexts it might be useful to disable this feature (for example if
+the program performs its own argument expansion). In order to do this, a C
+symbol needs to be defined and set to @code{0}. You can do this by
+adding the following code fragment in one of your @strong{Ada} units:
+
+@example
+Do_Argv_Expansion : Integer := 0;
+pragma Export (C, Do_Argv_Expansion, "__gnat_do_argv_expansion");
+@end example
+
+The results of previous examples will be respectively:
+
+@example
+Ada.Command_Line.Argument (1) -> "*.txt"
+@end example
+
+and:
+
+@example
+Ada.Command_Line.Argument (1) -> "'*.txt'"
+@end example
+
+@node Mixed-Language Programming on Windows,Windows Specific Add-Ons,Disabling Command Line Argument Expansion,Microsoft Windows Topics
+@anchor{gnat_ugn/platform_specific_information mixed-language-programming-on-windows}@anchor{1e8}@anchor{gnat_ugn/platform_specific_information id14}@anchor{1e9}
@subsection Mixed-Language Programming on Windows
@@ -30244,17 +23964,17 @@ to use the Microsoft tools for your C++ code, you have two choices:
Encapsulate your C++ code in a DLL to be linked with your Ada
application. In this case, use the Microsoft or whatever environment to
build the DLL and use GNAT to build your executable
-(@ref{275,,Using DLLs with GNAT}).
+(@ref{1ea,,Using DLLs with GNAT}).
@item
Or you can encapsulate your Ada code in a DLL to be linked with the
other part of your application. In this case, use GNAT to build the DLL
-(@ref{276,,Building DLLs with GNAT Project files}) and use the Microsoft
+(@ref{1eb,,Building DLLs with GNAT Project files}) and use the Microsoft
or whatever environment to build your executable.
@end itemize
In addition to the description about C main in
-@ref{46,,Mixed Language Programming} section, if the C main uses a
+@ref{44,,Mixed Language Programming} section, if the C main uses a
stand-alone library it is required on x86-windows to
setup the SEH context. For this the C main must looks like this:
@@ -30306,7 +24026,7 @@ native SEH support is used.
@end menu
@node Windows Calling Conventions,Introduction to Dynamic Link Libraries DLLs,,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information windows-calling-conventions}@anchor{277}@anchor{gnat_ugn/platform_specific_information id15}@anchor{278}
+@anchor{gnat_ugn/platform_specific_information windows-calling-conventions}@anchor{1ec}@anchor{gnat_ugn/platform_specific_information id15}@anchor{1ed}
@subsubsection Windows Calling Conventions
@@ -30351,7 +24071,7 @@ are available for Windows:
@end menu
@node C Calling Convention,Stdcall Calling Convention,,Windows Calling Conventions
-@anchor{gnat_ugn/platform_specific_information c-calling-convention}@anchor{279}@anchor{gnat_ugn/platform_specific_information id16}@anchor{27a}
+@anchor{gnat_ugn/platform_specific_information c-calling-convention}@anchor{1ee}@anchor{gnat_ugn/platform_specific_information id16}@anchor{1ef}
@subsubsection @cite{C} Calling Convention
@@ -30393,10 +24113,10 @@ is missing, as in the above example, this parameter is set to be the
When importing a variable defined in C, you should always use the @cite{C}
calling convention unless the object containing the variable is part of a
DLL (in which case you should use the @cite{Stdcall} calling
-convention, @ref{27b,,Stdcall Calling Convention}).
+convention, @ref{1f0,,Stdcall Calling Convention}).
@node Stdcall Calling Convention,Win32 Calling Convention,C Calling Convention,Windows Calling Conventions
-@anchor{gnat_ugn/platform_specific_information stdcall-calling-convention}@anchor{27b}@anchor{gnat_ugn/platform_specific_information id17}@anchor{27c}
+@anchor{gnat_ugn/platform_specific_information stdcall-calling-convention}@anchor{1f0}@anchor{gnat_ugn/platform_specific_information id17}@anchor{1f1}
@subsubsection @cite{Stdcall} Calling Convention
@@ -30493,7 +24213,7 @@ Note that to ease building cross-platform bindings this convention
will be handled as a @cite{C} calling convention on non-Windows platforms.
@node Win32 Calling Convention,DLL Calling Convention,Stdcall Calling Convention,Windows Calling Conventions
-@anchor{gnat_ugn/platform_specific_information id18}@anchor{27d}@anchor{gnat_ugn/platform_specific_information win32-calling-convention}@anchor{27e}
+@anchor{gnat_ugn/platform_specific_information id18}@anchor{1f2}@anchor{gnat_ugn/platform_specific_information win32-calling-convention}@anchor{1f3}
@subsubsection @cite{Win32} Calling Convention
@@ -30501,7 +24221,7 @@ This convention, which is GNAT-specific is fully equivalent to the
@cite{Stdcall} calling convention described above.
@node DLL Calling Convention,,Win32 Calling Convention,Windows Calling Conventions
-@anchor{gnat_ugn/platform_specific_information id19}@anchor{27f}@anchor{gnat_ugn/platform_specific_information dll-calling-convention}@anchor{280}
+@anchor{gnat_ugn/platform_specific_information id19}@anchor{1f4}@anchor{gnat_ugn/platform_specific_information dll-calling-convention}@anchor{1f5}
@subsubsection @cite{DLL} Calling Convention
@@ -30509,7 +24229,7 @@ This convention, which is GNAT-specific is fully equivalent to the
@cite{Stdcall} calling convention described above.
@node Introduction to Dynamic Link Libraries DLLs,Using DLLs with GNAT,Windows Calling Conventions,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information id20}@anchor{281}@anchor{gnat_ugn/platform_specific_information introduction-to-dynamic-link-libraries-dlls}@anchor{282}
+@anchor{gnat_ugn/platform_specific_information id20}@anchor{1f6}@anchor{gnat_ugn/platform_specific_information introduction-to-dynamic-link-libraries-dlls}@anchor{1f7}
@subsubsection Introduction to Dynamic Link Libraries (DLLs)
@@ -30593,10 +24313,10 @@ As a side note, an interesting difference between Microsoft DLLs and
Unix shared libraries, is the fact that on most Unix systems all public
routines are exported by default in a Unix shared library, while under
Windows it is possible (but not required) to list exported routines in
-a definition file (see @ref{283,,The Definition File}).
+a definition file (see @ref{1f8,,The Definition File}).
@node Using DLLs with GNAT,Building DLLs with GNAT Project files,Introduction to Dynamic Link Libraries DLLs,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information id21}@anchor{284}@anchor{gnat_ugn/platform_specific_information using-dlls-with-gnat}@anchor{275}
+@anchor{gnat_ugn/platform_specific_information id21}@anchor{1f9}@anchor{gnat_ugn/platform_specific_information using-dlls-with-gnat}@anchor{1ea}
@subsubsection Using DLLs with GNAT
@@ -30687,7 +24407,7 @@ example a fictitious DLL called @code{API.dll}.
@end menu
@node Creating an Ada Spec for the DLL Services,Creating an Import Library,,Using DLLs with GNAT
-@anchor{gnat_ugn/platform_specific_information creating-an-ada-spec-for-the-dll-services}@anchor{285}@anchor{gnat_ugn/platform_specific_information id22}@anchor{286}
+@anchor{gnat_ugn/platform_specific_information creating-an-ada-spec-for-the-dll-services}@anchor{1fa}@anchor{gnat_ugn/platform_specific_information id22}@anchor{1fb}
@subsubsection Creating an Ada Spec for the DLL Services
@@ -30727,7 +24447,7 @@ end API;
@end quotation
@node Creating an Import Library,,Creating an Ada Spec for the DLL Services,Using DLLs with GNAT
-@anchor{gnat_ugn/platform_specific_information id23}@anchor{287}@anchor{gnat_ugn/platform_specific_information creating-an-import-library}@anchor{288}
+@anchor{gnat_ugn/platform_specific_information id23}@anchor{1fc}@anchor{gnat_ugn/platform_specific_information creating-an-import-library}@anchor{1fd}
@subsubsection Creating an Import Library
@@ -30741,7 +24461,7 @@ as in this case it is possible to link directly against the
DLL. Otherwise read on.
@geindex Definition file
-@anchor{gnat_ugn/platform_specific_information the-definition-file}@anchor{283}
+@anchor{gnat_ugn/platform_specific_information the-definition-file}@anchor{1f8}
@subsubheading The Definition File
@@ -30789,17 +24509,17 @@ EXPORTS
@end table
Note that you must specify the correct suffix (@code{@@@emph{nn}})
-(see @ref{277,,Windows Calling Conventions}) for a Stdcall
+(see @ref{1ec,,Windows Calling Conventions}) for a Stdcall
calling convention function in the exported symbols list.
There can actually be other sections in a definition file, but these
sections are not relevant to the discussion at hand.
-@anchor{gnat_ugn/platform_specific_information create-def-file-automatically}@anchor{289}
+@anchor{gnat_ugn/platform_specific_information create-def-file-automatically}@anchor{1fe}
@subsubheading Creating a Definition File Automatically
You can automatically create the definition file @code{API.def}
-(see @ref{283,,The Definition File}) from a DLL.
+(see @ref{1f8,,The Definition File}) from a DLL.
For that use the @cite{dlltool} program as follows:
@quotation
@@ -30809,7 +24529,7 @@ $ dlltool API.dll -z API.def --export-all-symbols
@end example
Note that if some routines in the DLL have the @cite{Stdcall} convention
-(@ref{277,,Windows Calling Conventions}) with stripped @code{@@@emph{nn}}
+(@ref{1ec,,Windows Calling Conventions}) with stripped @code{@@@emph{nn}}
suffix then you'll have to edit @code{api.def} to add it, and specify
@emph{-k} to @emph{gnatdll} when creating the import library.
@@ -30833,13 +24553,13 @@ tells you what symbol is expected. You just have to go back to the
definition file and add the right suffix.
@end itemize
@end quotation
-@anchor{gnat_ugn/platform_specific_information gnat-style-import-library}@anchor{28a}
+@anchor{gnat_ugn/platform_specific_information gnat-style-import-library}@anchor{1ff}
@subsubheading GNAT-Style Import Library
To create a static import library from @code{API.dll} with the GNAT tools
you should create the .def file, then use @cite{gnatdll} tool
-(see @ref{28b,,Using gnatdll}) as follows:
+(see @ref{200,,Using gnatdll}) as follows:
@quotation
@@ -30855,15 +24575,15 @@ definition file name is @cite{xyz`}.def`, the import library name will
be @cite{lib`@w{`}xyz`}.a`. Note that in the previous example option
@emph{-e} could have been removed because the name of the definition
file (before the '@cite{.def}' suffix) is the same as the name of the
-DLL (@ref{28b,,Using gnatdll} for more information about @cite{gnatdll}).
+DLL (@ref{200,,Using gnatdll} for more information about @cite{gnatdll}).
@end quotation
-@anchor{gnat_ugn/platform_specific_information msvs-style-import-library}@anchor{28c}
+@anchor{gnat_ugn/platform_specific_information msvs-style-import-library}@anchor{201}
@subsubheading Microsoft-Style Import Library
A Microsoft import library is needed only if you plan to make an
Ada DLL available to applications developed with Microsoft
-tools (@ref{273,,Mixed-Language Programming on Windows}).
+tools (@ref{1e8,,Mixed-Language Programming on Windows}).
To create a Microsoft-style import library for @code{API.dll} you
should create the .def file, then build the actual import library using
@@ -30887,7 +24607,7 @@ See the Microsoft documentation for further details about the usage of
@end quotation
@node Building DLLs with GNAT Project files,Building DLLs with GNAT,Using DLLs with GNAT,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information id24}@anchor{28d}@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnat-project-files}@anchor{276}
+@anchor{gnat_ugn/platform_specific_information id24}@anchor{202}@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnat-project-files}@anchor{1eb}
@subsubsection Building DLLs with GNAT Project files
@@ -30895,14 +24615,15 @@ See the Microsoft documentation for further details about the usage of
@geindex building
There is nothing specific to Windows in the build process.
-@ref{8a,,Library Projects}.
+See the @emph{Library Projects} section in the @emph{GNAT Project Manager}
+chapter of the @emph{GPRbuild User's Guide}.
Due to a system limitation, it is not possible under Windows to create threads
when inside the @cite{DllMain} routine which is used for auto-initialization
of shared libraries, so it is not possible to have library level tasks in SALs.
@node Building DLLs with GNAT,Building DLLs with gnatdll,Building DLLs with GNAT Project files,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnat}@anchor{28e}@anchor{gnat_ugn/platform_specific_information id25}@anchor{28f}
+@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnat}@anchor{203}@anchor{gnat_ugn/platform_specific_information id25}@anchor{204}
@subsubsection Building DLLs with GNAT
@@ -30933,7 +24654,7 @@ $ gcc -shared -shared-libgcc -o api.dll obj1.o obj2.o ...
It is important to note that in this case all symbols found in the
object files are automatically exported. It is possible to restrict
the set of symbols to export by passing to @emph{gcc} a definition
-file (see @ref{283,,The Definition File}).
+file (see @ref{1f8,,The Definition File}).
For example:
@example
@@ -30971,7 +24692,7 @@ $ gnatmake main -Iapilib -bargs -shared -largs -Lapilib -lAPI
@end quotation
@node Building DLLs with gnatdll,Ada DLLs and Finalization,Building DLLs with GNAT,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnatdll}@anchor{290}@anchor{gnat_ugn/platform_specific_information id26}@anchor{291}
+@anchor{gnat_ugn/platform_specific_information building-dlls-with-gnatdll}@anchor{205}@anchor{gnat_ugn/platform_specific_information id26}@anchor{206}
@subsubsection Building DLLs with gnatdll
@@ -30979,8 +24700,8 @@ $ gnatmake main -Iapilib -bargs -shared -largs -Lapilib -lAPI
@geindex building
Note that it is preferred to use GNAT Project files
-(@ref{276,,Building DLLs with GNAT Project files}) or the built-in GNAT
-DLL support (@ref{28e,,Building DLLs with GNAT}) or to build DLLs.
+(@ref{1eb,,Building DLLs with GNAT Project files}) or the built-in GNAT
+DLL support (@ref{203,,Building DLLs with GNAT}) or to build DLLs.
This section explains how to build DLLs containing Ada code using
@cite{gnatdll}. These DLLs will be referred to as Ada DLLs in the
@@ -30996,20 +24717,20 @@ non-Ada applications are as follows:
You need to mark each Ada @emph{entity} exported by the DLL with a @cite{C} or
@cite{Stdcall} calling convention to avoid any Ada name mangling for the
entities exported by the DLL
-(see @ref{292,,Exporting Ada Entities}). You can
+(see @ref{207,,Exporting Ada Entities}). You can
skip this step if you plan to use the Ada DLL only from Ada applications.
@item
Your Ada code must export an initialization routine which calls the routine
@cite{adainit} generated by @emph{gnatbind} to perform the elaboration of
-the Ada code in the DLL (@ref{293,,Ada DLLs and Elaboration}). The initialization
+the Ada code in the DLL (@ref{208,,Ada DLLs and Elaboration}). The initialization
routine exported by the Ada DLL must be invoked by the clients of the DLL
to initialize the DLL.
@item
When useful, the DLL should also export a finalization routine which calls
routine @cite{adafinal} generated by @emph{gnatbind} to perform the
-finalization of the Ada code in the DLL (@ref{294,,Ada DLLs and Finalization}).
+finalization of the Ada code in the DLL (@ref{209,,Ada DLLs and Finalization}).
The finalization routine exported by the Ada DLL must be invoked by the
clients of the DLL when the DLL services are no further needed.
@@ -31019,18 +24740,19 @@ of the programming languages to which you plan to make the DLL available.
@item
You must provide a definition file listing the exported entities
-(@ref{283,,The Definition File}).
+(@ref{1f8,,The Definition File}).
@item
Finally you must use @cite{gnatdll} to produce the DLL and the import
-library (@ref{28b,,Using gnatdll}).
+library (@ref{200,,Using gnatdll}).
@end itemize
Note that a relocatable DLL stripped using the @cite{strip}
binutils tool will not be relocatable anymore. To build a DLL without
debug information pass @cite{-largs -s} to @cite{gnatdll}. This
restriction does not apply to a DLL built using a Library Project.
-See @ref{8a,,Library Projects}.
+See the @emph{Library Projects} section in the @emph{GNAT Project Manager}
+chapter of the @emph{GPRbuild User's Guide}.
@c Limitations_When_Using_Ada_DLLs_from Ada:
@@ -31042,7 +24764,7 @@ See @ref{8a,,Library Projects}.
@end menu
@node Limitations When Using Ada DLLs from Ada,Exporting Ada Entities,,Building DLLs with gnatdll
-@anchor{gnat_ugn/platform_specific_information limitations-when-using-ada-dlls-from-ada}@anchor{295}
+@anchor{gnat_ugn/platform_specific_information limitations-when-using-ada-dlls-from-ada}@anchor{20a}
@subsubsection Limitations When Using Ada DLLs from Ada
@@ -31063,7 +24785,7 @@ It is completely safe to exchange plain elementary, array or record types,
Windows object handles, etc.
@node Exporting Ada Entities,Ada DLLs and Elaboration,Limitations When Using Ada DLLs from Ada,Building DLLs with gnatdll
-@anchor{gnat_ugn/platform_specific_information exporting-ada-entities}@anchor{292}@anchor{gnat_ugn/platform_specific_information id27}@anchor{296}
+@anchor{gnat_ugn/platform_specific_information exporting-ada-entities}@anchor{207}@anchor{gnat_ugn/platform_specific_information id27}@anchor{20b}
@subsubsection Exporting Ada Entities
@@ -31163,10 +24885,10 @@ end API;
Note that if you do not export the Ada entities with a @cite{C} or
@cite{Stdcall} convention you will have to provide the mangled Ada names
in the definition file of the Ada DLL
-(@ref{297,,Creating the Definition File}).
+(@ref{20c,,Creating the Definition File}).
@node Ada DLLs and Elaboration,,Exporting Ada Entities,Building DLLs with gnatdll
-@anchor{gnat_ugn/platform_specific_information ada-dlls-and-elaboration}@anchor{293}@anchor{gnat_ugn/platform_specific_information id28}@anchor{298}
+@anchor{gnat_ugn/platform_specific_information ada-dlls-and-elaboration}@anchor{208}@anchor{gnat_ugn/platform_specific_information id28}@anchor{20d}
@subsubsection Ada DLLs and Elaboration
@@ -31175,16 +24897,16 @@ in the definition file of the Ada DLL
The DLL that you are building contains your Ada code as well as all the
routines in the Ada library that are needed by it. The first thing a
user of your DLL must do is elaborate the Ada code
-(@ref{11,,Elaboration Order Handling in GNAT}).
+(@ref{f,,Elaboration Order Handling in GNAT}).
To achieve this you must export an initialization routine
(@cite{Initialize_API} in the previous example), which must be invoked
before using any of the DLL services. This elaboration routine must call
the Ada elaboration routine @cite{adainit} generated by the GNAT binder
-(@ref{ba,,Binding with Non-Ada Main Programs}). See the body of
+(@ref{b4,,Binding with Non-Ada Main Programs}). See the body of
@cite{Initialize_Api} for an example. Note that the GNAT binder is
automatically invoked during the DLL build process by the @cite{gnatdll}
-tool (@ref{28b,,Using gnatdll}).
+tool (@ref{200,,Using gnatdll}).
When a DLL is loaded, Windows systematically invokes a routine called
@cite{DllMain}. It would therefore be possible to call @cite{adainit}
@@ -31197,7 +24919,7 @@ time), which means that the GNAT run time will deadlock waiting for the
newly created task to complete its initialization.
@node Ada DLLs and Finalization,Creating a Spec for Ada DLLs,Building DLLs with gnatdll,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information id29}@anchor{299}@anchor{gnat_ugn/platform_specific_information ada-dlls-and-finalization}@anchor{294}
+@anchor{gnat_ugn/platform_specific_information id29}@anchor{20e}@anchor{gnat_ugn/platform_specific_information ada-dlls-and-finalization}@anchor{209}
@subsubsection Ada DLLs and Finalization
@@ -31208,14 +24930,14 @@ invoke the DLL finalization routine, if available. The DLL finalization
routine is in charge of releasing all resources acquired by the DLL. In the
case of the Ada code contained in the DLL, this is achieved by calling
routine @cite{adafinal} generated by the GNAT binder
-(@ref{ba,,Binding with Non-Ada Main Programs}).
+(@ref{b4,,Binding with Non-Ada Main Programs}).
See the body of @cite{Finalize_Api} for an
example. As already pointed out the GNAT binder is automatically invoked
during the DLL build process by the @cite{gnatdll} tool
-(@ref{28b,,Using gnatdll}).
+(@ref{200,,Using gnatdll}).
@node Creating a Spec for Ada DLLs,GNAT and Windows Resources,Ada DLLs and Finalization,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information id30}@anchor{29a}@anchor{gnat_ugn/platform_specific_information creating-a-spec-for-ada-dlls}@anchor{29b}
+@anchor{gnat_ugn/platform_specific_information id30}@anchor{20f}@anchor{gnat_ugn/platform_specific_information creating-a-spec-for-ada-dlls}@anchor{210}
@subsubsection Creating a Spec for Ada DLLs
@@ -31273,7 +24995,7 @@ end API;
@end menu
@node Creating the Definition File,Using gnatdll,,Creating a Spec for Ada DLLs
-@anchor{gnat_ugn/platform_specific_information creating-the-definition-file}@anchor{297}@anchor{gnat_ugn/platform_specific_information id31}@anchor{29c}
+@anchor{gnat_ugn/platform_specific_information creating-the-definition-file}@anchor{20c}@anchor{gnat_ugn/platform_specific_information id31}@anchor{211}
@subsubsection Creating the Definition File
@@ -31309,7 +25031,7 @@ EXPORTS
@end quotation
@node Using gnatdll,,Creating the Definition File,Creating a Spec for Ada DLLs
-@anchor{gnat_ugn/platform_specific_information using-gnatdll}@anchor{28b}@anchor{gnat_ugn/platform_specific_information id32}@anchor{29d}
+@anchor{gnat_ugn/platform_specific_information using-gnatdll}@anchor{200}@anchor{gnat_ugn/platform_specific_information id32}@anchor{212}
@subsubsection Using @cite{gnatdll}
@@ -31407,7 +25129,7 @@ Help mode. Displays @cite{gnatdll} switch usage information.
Direct @cite{gnatdll} to search the @cite{dir} directory for source and
object files needed to build the DLL.
-(@ref{8e,,Search Paths and the Run-Time Library (RTL)}).
+(@ref{89,,Search Paths and the Run-Time Library (RTL)}).
@geindex -k (gnatdll)
@@ -31520,7 +25242,7 @@ asks @emph{gnatlink} to generate the routines @cite{DllMain} and
is loaded into memory.
@item
-@cite{gnatdll} uses @cite{dlltool} (see @ref{29e,,Using dlltool}) to build the
+@cite{gnatdll} uses @cite{dlltool} (see @ref{213,,Using dlltool}) to build the
export table (@code{api.exp}). The export table contains the relocation
information in a form which can be used during the final link to ensure
that the Windows loader is able to place the DLL anywhere in memory.
@@ -31559,7 +25281,7 @@ $ gnatbind -n api
$ gnatlink api api.exp -o api.dll -mdll
@end example
@end itemize
-@anchor{gnat_ugn/platform_specific_information using-dlltool}@anchor{29e}
+@anchor{gnat_ugn/platform_specific_information using-dlltool}@anchor{213}
@subsubheading Using @cite{dlltool}
@@ -31618,7 +25340,7 @@ DLL in the static import library generated by @cite{dlltool} with switch
@item @code{-k}
Kill @code{@@@emph{nn}} from exported names
-(@ref{277,,Windows Calling Conventions}
+(@ref{1ec,,Windows Calling Conventions}
for a discussion about @cite{Stdcall}-style symbols.
@end table
@@ -31674,7 +25396,7 @@ Use @cite{assembler-name} as the assembler. The default is @cite{as}.
@end table
@node GNAT and Windows Resources,Using GNAT DLLs from Microsoft Visual Studio Applications,Creating a Spec for Ada DLLs,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information gnat-and-windows-resources}@anchor{29f}@anchor{gnat_ugn/platform_specific_information id33}@anchor{2a0}
+@anchor{gnat_ugn/platform_specific_information gnat-and-windows-resources}@anchor{214}@anchor{gnat_ugn/platform_specific_information id33}@anchor{215}
@subsubsection GNAT and Windows Resources
@@ -31769,7 +25491,7 @@ the corresponding Microsoft documentation.
@end menu
@node Building Resources,Compiling Resources,,GNAT and Windows Resources
-@anchor{gnat_ugn/platform_specific_information building-resources}@anchor{2a1}@anchor{gnat_ugn/platform_specific_information id34}@anchor{2a2}
+@anchor{gnat_ugn/platform_specific_information building-resources}@anchor{216}@anchor{gnat_ugn/platform_specific_information id34}@anchor{217}
@subsubsection Building Resources
@@ -31789,7 +25511,7 @@ complete description of the resource script language can be found in the
Microsoft documentation.
@node Compiling Resources,Using Resources,Building Resources,GNAT and Windows Resources
-@anchor{gnat_ugn/platform_specific_information compiling-resources}@anchor{2a3}@anchor{gnat_ugn/platform_specific_information id35}@anchor{2a4}
+@anchor{gnat_ugn/platform_specific_information compiling-resources}@anchor{218}@anchor{gnat_ugn/platform_specific_information id35}@anchor{219}
@subsubsection Compiling Resources
@@ -31831,7 +25553,7 @@ $ windres -i myres.res -o myres.o
@end quotation
@node Using Resources,,Compiling Resources,GNAT and Windows Resources
-@anchor{gnat_ugn/platform_specific_information id36}@anchor{2a5}@anchor{gnat_ugn/platform_specific_information using-resources}@anchor{2a6}
+@anchor{gnat_ugn/platform_specific_information id36}@anchor{21a}@anchor{gnat_ugn/platform_specific_information using-resources}@anchor{21b}
@subsubsection Using Resources
@@ -31851,7 +25573,7 @@ $ gnatmake myprog -largs myres.o
@end quotation
@node Using GNAT DLLs from Microsoft Visual Studio Applications,Debugging a DLL,GNAT and Windows Resources,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information using-gnat-dll-from-msvs}@anchor{2a7}@anchor{gnat_ugn/platform_specific_information using-gnat-dlls-from-microsoft-visual-studio-applications}@anchor{2a8}
+@anchor{gnat_ugn/platform_specific_information using-gnat-dll-from-msvs}@anchor{21c}@anchor{gnat_ugn/platform_specific_information using-gnat-dlls-from-microsoft-visual-studio-applications}@anchor{21d}
@subsubsection Using GNAT DLLs from Microsoft Visual Studio Applications
@@ -31885,7 +25607,7 @@ $ gprbuild -p mylib.gpr
@item
Produce a .def file for the symbols you need to interface with, either by
hand or automatically with possibly some manual adjustments
-(see @ref{289,,Creating Definition File Automatically}):
+(see @ref{1fe,,Creating Definition File Automatically}):
@end enumerate
@quotation
@@ -31902,7 +25624,7 @@ $ dlltool libmylib.dll -z libmylib.def --export-all-symbols
Make sure that MSVS command-line tools are accessible on the path.
@item
-Create the Microsoft-style import library (see @ref{28c,,MSVS-Style Import Library}):
+Create the Microsoft-style import library (see @ref{201,,MSVS-Style Import Library}):
@end enumerate
@quotation
@@ -31944,7 +25666,7 @@ or copy the DLL into into the directory containing the .exe.
@end enumerate
@node Debugging a DLL,Setting Stack Size from gnatlink,Using GNAT DLLs from Microsoft Visual Studio Applications,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information id37}@anchor{2a9}@anchor{gnat_ugn/platform_specific_information debugging-a-dll}@anchor{2aa}
+@anchor{gnat_ugn/platform_specific_information id37}@anchor{21e}@anchor{gnat_ugn/platform_specific_information debugging-a-dll}@anchor{21f}
@subsubsection Debugging a DLL
@@ -31982,7 +25704,7 @@ tools suite used to build the DLL.
@end menu
@node Program and DLL Both Built with GCC/GNAT,Program Built with Foreign Tools and DLL Built with GCC/GNAT,,Debugging a DLL
-@anchor{gnat_ugn/platform_specific_information program-and-dll-both-built-with-gcc-gnat}@anchor{2ab}@anchor{gnat_ugn/platform_specific_information id38}@anchor{2ac}
+@anchor{gnat_ugn/platform_specific_information program-and-dll-both-built-with-gcc-gnat}@anchor{220}@anchor{gnat_ugn/platform_specific_information id38}@anchor{221}
@subsubsection Program and DLL Both Built with GCC/GNAT
@@ -31992,7 +25714,7 @@ the process. Let's suppose here that the main procedure is named
@cite{ada_main} and that in the DLL there is an entry point named
@cite{ada_dll}.
-The DLL (@ref{282,,Introduction to Dynamic Link Libraries (DLLs)}) and
+The DLL (@ref{1f7,,Introduction to Dynamic Link Libraries (DLLs)}) and
program must have been built with the debugging information (see GNAT -g
switch). Here are the step-by-step instructions for debugging it:
@@ -32029,10 +25751,10 @@ Set a breakpoint inside the DLL
At this stage a breakpoint is set inside the DLL. From there on
you can use the standard approach to debug the whole program
-(@ref{26,,Running and Debugging Ada Programs}).
+(@ref{24,,Running and Debugging Ada Programs}).
@node Program Built with Foreign Tools and DLL Built with GCC/GNAT,,Program and DLL Both Built with GCC/GNAT,Debugging a DLL
-@anchor{gnat_ugn/platform_specific_information program-built-with-foreign-tools-and-dll-built-with-gcc-gnat}@anchor{2ad}@anchor{gnat_ugn/platform_specific_information id39}@anchor{2ae}
+@anchor{gnat_ugn/platform_specific_information program-built-with-foreign-tools-and-dll-built-with-gcc-gnat}@anchor{222}@anchor{gnat_ugn/platform_specific_information id39}@anchor{223}
@subsubsection Program Built with Foreign Tools and DLL Built with GCC/GNAT
@@ -32049,7 +25771,7 @@ example some C code built with Microsoft Visual C) and that there is a
DLL named @cite{test.dll} containing an Ada entry point named
@cite{ada_dll}.
-The DLL (see @ref{282,,Introduction to Dynamic Link Libraries (DLLs)}) must have
+The DLL (see @ref{1f7,,Introduction to Dynamic Link Libraries (DLLs)}) must have
been built with debugging information (see GNAT @cite{-g} option).
@subsubheading Debugging the DLL Directly
@@ -32115,7 +25837,7 @@ Continue the program.
This will run the program until it reaches the breakpoint that has been
set. From that point you can use the standard way to debug a program
-as described in (@ref{26,,Running and Debugging Ada Programs}).
+as described in (@ref{24,,Running and Debugging Ada Programs}).
@end itemize
It is also possible to debug the DLL by attaching to a running process.
@@ -32185,10 +25907,10 @@ Continue process execution.
This last step will resume the process execution, and stop at
the breakpoint we have set. From there you can use the standard
approach to debug a program as described in
-@ref{26,,Running and Debugging Ada Programs}.
+@ref{24,,Running and Debugging Ada Programs}.
@node Setting Stack Size from gnatlink,Setting Heap Size from gnatlink,Debugging a DLL,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information setting-stack-size-from-gnatlink}@anchor{13d}@anchor{gnat_ugn/platform_specific_information id40}@anchor{2af}
+@anchor{gnat_ugn/platform_specific_information setting-stack-size-from-gnatlink}@anchor{136}@anchor{gnat_ugn/platform_specific_information id40}@anchor{224}
@subsubsection Setting Stack Size from @emph{gnatlink}
@@ -32231,7 +25953,7 @@ because the coma is a separator for this option.
@end itemize
@node Setting Heap Size from gnatlink,,Setting Stack Size from gnatlink,Mixed-Language Programming on Windows
-@anchor{gnat_ugn/platform_specific_information setting-heap-size-from-gnatlink}@anchor{13e}@anchor{gnat_ugn/platform_specific_information id41}@anchor{2b0}
+@anchor{gnat_ugn/platform_specific_information setting-heap-size-from-gnatlink}@anchor{137}@anchor{gnat_ugn/platform_specific_information id41}@anchor{225}
@subsubsection Setting Heap Size from @emph{gnatlink}
@@ -32264,7 +25986,7 @@ because the coma is a separator for this option.
@end itemize
@node Windows Specific Add-Ons,,Mixed-Language Programming on Windows,Microsoft Windows Topics
-@anchor{gnat_ugn/platform_specific_information windows-specific-add-ons}@anchor{2b1}@anchor{gnat_ugn/platform_specific_information win32-specific-addons}@anchor{2b2}
+@anchor{gnat_ugn/platform_specific_information windows-specific-add-ons}@anchor{226}@anchor{gnat_ugn/platform_specific_information win32-specific-addons}@anchor{227}
@subsection Windows Specific Add-Ons
@@ -32277,7 +25999,7 @@ This section describes the Windows specific add-ons.
@end menu
@node Win32Ada,wPOSIX,,Windows Specific Add-Ons
-@anchor{gnat_ugn/platform_specific_information win32ada}@anchor{2b3}@anchor{gnat_ugn/platform_specific_information id42}@anchor{2b4}
+@anchor{gnat_ugn/platform_specific_information win32ada}@anchor{228}@anchor{gnat_ugn/platform_specific_information id42}@anchor{229}
@subsubsection Win32Ada
@@ -32308,7 +26030,7 @@ gprbuild p.gpr
@end quotation
@node wPOSIX,,Win32Ada,Windows Specific Add-Ons
-@anchor{gnat_ugn/platform_specific_information id43}@anchor{2b5}@anchor{gnat_ugn/platform_specific_information wposix}@anchor{2b6}
+@anchor{gnat_ugn/platform_specific_information id43}@anchor{22a}@anchor{gnat_ugn/platform_specific_information wposix}@anchor{22b}
@subsubsection wPOSIX
@@ -32341,7 +26063,7 @@ gprbuild p.gpr
@end quotation
@node Mac OS Topics,,Microsoft Windows Topics,Platform-Specific Information
-@anchor{gnat_ugn/platform_specific_information mac-os-topics}@anchor{2f}@anchor{gnat_ugn/platform_specific_information id44}@anchor{2b7}
+@anchor{gnat_ugn/platform_specific_information mac-os-topics}@anchor{2d}@anchor{gnat_ugn/platform_specific_information id44}@anchor{22c}
@section Mac OS Topics
@@ -32356,7 +26078,7 @@ platform.
@end menu
@node Codesigning the Debugger,,,Mac OS Topics
-@anchor{gnat_ugn/platform_specific_information codesigning-the-debugger}@anchor{2b8}
+@anchor{gnat_ugn/platform_specific_information codesigning-the-debugger}@anchor{22d}
@subsection Codesigning the Debugger
@@ -32437,7 +26159,7 @@ the location where you installed GNAT. Also, be sure that users are
in the Unix group @code{_developer}.
@node Example of Binder Output File,Elaboration Order Handling in GNAT,Platform-Specific Information,Top
-@anchor{gnat_ugn/example_of_binder_output example-of-binder-output-file}@anchor{10}@anchor{gnat_ugn/example_of_binder_output doc}@anchor{2b9}@anchor{gnat_ugn/example_of_binder_output id1}@anchor{2ba}
+@anchor{gnat_ugn/example_of_binder_output example-of-binder-output-file}@anchor{e}@anchor{gnat_ugn/example_of_binder_output doc}@anchor{22e}@anchor{gnat_ugn/example_of_binder_output id1}@anchor{22f}
@chapter Example of Binder Output File
@@ -33189,7 +26911,7 @@ elaboration code in your own application).
@c -- Example: A |withing| unit has a |with| clause, it |withs| a |withed| unit
@node Elaboration Order Handling in GNAT,Inline Assembler,Example of Binder Output File,Top
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-order-handling-in-gnat}@anchor{11}@anchor{gnat_ugn/elaboration_order_handling_in_gnat doc}@anchor{2bb}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id1}@anchor{2bc}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-order-handling-in-gnat}@anchor{f}@anchor{gnat_ugn/elaboration_order_handling_in_gnat doc}@anchor{230}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id1}@anchor{231}
@chapter Elaboration Order Handling in GNAT
@@ -33221,7 +26943,7 @@ features.
@end menu
@node Elaboration Code,Checking the Elaboration Order,,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-code}@anchor{2bd}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id2}@anchor{2be}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-code}@anchor{232}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id2}@anchor{233}
@section Elaboration Code
@@ -33371,7 +27093,7 @@ to figure out which of these expressions will be true, and hence it
is impossible to guarantee a safe order of elaboration at run time.
@node Checking the Elaboration Order,Controlling the Elaboration Order,Elaboration Code,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat checking-the-elaboration-order}@anchor{2bf}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id3}@anchor{2c0}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat checking-the-elaboration-order}@anchor{234}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id3}@anchor{235}
@section Checking the Elaboration Order
@@ -33475,7 +27197,7 @@ does such optimizations, but still the easiest conceptual model is to
think of there being one variable per subprogram.
@node Controlling the Elaboration Order,Controlling Elaboration in GNAT - Internal Calls,Checking the Elaboration Order,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat id4}@anchor{2c1}@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order}@anchor{2c2}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat id4}@anchor{236}@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-the-elaboration-order}@anchor{237}
@section Controlling the Elaboration Order
@@ -33734,7 +27456,7 @@ code in the body makes calls to some other unit, so it is still necessary
to use @cite{Elaborate_All} on such units.
@node Controlling Elaboration in GNAT - Internal Calls,Controlling Elaboration in GNAT - External Calls,Controlling the Elaboration Order,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat id5}@anchor{2c3}@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-elaboration-in-gnat-internal-calls}@anchor{2c4}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat id5}@anchor{238}@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-elaboration-in-gnat-internal-calls}@anchor{239}
@section Controlling Elaboration in GNAT - Internal Calls
@@ -33914,7 +27636,7 @@ guaranteed) for a program to be able to call a subprogram whose body
is not yet elaborated, without raising a @cite{Program_Error} exception.
@node Controlling Elaboration in GNAT - External Calls,Default Behavior in GNAT - Ensuring Safety,Controlling Elaboration in GNAT - Internal Calls,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat id6}@anchor{2c5}@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-elaboration-in-gnat-external-calls}@anchor{2c6}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat id6}@anchor{23a}@anchor{gnat_ugn/elaboration_order_handling_in_gnat controlling-elaboration-in-gnat-external-calls}@anchor{23b}
@section Controlling Elaboration in GNAT - External Calls
@@ -34022,7 +27744,7 @@ provides a number of facilities for assisting the programmer in
developing programs that are robust with respect to elaboration order.
@node Default Behavior in GNAT - Ensuring Safety,Treatment of Pragma Elaborate,Controlling Elaboration in GNAT - External Calls,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat id7}@anchor{2c7}@anchor{gnat_ugn/elaboration_order_handling_in_gnat default-behavior-in-gnat-ensuring-safety}@anchor{2c8}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat id7}@anchor{23c}@anchor{gnat_ugn/elaboration_order_handling_in_gnat default-behavior-in-gnat-ensuring-safety}@anchor{23d}
@section Default Behavior in GNAT - Ensuring Safety
@@ -34124,7 +27846,7 @@ is clearly safer to rely on compile and link time checks rather than
run-time checks. However, in the case of legacy code, it may be
difficult to meet the requirements of the static model. This
issue is further discussed in
-@ref{2c9,,What to Do If the Default Elaboration Behavior Fails}.
+@ref{23e,,What to Do If the Default Elaboration Behavior Fails}.
Note that the static model provides a strict subset of the allowed
behavior and programs of the Ada Reference Manual, so if you do
@@ -34134,7 +27856,7 @@ work using the dynamic model, providing that you remove any
pragma Elaborate statements from the source.
@node Treatment of Pragma Elaborate,Elaboration Issues for Library Tasks,Default Behavior in GNAT - Ensuring Safety,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat treatment-of-pragma-elaborate}@anchor{2ca}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id8}@anchor{2cb}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat treatment-of-pragma-elaborate}@anchor{23f}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id8}@anchor{240}
@section Treatment of Pragma Elaborate
@@ -34173,7 +27895,7 @@ When using the static mode with @emph{-gnatwl}, any use of
problems.
@node Elaboration Issues for Library Tasks,Mixing Elaboration Models,Treatment of Pragma Elaborate,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-issues-for-library-tasks}@anchor{2cc}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id9}@anchor{2cd}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-issues-for-library-tasks}@anchor{241}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id9}@anchor{242}
@section Elaboration Issues for Library Tasks
@@ -34536,7 +28258,7 @@ no task receives an entry call before elaboration of all units is completed.
@end itemize
@node Mixing Elaboration Models,What to Do If the Default Elaboration Behavior Fails,Elaboration Issues for Library Tasks,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat id10}@anchor{2ce}@anchor{gnat_ugn/elaboration_order_handling_in_gnat mixing-elaboration-models}@anchor{2cf}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat id10}@anchor{243}@anchor{gnat_ugn/elaboration_order_handling_in_gnat mixing-elaboration-models}@anchor{244}
@section Mixing Elaboration Models
@@ -34601,7 +28323,7 @@ allowing the main application that uses this subsystem to be compiled
using the more reliable default static model.
@node What to Do If the Default Elaboration Behavior Fails,Elaboration for Indirect Calls,Mixing Elaboration Models,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat id11}@anchor{2d0}@anchor{gnat_ugn/elaboration_order_handling_in_gnat what-to-do-if-the-default-elaboration-behavior-fails}@anchor{2c9}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat id11}@anchor{245}@anchor{gnat_ugn/elaboration_order_handling_in_gnat what-to-do-if-the-default-elaboration-behavior-fails}@anchor{23e}
@section What to Do If the Default Elaboration Behavior Fails
@@ -34712,7 +28434,7 @@ all subprograms declared in this spec.
@item
Use Pragma Elaborate.
-As previously described in section @ref{2ca,,Treatment of Pragma Elaborate},
+As previously described in section @ref{23f,,Treatment of Pragma Elaborate},
GNAT in static mode assumes that a @cite{pragma} Elaborate indicates correctly
that no elaboration checks are required on calls to the designated unit.
There may be cases in which the caller knows that no transitive calls
@@ -34845,7 +28567,7 @@ C-tests are indeed correct (it is less efficient, but efficiency is
not a factor in running the ACATS tests.)
@node Elaboration for Indirect Calls,Summary of Procedures for Elaboration Control,What to Do If the Default Elaboration Behavior Fails,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat id12}@anchor{2d1}@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-for-indirect-calls}@anchor{2d2}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat id12}@anchor{246}@anchor{gnat_ugn/elaboration_order_handling_in_gnat elaboration-for-indirect-calls}@anchor{247}
@section Elaboration for Indirect Calls
@@ -34859,29 +28581,34 @@ fall back to run-time checks; premature calls to any primitive
operation of a tagged type before the body of the operation has been
elaborated will raise @cite{Program_Error}.
-Access-to-subprogram types, however, are handled conservatively, and
-do not require run-time checks. This was not true in earlier versions
-of the compiler; you can use the @emph{-gnatd.U} debug switch to
-revert to the old behavior if the new conservative behavior causes
-elaboration cycles. Here, 'conservative' means that if you do
-@cite{P'Access} during elaboration, the compiler will assume that you
-might call @cite{P} indirectly during elaboration, so it adds an
-implicit @cite{pragma Elaborate_All} on the library unit containing
-@cite{P}. The @emph{-gnatd.U} switch is safe if you know there are
-no such calls. If the program worked before, it will continue to work
-with @emph{-gnatd.U}. But beware that code modifications such as
-adding an indirect call can cause erroneous behavior in the presence
-of @emph{-gnatd.U}.
+Access-to-subprogram types, however, are handled conservatively in many
+cases. This was not true in earlier versions of the compiler; you can use
+the @emph{-gnatd.U} debug switch to revert to the old behavior if the new
+conservative behavior causes elaboration cycles. Here, 'conservative' means
+that if you do @cite{P'Access} during elaboration, the compiler will normally
+assume that you might call @cite{P} indirectly during elaboration, so it adds an
+implicit @cite{pragma Elaborate_All} on the library unit containing @cite{P}. The
+@emph{-gnatd.U} switch is safe if you know there are no such calls. If the
+program worked before, it will continue to work with @emph{-gnatd.U}. But beware
+that code modifications such as adding an indirect call can cause erroneous
+behavior in the presence of @emph{-gnatd.U}.
+
+These implicit Elaborate_All pragmas are not added in all cases, because
+they cause elaboration cycles in certain common code patterns. If you want
+even more conservative handling of P'Access, you can use the @emph{-gnatd.o}
+switch.
+
+See @cite{debug.adb} for documentation on the @emph{-gnatd...} debug switches.
@node Summary of Procedures for Elaboration Control,Other Elaboration Order Considerations,Elaboration for Indirect Calls,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat id13}@anchor{2d3}@anchor{gnat_ugn/elaboration_order_handling_in_gnat summary-of-procedures-for-elaboration-control}@anchor{2d4}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat id13}@anchor{248}@anchor{gnat_ugn/elaboration_order_handling_in_gnat summary-of-procedures-for-elaboration-control}@anchor{249}
@section Summary of Procedures for Elaboration Control
@geindex Elaboration control
First, compile your program with the default options, using none of
-the special elaboration control switches. If the binder successfully
+the special elaboration-control switches. If the binder successfully
binds your program, then you can be confident that, apart from issues
raised by the use of access-to-subprogram types and dynamic dispatching,
the program is free of elaboration errors. If it is important that the
@@ -34898,7 +28625,7 @@ and, if you are sure there really are no elaboration problems,
use a global pragma @cite{Suppress (Elaboration_Check)}.
@node Other Elaboration Order Considerations,Determining the Chosen Elaboration Order,Summary of Procedures for Elaboration Control,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat id14}@anchor{2d5}@anchor{gnat_ugn/elaboration_order_handling_in_gnat other-elaboration-order-considerations}@anchor{2d6}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat id14}@anchor{24a}@anchor{gnat_ugn/elaboration_order_handling_in_gnat other-elaboration-order-considerations}@anchor{24b}
@section Other Elaboration Order Considerations
@@ -34973,8 +28700,8 @@ and
@example
Init_Constants spec
-Init_Constants body
Constants spec
+Init_Constants body
Calc spec
Main body
@end example
@@ -35016,7 +28743,7 @@ compilers can choose different orders.
However, GNAT does attempt to diagnose the common situation where there
are uninitialized variables in the visible part of a package spec, and the
corresponding package body has an elaboration block that directly or
-indirectly initialized one or more of these variables. This is the situation
+indirectly initializes one or more of these variables. This is the situation
in which a pragma Elaborate_Body is usually desirable, and GNAT will generate
a warning that suggests this addition if it detects this situation.
@@ -35045,7 +28772,7 @@ and figuring out which is correct, and then adding the necessary
@cite{Elaborate} or @cite{Elaborate_All} pragmas to ensure the desired order.
@node Determining the Chosen Elaboration Order,,Other Elaboration Order Considerations,Elaboration Order Handling in GNAT
-@anchor{gnat_ugn/elaboration_order_handling_in_gnat determining-the-chosen-elaboration-order}@anchor{2d7}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id15}@anchor{2d8}
+@anchor{gnat_ugn/elaboration_order_handling_in_gnat determining-the-chosen-elaboration-order}@anchor{24c}@anchor{gnat_ugn/elaboration_order_handling_in_gnat id15}@anchor{24d}
@section Determining the Chosen Elaboration Order
@@ -35185,7 +28912,7 @@ gdbstr (body)
@end example
@node Inline Assembler,GNU Free Documentation License,Elaboration Order Handling in GNAT,Top
-@anchor{gnat_ugn/inline_assembler inline-assembler}@anchor{12}@anchor{gnat_ugn/inline_assembler doc}@anchor{2d9}@anchor{gnat_ugn/inline_assembler id1}@anchor{2da}
+@anchor{gnat_ugn/inline_assembler inline-assembler}@anchor{10}@anchor{gnat_ugn/inline_assembler doc}@anchor{24e}@anchor{gnat_ugn/inline_assembler id1}@anchor{24f}
@chapter Inline Assembler
@@ -35244,7 +28971,7 @@ and with assembly language programming.
@end menu
@node Basic Assembler Syntax,A Simple Example of Inline Assembler,,Inline Assembler
-@anchor{gnat_ugn/inline_assembler id2}@anchor{2db}@anchor{gnat_ugn/inline_assembler basic-assembler-syntax}@anchor{2dc}
+@anchor{gnat_ugn/inline_assembler id2}@anchor{250}@anchor{gnat_ugn/inline_assembler basic-assembler-syntax}@anchor{251}
@section Basic Assembler Syntax
@@ -35360,7 +29087,7 @@ Intel: Destination first; for example @cite{mov eax@comma{} 4}@w{ }
@node A Simple Example of Inline Assembler,Output Variables in Inline Assembler,Basic Assembler Syntax,Inline Assembler
-@anchor{gnat_ugn/inline_assembler a-simple-example-of-inline-assembler}@anchor{2dd}@anchor{gnat_ugn/inline_assembler id3}@anchor{2de}
+@anchor{gnat_ugn/inline_assembler a-simple-example-of-inline-assembler}@anchor{252}@anchor{gnat_ugn/inline_assembler id3}@anchor{253}
@section A Simple Example of Inline Assembler
@@ -35509,7 +29236,7 @@ If there are no errors, @emph{as} will generate an object file
@code{nothing.out}.
@node Output Variables in Inline Assembler,Input Variables in Inline Assembler,A Simple Example of Inline Assembler,Inline Assembler
-@anchor{gnat_ugn/inline_assembler id4}@anchor{2df}@anchor{gnat_ugn/inline_assembler output-variables-in-inline-assembler}@anchor{2e0}
+@anchor{gnat_ugn/inline_assembler id4}@anchor{254}@anchor{gnat_ugn/inline_assembler output-variables-in-inline-assembler}@anchor{255}
@section Output Variables in Inline Assembler
@@ -35876,7 +29603,7 @@ end Get_Flags_3;
@end quotation
@node Input Variables in Inline Assembler,Inlining Inline Assembler Code,Output Variables in Inline Assembler,Inline Assembler
-@anchor{gnat_ugn/inline_assembler id5}@anchor{2e1}@anchor{gnat_ugn/inline_assembler input-variables-in-inline-assembler}@anchor{2e2}
+@anchor{gnat_ugn/inline_assembler id5}@anchor{256}@anchor{gnat_ugn/inline_assembler input-variables-in-inline-assembler}@anchor{257}
@section Input Variables in Inline Assembler
@@ -35965,7 +29692,7 @@ _increment__incr.1:
@end quotation
@node Inlining Inline Assembler Code,Other Asm Functionality,Input Variables in Inline Assembler,Inline Assembler
-@anchor{gnat_ugn/inline_assembler id6}@anchor{2e3}@anchor{gnat_ugn/inline_assembler inlining-inline-assembler-code}@anchor{2e4}
+@anchor{gnat_ugn/inline_assembler id6}@anchor{258}@anchor{gnat_ugn/inline_assembler inlining-inline-assembler-code}@anchor{259}
@section Inlining Inline Assembler Code
@@ -36036,7 +29763,7 @@ movl %esi,%eax
thus saving the overhead of stack frame setup and an out-of-line call.
@node Other Asm Functionality,,Inlining Inline Assembler Code,Inline Assembler
-@anchor{gnat_ugn/inline_assembler other-asm-functionality}@anchor{2e5}@anchor{gnat_ugn/inline_assembler id7}@anchor{2e6}
+@anchor{gnat_ugn/inline_assembler other-asm-functionality}@anchor{25a}@anchor{gnat_ugn/inline_assembler id7}@anchor{25b}
@section Other @cite{Asm} Functionality
@@ -36051,7 +29778,7 @@ and @cite{Volatile}, which inhibits unwanted optimizations.
@end menu
@node The Clobber Parameter,The Volatile Parameter,,Other Asm Functionality
-@anchor{gnat_ugn/inline_assembler the-clobber-parameter}@anchor{2e7}@anchor{gnat_ugn/inline_assembler id8}@anchor{2e8}
+@anchor{gnat_ugn/inline_assembler the-clobber-parameter}@anchor{25c}@anchor{gnat_ugn/inline_assembler id8}@anchor{25d}
@subsection The @cite{Clobber} Parameter
@@ -36115,7 +29842,7 @@ Use 'register' name @cite{memory} if you changed a memory location
@end itemize
@node The Volatile Parameter,,The Clobber Parameter,Other Asm Functionality
-@anchor{gnat_ugn/inline_assembler the-volatile-parameter}@anchor{2e9}@anchor{gnat_ugn/inline_assembler id9}@anchor{2ea}
+@anchor{gnat_ugn/inline_assembler the-volatile-parameter}@anchor{25e}@anchor{gnat_ugn/inline_assembler id9}@anchor{25f}
@subsection The @cite{Volatile} Parameter
@@ -36151,7 +29878,7 @@ to @cite{True} only if the compiler's optimizations have created
problems.
@node GNU Free Documentation License,Index,Inline Assembler,Top
-@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license doc}@anchor{2eb}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{2ec}
+@anchor{share/gnu_free_documentation_license gnu-fdl}@anchor{1}@anchor{share/gnu_free_documentation_license doc}@anchor{260}@anchor{share/gnu_free_documentation_license gnu-free-documentation-license}@anchor{261}
@chapter GNU Free Documentation License
@@ -36639,6 +30366,8 @@ to permit their use in free software.
@printindex ge
+@anchor{de}@w{ }
+@anchor{gnat_ugn/gnat_utility_programs switches-related-to-project-files}@w{ }
@c %**end of body
@bye
diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb
index 3a4ec5318e..ebe87c11f0 100644
--- a/gcc/ada/gnatbind.adb
+++ b/gcc/ada/gnatbind.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -30,12 +30,10 @@ with Binde; use Binde;
with Binderr; use Binderr;
with Bindgen; use Bindgen;
with Bindusg;
-with Butil; use Butil;
with Casing; use Casing;
with Csets;
with Debug; use Debug;
with Fmap;
-with Fname; use Fname;
with Namet; use Namet;
with Opt; use Opt;
with Osint; use Osint;
@@ -45,7 +43,6 @@ with Rident; use Rident;
with Snames;
with Switch; use Switch;
with Switch.B; use Switch.B;
-with Table;
with Targparm; use Targparm;
with Types; use Types;
@@ -69,29 +66,22 @@ procedure Gnatbind is
-- The first library file, that should be a main subprogram if neither -n
-- nor -z are used.
- Std_Lib_File : File_Name_Type;
- -- Standard library
-
- Text : Text_Buffer_Ptr;
+ Text : Text_Buffer_Ptr;
Output_File_Name_Seen : Boolean := False;
Output_File_Name : String_Ptr := new String'("");
Mapping_File : String_Ptr := null;
- package Closure_Sources is new Table.Table
- (Table_Component_Type => File_Name_Type,
- Table_Index_Type => Natural,
- Table_Low_Bound => 1,
- Table_Initial => 10,
- Table_Increment => 100,
- Table_Name => "Gnatbind.Closure_Sources");
- -- Table to record the sources in the closure, to avoid duplications. Used
- -- only with switch -R.
+ procedure Add_Artificial_ALI_File (Name : String);
+ -- Artificially add ALI file Name in the closure
function Gnatbind_Supports_Auto_Init return Boolean;
- -- Indicates if automatic initialization of elaboration procedure
- -- through the constructor mechanism is possible on the platform.
+ -- Indicates if automatic initialization of elaboration procedure through
+ -- the constructor mechanism is possible on the platform.
+
+ function Is_Cross_Compiler return Boolean;
+ -- Returns True iff this is a cross-compiler
procedure List_Applicable_Restrictions;
-- List restrictions that apply to this partition if option taken
@@ -110,8 +100,33 @@ procedure Gnatbind is
procedure Write_Arg (S : String);
-- Passed to Generic_Scan_Bind_Args to print args
- function Is_Cross_Compiler return Boolean;
- -- Returns True iff this is a cross-compiler
+ -----------------------------
+ -- Add_Artificial_ALI_File --
+ -----------------------------
+
+ procedure Add_Artificial_ALI_File (Name : String) is
+ Id : ALI_Id;
+ pragma Warnings (Off, Id);
+
+ Std_Lib_File : File_Name_Type;
+ -- Standard library
+
+ begin
+ Name_Len := Name'Length;
+ Name_Buffer (1 .. Name_Len) := Name;
+ Std_Lib_File := Name_Find;
+ Text := Read_Library_Info (Std_Lib_File, True);
+
+ Id :=
+ Scan_ALI
+ (F => Std_Lib_File,
+ T => Text,
+ Ignore_ED => False,
+ Err => False,
+ Ignore_Errors => Debug_Flag_I);
+
+ Free (Text);
+ end Add_Artificial_ALI_File;
---------------------------------
-- Gnatbind_Supports_Auto_Init --
@@ -121,6 +136,7 @@ procedure Gnatbind is
function gnat_binder_supports_auto_init return Integer;
pragma Import (C, gnat_binder_supports_auto_init,
"__gnat_binder_supports_auto_init");
+
begin
return gnat_binder_supports_auto_init /= 0;
end Gnatbind_Supports_Auto_Init;
@@ -132,6 +148,7 @@ procedure Gnatbind is
function Is_Cross_Compiler return Boolean is
Cross_Compiler : Integer;
pragma Import (C, Cross_Compiler, "__gnat_is_cross_compiler");
+
begin
return Cross_Compiler = 1;
end Is_Cross_Compiler;
@@ -249,7 +266,6 @@ procedure Gnatbind is
when others =>
raise Program_Error;
-
end case;
end Restriction_Could_Be_Set;
@@ -260,13 +276,13 @@ procedure Gnatbind is
for R in All_Restrictions loop
if not No_Restriction_List (R)
- and then Restriction_Could_Be_Set (R)
+ and then Restriction_Could_Be_Set (R)
then
if not Additional_Restrictions_Listed then
Write_Eol;
Write_Line
- ("The following additional restrictions may be" &
- " applied to this partition:");
+ ("The following additional restrictions may be applied to "
+ & "this partition:");
Additional_Restrictions_Listed := True;
end if;
@@ -274,6 +290,7 @@ procedure Gnatbind is
declare
S : constant String := Restriction_Id'Image (R);
+
begin
Name_Len := S'Length;
Name_Buffer (1 .. Name_Len) := S;
@@ -350,8 +367,8 @@ procedure Gnatbind is
else
Fail
- ("Prefix of initialization and finalization " &
- "procedure names missing in -L");
+ ("Prefix of initialization and finalization procedure names "
+ & "missing in -L");
end if;
-- -Sin -Slo -Shi -Sxx -Sev
@@ -533,12 +550,12 @@ procedure Gnatbind is
Write_Str (" " & S);
end Write_Arg;
- procedure Scan_Bind_Args is new Generic_Scan_Bind_Args (Scan_Bind_Arg);
- procedure Put_Bind_Args is new Generic_Scan_Bind_Args (Write_Arg);
-
procedure Check_Version_And_Help is
new Check_Version_And_Help_G (Bindusg.Display);
+ procedure Put_Bind_Args is new Generic_Scan_Bind_Args (Write_Arg);
+ procedure Scan_Bind_Args is new Generic_Scan_Bind_Args (Scan_Bind_Arg);
+
-- Start of processing for Gnatbind
begin
@@ -555,8 +572,8 @@ begin
begin
pragma Assert
(Shared_Libgnat_Default = SHARED
- or else
- Shared_Libgnat_Default = STATIC);
+ or else
+ Shared_Libgnat_Default = STATIC);
Shared_Libgnat := (Shared_Libgnat_Default = SHARED);
end;
@@ -591,8 +608,8 @@ begin
Fail ("switch -a must be used in conjunction with -n or -Lxxx");
elsif not Gnatbind_Supports_Auto_Init then
- Fail ("automatic initialisation of elaboration " &
- "not supported on this platform");
+ Fail ("automatic initialisation of elaboration not supported on this "
+ & "platform");
end if;
end if;
@@ -614,6 +631,7 @@ begin
Check_Extensions : declare
Length : constant Natural := Output_File_Name'Length;
Last : constant Natural := Output_File_Name'Last;
+
begin
if Length <= 4
or else Output_File_Name (Last - 3 .. Last) /= ".adb"
@@ -740,29 +758,15 @@ begin
-- Add System.Standard_Library to list to ensure that these files are
-- included in the bind, even if not directly referenced from Ada code
- -- This is suppressed if the appropriate targparm switch is set.
+ -- This is suppressed if the appropriate targparm switch is set. Be sure
+ -- in any case that System is in the closure, as it may contain linker
+ -- options. Note that it will be automatically added if s-stalib is
+ -- added.
if not Suppress_Standard_Library_On_Target then
- Name_Buffer (1 .. 12) := "s-stalib.ali";
- Name_Len := 12;
- Std_Lib_File := Name_Find;
- Text := Read_Library_Info (Std_Lib_File, True);
-
- declare
- Id : ALI_Id;
- pragma Warnings (Off, Id);
-
- begin
- Id :=
- Scan_ALI
- (F => Std_Lib_File,
- T => Text,
- Ignore_ED => False,
- Err => False,
- Ignore_Errors => Debug_Flag_I);
- end;
-
- Free (Text);
+ Add_Artificial_ALI_File ("s-stalib.ali");
+ else
+ Add_Artificial_ALI_File ("system.ali");
end if;
-- Load ALIs for all dependent units
@@ -841,12 +845,15 @@ begin
end;
end if;
- -- Perform consistency and correctness checks
+ -- Perform consistency and correctness checks. Disable these in CodePeer
+ -- mode where we want to be more flexible.
- Check_Duplicated_Subunits;
- Check_Versions;
- Check_Consistency;
- Check_Configuration_Consistency;
+ if not CodePeer_Mode then
+ Check_Duplicated_Subunits;
+ Check_Versions;
+ Check_Consistency;
+ Check_Configuration_Consistency;
+ end if;
-- List restrictions that could be applied to this partition
@@ -857,132 +864,19 @@ begin
-- Complete bind if no errors
if Errors_Detected = 0 then
- Find_Elab_Order;
-
- if Errors_Detected = 0 then
- -- Display elaboration order if -l was specified
-
- if Elab_Order_Output then
- if not Zero_Formatting then
- Write_Eol;
- Write_Str ("ELABORATION ORDER");
- Write_Eol;
- end if;
-
- for J in Elab_Order.First .. Elab_Order.Last loop
- if not Units.Table (Elab_Order.Table (J)).SAL_Interface then
- if not Zero_Formatting then
- Write_Str (" ");
- end if;
-
- Write_Unit_Name
- (Units.Table (Elab_Order.Table (J)).Uname);
- Write_Eol;
- end if;
- end loop;
-
- if not Zero_Formatting then
- Write_Eol;
- end if;
- end if;
-
- if not Check_Only then
- Gen_Output_File (Output_File_Name.all);
- end if;
+ declare
+ Elab_Order : Unit_Id_Table;
+ use Unit_Id_Tables;
- -- Display list of sources in the closure (except predefined
- -- sources) if -R was used.
-
- if List_Closure then
- List_Closure_Display : declare
- Source : File_Name_Type;
-
- function Put_In_Sources (S : File_Name_Type) return Boolean;
- -- Check if S is already in table Sources and put in Sources
- -- if it is not. Return False if the source is already in
- -- Sources, and True if it is added.
-
- --------------------
- -- Put_In_Sources --
- --------------------
-
- function Put_In_Sources
- (S : File_Name_Type) return Boolean
- is
- begin
- for J in 1 .. Closure_Sources.Last loop
- if Closure_Sources.Table (J) = S then
- return False;
- end if;
- end loop;
-
- Closure_Sources.Append (S);
- return True;
- end Put_In_Sources;
-
- -- Start of processing for List_Closure_Display
-
- begin
- Closure_Sources.Init;
-
- if not Zero_Formatting then
- Write_Eol;
- Write_Str ("REFERENCED SOURCES");
- Write_Eol;
- end if;
+ begin
+ Find_Elab_Order (Elab_Order, First_Main_Lib_File);
- for J in reverse Elab_Order.First .. Elab_Order.Last loop
- Source := Units.Table (Elab_Order.Table (J)).Sfile;
-
- -- Do not include same source more than once
-
- if Put_In_Sources (Source)
-
- -- Do not include run-time units unless -Ra switch set
-
- and then (List_Closure_All
- or else not Is_Internal_File_Name (Source))
- then
- if not Zero_Formatting then
- Write_Str (" ");
- end if;
-
- Write_Str (Get_Name_String (Source));
- Write_Eol;
- end if;
- end loop;
-
- -- Subunits do not appear in the elaboration table because
- -- they are subsumed by their parent units, but we need to
- -- list them for other tools. For now they are listed after
- -- other files, rather than right after their parent, since
- -- there is no easy link between the elaboration table and
- -- the ALIs table ??? As subunits may appear repeatedly in
- -- the list, if the parent unit appears in the context of
- -- several units in the closure, duplicates are suppressed.
-
- for J in Sdep.First .. Sdep.Last loop
- Source := Sdep.Table (J).Sfile;
-
- if Sdep.Table (J).Subunit_Name /= No_Name
- and then Put_In_Sources (Source)
- and then not Is_Internal_File_Name (Source)
- then
- if not Zero_Formatting then
- Write_Str (" ");
- end if;
-
- Write_Str (Get_Name_String (Source));
- Write_Eol;
- end if;
- end loop;
-
- if not Zero_Formatting then
- Write_Eol;
- end if;
- end List_Closure_Display;
+ if Errors_Detected = 0 and then not Check_Only then
+ Gen_Output_File
+ (Output_File_Name.all,
+ Elab_Order => Elab_Order.Table (First .. Last (Elab_Order)));
end if;
- end if;
+ end;
end if;
Total_Errors := Total_Errors + Errors_Detected;
@@ -994,7 +888,7 @@ begin
Total_Warnings := Total_Warnings + Warnings_Detected;
end;
- -- All done. Set proper exit status
+ -- All done. Set the proper exit status.
Finalize_Binderr;
Namet.Finalize;
diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb
index 451f202138..e82e8d591a 100644
--- a/gcc/ada/gnatcmd.adb
+++ b/gcc/ada/gnatcmd.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -23,13 +23,9 @@
-- --
------------------------------------------------------------------------------
-with GNAT.Directory_Operations; use GNAT.Directory_Operations;
-
with Csets;
with Gnatvsn;
with Makeutl; use Makeutl;
-with MLib.Tgt; use MLib.Tgt;
-with MLib.Utl;
with Namet; use Namet;
with Opt; use Opt;
with Osint; use Osint;
@@ -46,7 +42,6 @@ with Snames; use Snames;
with Stringt;
with Switch; use Switch;
with Table;
-with Targparm; use Targparm;
with Tempdir;
with Types; use Types;
@@ -54,15 +49,14 @@ with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
-with GNAT.OS_Lib; use GNAT.OS_Lib;
+with GNAT.Directory_Operations; use GNAT.Directory_Operations;
+with GNAT.OS_Lib; use GNAT.OS_Lib;
procedure GNATCmd is
Gprbuild : constant String := "gprbuild";
Gprclean : constant String := "gprclean";
Gprname : constant String := "gprname";
-
- Normal_Exit : exception;
- -- Raise this exception for normal program termination
+ Gprls : constant String := "gprls";
Error_Exit : exception;
-- Raise this exception if error detected
@@ -103,6 +97,9 @@ procedure GNATCmd is
Pp => Pretty);
-- Mapping of alternate commands to commands
+ Call_GPR_Tool : Boolean := False;
+ -- True when a GPR tool should be called, if available
+
Project_Node_Tree : Project_Node_Tree_Ref;
Project_File : String_Access;
Project : Prj.Project_Id;
@@ -113,10 +110,7 @@ procedure GNATCmd is
new Project_Tree_Data (Is_Root_Tree => True);
-- The project tree
- Old_Project_File_Used : Boolean := False;
- -- This flag indicates a switch -p (for gnatxref and gnatfind) for
- -- an old fashioned project file. -p cannot be used in conjunction
- -- with -P.
+ All_Projects : Boolean := False;
Temp_File_Name : Path_Name_Type := No_Path;
-- The name of the temporary text file to put a list of source/object
@@ -131,32 +125,6 @@ procedure GNATCmd is
Table_Name => "Gnatcmd.First_Switches");
-- A table to keep the switches from the project file
- package Carg_Switches is new Table.Table
- (Table_Component_Type => String_Access,
- Table_Index_Type => Integer,
- Table_Low_Bound => 1,
- Table_Initial => 20,
- Table_Increment => 100,
- Table_Name => "Gnatcmd.Carg_Switches");
- -- A table to keep the switches following -cargs for ASIS tools
-
- package Rules_Switches is new Table.Table
- (Table_Component_Type => String_Access,
- Table_Index_Type => Integer,
- Table_Low_Bound => 1,
- Table_Initial => 20,
- Table_Increment => 100,
- Table_Name => "Gnatcmd.Rules_Switches");
- -- A table to keep the switches following -rules for gnatcheck
-
- package Library_Paths is new Table.Table (
- Table_Component_Type => String_Access,
- Table_Index_Type => Integer,
- Table_Low_Bound => 1,
- Table_Initial => 20,
- Table_Increment => 100,
- Table_Name => "Make.Library_Path");
-
package Last_Switches is new Table.Table
(Table_Component_Type => String_Access,
Table_Index_Type => Integer,
@@ -165,36 +133,6 @@ procedure GNATCmd is
Table_Increment => 100,
Table_Name => "Gnatcmd.Last_Switches");
- -- Packages of project files to pass to Prj.Pars.Parse, depending on the
- -- tool. We allocate objects because we cannot declare aliased objects
- -- as we are in a procedure, not a library level package.
-
- subtype SA is String_Access;
-
- Naming_String : constant SA := new String'("naming");
- Binder_String : constant SA := new String'("binder");
- Finder_String : constant SA := new String'("finder");
- Linker_String : constant SA := new String'("linker");
- Gnatls_String : constant SA := new String'("gnatls");
- Xref_String : constant SA := new String'("cross_reference");
-
- Packages_To_Check_By_Binder : constant String_List_Access :=
- new String_List'((Naming_String, Binder_String));
-
- Packages_To_Check_By_Finder : constant String_List_Access :=
- new String_List'((Naming_String, Finder_String));
-
- Packages_To_Check_By_Linker : constant String_List_Access :=
- new String_List'((Naming_String, Linker_String));
-
- Packages_To_Check_By_Gnatls : constant String_List_Access :=
- new String_List'((Naming_String, Gnatls_String));
-
- Packages_To_Check_By_Xref : constant String_List_Access :=
- new String_List'((Naming_String, Xref_String));
-
- Packages_To_Check : String_List_Access := Prj.All_Packages;
-
----------------------------------
-- Declarations for GNATCMD use --
----------------------------------
@@ -208,14 +146,6 @@ procedure GNATCmd is
My_Exit_Status : Exit_Status := Success;
-- The exit status of the spawned tool
- Current_Work_Dir : constant String := Get_Current_Dir;
- -- The path of the working directory
-
- All_Projects : Boolean := False;
- -- Flag used for GNAT CHECK, GNAT PRETTY and GNAT METRIC to indicate that
- -- the underlying tool (gnatcheck, gnatpp or gnatmetric) should be invoked
- -- for all sources of all projects.
-
type Command_Entry is record
Cname : String_Access;
-- Command name for GNAT xxx command
@@ -326,32 +256,25 @@ procedure GNATCmd is
Unixsws => null)
);
+ subtype SA is String_Access;
+
+ Naming_String : constant SA := new String'("naming");
+ Gnatls_String : constant SA := new String'("gnatls");
+
+ Packages_To_Check_By_Gnatls : constant String_List_Access :=
+ new String_List'((Naming_String, Gnatls_String));
+
+ Packages_To_Check : String_List_Access := Prj.All_Packages;
+
-----------------------
-- Local Subprograms --
-----------------------
procedure Check_Files;
- -- For GNAT LIST, GNAT PRETTY and GNAT METRIC, check if a project file
- -- is specified, without any file arguments and without a switch -files=.
- -- If it is the case, invoke the GNAT tool with the proper list of files,
- -- derived from the sources of the project.
-
- procedure Check_Relative_Executable (Name : in out String_Access);
- -- Check if an executable is specified as a relative path. If it is, and
- -- the path contains directory information, fail. Otherwise, prepend the
- -- exec directory. This procedure is only used for GNAT LINK when a project
- -- file is specified.
-
- procedure Delete_Temp_Config_Files;
- -- Delete all temporary config files. The caller is responsible for
- -- ensuring that Keep_Temporary_Files is False.
-
- procedure Ensure_Absolute_Path
- (Switch : in out String_Access;
- Parent : String);
- -- Test if Switch is a relative search path switch. If it is and it
- -- includes directory information, prepend the path with Parent. This
- -- subprogram is only called when using project files.
+ -- For GNAT LIST -V, check if a project file is specified, without any file
+ -- arguments and without a switch -files=. If it is the case, invoke the
+ -- GNAT tool with the proper list of files, derived from the sources of
+ -- the project.
procedure Output_Version;
-- Output the version of this program
@@ -359,20 +282,6 @@ procedure GNATCmd is
procedure Usage;
-- Display usage
- procedure Process_Link;
- -- Process GNAT LINK, when there is a project file specified
-
- procedure Set_Library_For
- (Project : Project_Id;
- Tree : Project_Tree_Ref;
- Libraries_Present : in out Boolean);
- -- If Project is a library project, add the correct -L and -l switches to
- -- the linker invocation.
-
- procedure Set_Libraries is new
- For_Every_Project_Imported (Boolean, Set_Library_For);
- -- Add the -L and -l switches to the linker for all the library projects
-
-----------------
-- Check_Files --
-----------------
@@ -447,6 +356,7 @@ procedure GNATCmd is
if Add_Sources then
Tempdir.Create_Temp_File (FD, Temp_File_Name);
+ Record_Temp_File (Project_Tree.Shared, Temp_File_Name);
Last_Switches.Increment_Last;
Last_Switches.Table (Last_Switches.Last) :=
new String'("-files=" & Get_Name_String (Temp_File_Name));
@@ -518,99 +428,13 @@ procedure GNATCmd is
end if;
end Check_Files;
- -------------------------------
- -- Check_Relative_Executable --
- -------------------------------
-
- procedure Check_Relative_Executable (Name : in out String_Access) is
- Exec_File_Name : constant String := Name.all;
-
- begin
- if not Is_Absolute_Path (Exec_File_Name) then
- for Index in Exec_File_Name'Range loop
- if Exec_File_Name (Index) = Directory_Separator then
- Fail ("relative executable (""" & Exec_File_Name
- & """) with directory part not allowed "
- & "when using project files");
- end if;
- end loop;
-
- Get_Name_String (Project.Exec_Directory.Name);
-
- if Name_Buffer (Name_Len) /= Directory_Separator then
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := Directory_Separator;
- end if;
-
- Name_Buffer (Name_Len + 1 .. Name_Len + Exec_File_Name'Length) :=
- Exec_File_Name;
- Name_Len := Name_Len + Exec_File_Name'Length;
- Name := new String'(Name_Buffer (1 .. Name_Len));
- end if;
- end Check_Relative_Executable;
-
- ------------------------------
- -- Delete_Temp_Config_Files --
- ------------------------------
-
- procedure Delete_Temp_Config_Files is
- Success : Boolean;
- Proj : Project_List;
- pragma Warnings (Off, Success);
-
- begin
- -- This should only be called if Keep_Temporary_Files is False
-
- pragma Assert (not Keep_Temporary_Files);
-
- if Project /= No_Project then
- Proj := Project_Tree.Projects;
- while Proj /= null loop
- if Proj.Project.Config_File_Temp then
- Delete_Temporary_File
- (Project_Tree.Shared, Proj.Project.Config_File_Name);
- end if;
-
- Proj := Proj.Next;
- end loop;
- end if;
-
- -- If a temporary text file that contains a list of files for a tool
- -- has been created, delete this temporary file.
-
- if Temp_File_Name /= No_Path then
- Delete_Temporary_File (Project_Tree.Shared, Temp_File_Name);
- end if;
- end Delete_Temp_Config_Files;
-
- ---------------------------
- -- Ensure_Absolute_Path --
- ---------------------------
-
- procedure Ensure_Absolute_Path
- (Switch : in out String_Access;
- Parent : String)
- is
- begin
- Makeutl.Ensure_Absolute_Path
- (Switch, Parent,
- Do_Fail => Osint.Fail'Access,
- Including_Non_Switch => False,
- Including_RTS => True);
- end Ensure_Absolute_Path;
-
--------------------
-- Output_Version --
--------------------
procedure Output_Version is
begin
- if AAMP_On_Target then
- Put ("GNAAMP ");
- else
- Put ("GNAT ");
- end if;
-
+ Put ("GNAT ");
Put_Line (Gnatvsn.Gnat_Version_String);
Put_Line ("Copyright 1996-" & Gnatvsn.Current_Year
& ", Free Software Foundation, Inc.");
@@ -628,13 +452,7 @@ procedure GNATCmd is
New_Line;
for C in Command_List'Range loop
-
- if Targparm.AAMP_On_Target then
- Put ("gnaampcmd ");
- else
- Put ("gnat ");
- end if;
-
+ Put ("gnat ");
Put (To_Lower (Command_List (C).Cname.all));
Set_Col (25);
Put (Program_Name (Command_List (C).Unixcmd.all, "gnat").all);
@@ -654,330 +472,8 @@ procedure GNATCmd is
end loop;
New_Line;
- Put_Line ("Commands bind, find, link, list and xref "
- & "accept project file switches -vPx, -Pprj, -Xnam=val,"
- & "--subdirs= and -eL");
- New_Line;
end Usage;
- ------------------
- -- Process_Link --
- ------------------
-
- procedure Process_Link is
- Look_For_Executable : Boolean := True;
- Libraries_Present : Boolean := False;
- Path_Option : constant String_Access :=
- MLib.Linker_Library_Path_Option;
- Prj : Project_Id := Project;
- Arg : String_Access;
- Last : Natural := 0;
- Skip_Executable : Boolean := False;
-
- begin
- -- Add the default search directories, to be able to find libgnat in
- -- call to MLib.Utl.Lib_Directory.
-
- Add_Default_Search_Dirs;
-
- Library_Paths.Set_Last (0);
-
- -- Check if there are library project files
-
- if MLib.Tgt.Support_For_Libraries /= None then
- Set_Libraries (Project, Project_Tree, Libraries_Present);
- end if;
-
- -- If there are, add the necessary additional switches
-
- if Libraries_Present then
-
- -- Add -Wl,-rpath,<lib_dir>
-
- -- If Path_Option is not null, create the switch ("-Wl,-rpath," or
- -- equivalent) with all the library dirs plus the standard GNAT
- -- library dir.
-
- if Path_Option /= null then
- declare
- Option : String_Access;
- Length : Natural := Path_Option'Length;
- Current : Natural;
-
- begin
- if MLib.Separate_Run_Path_Options then
-
- -- We are going to create one switch of the form
- -- "-Wl,-rpath,dir_N" for each directory to consider.
-
- -- One switch for each library directory
-
- for Index in
- Library_Paths.First .. Library_Paths.Last
- loop
- Last_Switches.Increment_Last;
- Last_Switches.Table
- (Last_Switches.Last) := new String'
- (Path_Option.all &
- Last_Switches.Table (Index).all);
- end loop;
-
- -- One switch for the standard GNAT library dir
-
- Last_Switches.Increment_Last;
- Last_Switches.Table
- (Last_Switches.Last) := new String'
- (Path_Option.all & MLib.Utl.Lib_Directory);
-
- else
- -- First, compute the exact length for the switch
-
- for Index in Library_Paths.First .. Library_Paths.Last loop
-
- -- Add the length of the library dir plus one for the
- -- directory separator.
-
- Length :=
- Length +
- Library_Paths.Table (Index)'Length + 1;
- end loop;
-
- -- Finally, add the length of the standard GNAT library dir
-
- Length := Length + MLib.Utl.Lib_Directory'Length;
- Option := new String (1 .. Length);
- Option (1 .. Path_Option'Length) := Path_Option.all;
- Current := Path_Option'Length;
-
- -- Put each library dir followed by a dir separator
-
- for Index in
- Library_Paths.First .. Library_Paths.Last
- loop
- Option
- (Current + 1 ..
- Current + Library_Paths.Table (Index)'Length) :=
- Library_Paths.Table (Index).all;
- Current :=
- Current + Library_Paths.Table (Index)'Length + 1;
- Option (Current) := Path_Separator;
- end loop;
-
- -- Finally put the standard GNAT library dir
-
- Option
- (Current + 1 .. Current + MLib.Utl.Lib_Directory'Length) :=
- MLib.Utl.Lib_Directory;
-
- -- And add the switch to the last switches
-
- Last_Switches.Increment_Last;
- Last_Switches.Table (Last_Switches.Last) := Option;
- end if;
- end;
- end if;
- end if;
-
- -- Check if the first ALI file specified can be found, either in the
- -- object directory of the main project or in an object directory of a
- -- project file extended by the main project. If the ALI file can be
- -- found, replace its name with its absolute path.
-
- Skip_Executable := False;
-
- Switch_Loop : for J in 1 .. Last_Switches.Last loop
-
- -- If we have an executable just reset the flag
-
- if Skip_Executable then
- Skip_Executable := False;
-
- -- If -o, set flag so that next switch is not processed
-
- elsif Last_Switches.Table (J).all = "-o" then
- Skip_Executable := True;
-
- -- Normal case
-
- else
- declare
- Switch : constant String := Last_Switches.Table (J).all;
- ALI_File : constant String (1 .. Switch'Length + 4) :=
- Switch & ".ali";
-
- Test_Existence : Boolean := False;
-
- begin
- Last := Switch'Length;
-
- -- Skip real switches
-
- if Switch'Length /= 0
- and then Switch (Switch'First) /= '-'
- then
- -- Append ".ali" if file name does not end with it
-
- if Switch'Length <= 4
- or else Switch (Switch'Last - 3 .. Switch'Last) /= ".ali"
- then
- Last := ALI_File'Last;
- end if;
-
- -- If file name includes directory information, stop if ALI
- -- file exists.
-
- if Is_Absolute_Path (ALI_File (1 .. Last)) then
- Test_Existence := True;
-
- else
- for K in Switch'Range loop
- if Is_Directory_Separator (Switch (K)) then
- Test_Existence := True;
- exit;
- end if;
- end loop;
- end if;
-
- if Test_Existence then
- if Is_Regular_File (ALI_File (1 .. Last)) then
- exit Switch_Loop;
- end if;
-
- -- Look in object directories if ALI file exists
-
- else
- Project_Loop : loop
- declare
- Dir : constant String :=
- Get_Name_String (Prj.Object_Directory.Name);
- begin
- if Is_Regular_File (Dir & ALI_File (1 .. Last)) then
-
- -- We have found the correct project, so we
- -- replace the file with the absolute path.
-
- Last_Switches.Table (J) :=
- new String'(Dir & ALI_File (1 .. Last));
-
- -- And we are done
-
- exit Switch_Loop;
- end if;
- end;
-
- -- Go to the project being extended, if any
-
- Prj := Prj.Extends;
- exit Project_Loop when Prj = No_Project;
- end loop Project_Loop;
- end if;
- end if;
- end;
- end if;
- end loop Switch_Loop;
-
- -- If a relative path output file has been specified, we add the exec
- -- directory.
-
- for J in reverse 1 .. Last_Switches.Last - 1 loop
- if Last_Switches.Table (J).all = "-o" then
- Check_Relative_Executable (Name => Last_Switches.Table (J + 1));
- Look_For_Executable := False;
- exit;
- end if;
- end loop;
-
- if Look_For_Executable then
- for J in reverse 1 .. First_Switches.Last - 1 loop
- if First_Switches.Table (J).all = "-o" then
- Look_For_Executable := False;
- Check_Relative_Executable
- (Name => First_Switches.Table (J + 1));
- exit;
- end if;
- end loop;
- end if;
-
- -- If no executable is specified, then find the name of the first ALI
- -- file on the command line and issue a -o switch with the absolute path
- -- of the executable in the exec directory.
-
- if Look_For_Executable then
- for J in 1 .. Last_Switches.Last loop
- Arg := Last_Switches.Table (J);
- Last := 0;
-
- if Arg'Length /= 0 and then Arg (Arg'First) /= '-' then
- if Arg'Length > 4
- and then Arg (Arg'Last - 3 .. Arg'Last) = ".ali"
- then
- Last := Arg'Last - 4;
-
- elsif Is_Regular_File (Arg.all & ".ali") then
- Last := Arg'Last;
- end if;
-
- if Last /= 0 then
- Last_Switches.Increment_Last;
- Last_Switches.Table (Last_Switches.Last) :=
- new String'("-o");
- Get_Name_String (Project.Exec_Directory.Name);
- Last_Switches.Increment_Last;
- Last_Switches.Table (Last_Switches.Last) :=
- new String'(Name_Buffer (1 .. Name_Len) &
- Executable_Name
- (Base_Name (Arg (Arg'First .. Last))));
- exit;
- end if;
- end if;
- end loop;
- end if;
- end Process_Link;
-
- ---------------------
- -- Set_Library_For --
- ---------------------
-
- procedure Set_Library_For
- (Project : Project_Id;
- Tree : Project_Tree_Ref;
- Libraries_Present : in out Boolean)
- is
- pragma Unreferenced (Tree);
-
- Path_Option : constant String_Access := MLib.Linker_Library_Path_Option;
-
- begin
- -- Case of library project
-
- if Project.Library then
- Libraries_Present := True;
-
- -- Add the -L switch
-
- Last_Switches.Increment_Last;
- Last_Switches.Table (Last_Switches.Last) :=
- new String'("-L" & Get_Name_String (Project.Library_Dir.Name));
-
- -- Add the -l switch
-
- Last_Switches.Increment_Last;
- Last_Switches.Table (Last_Switches.Last) :=
- new String'("-l" & Get_Name_String (Project.Library_Name));
-
- -- Add the directory to table Library_Paths, to be processed later
- -- if library is not static and if Path_Option is not null.
-
- if Project.Library_Kind /= Static
- and then Path_Option /= null
- then
- Library_Paths.Increment_Last;
- Library_Paths.Table (Library_Paths.Last) :=
- new String'(Get_Name_String (Project.Library_Dir.Name));
- end if;
- end if;
- end Set_Library_For;
-
procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
-- Start of processing for GNATCmd
@@ -1005,17 +501,6 @@ begin
First_Switches.Init;
First_Switches.Set_Last (0);
- Carg_Switches.Init;
- Carg_Switches.Set_Last (0);
- Rules_Switches.Init;
- Rules_Switches.Set_Last (0);
-
- -- Set AAMP_On_Target from command name, for testing in Osint.Program_Name
- -- to handle the mapping of GNAAMP tool names. We don't extract it from
- -- system.ads, as there may be no default runtime.
-
- Find_Program_Name;
- AAMP_On_Target := Name_Buffer (1 .. Name_Len) = "gnaampcmd";
-- Put the command line in environment variable GNAT_DRIVER_COMMAND_LINE,
-- so that the spawned tool may know the way the GNAT driver was invoked.
@@ -1171,6 +656,7 @@ begin
begin
if The_Command = Stack then
+
-- Never call gnatstack with a prefix
Program := new String'(Command_List (The_Command).Unixcmd.all);
@@ -1182,34 +668,63 @@ begin
-- If we want to invoke gnatmake/gnatclean with -P, then check if
-- gprbuild/gprclean is available; if it is, use gprbuild/gprclean
-- instead of gnatmake/gnatclean.
- -- Ditto for gnatname -> gprname.
+ -- Ditto for gnatname -> gprname and gnatls -> gprls.
if The_Command = Make
- or else The_Command = Compile
- or else The_Command = Clean
- or else The_Command = Name
+ or else The_Command = Compile
+ or else The_Command = Bind
+ or else The_Command = Link
+ or else The_Command = Clean
+ or else The_Command = Name
+ or else The_Command = List
then
declare
- Project_File_Used : Boolean := False;
Switch : String_Access;
+ Dash_V_Switch : constant String := "-V";
begin
for J in 1 .. Last_Switches.Last loop
Switch := Last_Switches.Table (J);
- if Switch'Length >= 2 and then
- Switch (Switch'First .. Switch'First + 1) = "-P"
+
+ if The_Command = List and then Switch.all = Dash_V_Switch
then
- Project_File_Used := True;
+ Call_GPR_Tool := False;
exit;
end if;
+
+ if Switch'Length >= 2
+ and then Switch (Switch'First .. Switch'First + 1) = "-P"
+ then
+ Call_GPR_Tool := True;
+ end if;
end loop;
- if Project_File_Used then
+ if Call_GPR_Tool then
case The_Command is
- when Make | Compile =>
- if Locate_Exec_On_Path (Gprbuild) /= null then
- Program := new String'(Gprbuild);
+ when Bind
+ | Compile
+ | Link
+ | Make
+ =>
+ if Locate_Exec_On_Path (Gprbuild) /= null then
+ Program := new String'(Gprbuild);
Get_Target := True;
+
+ if The_Command = Bind then
+ First_Switches.Append (new String'("-b"));
+ elsif The_Command = Link then
+ First_Switches.Append (new String'("-l"));
+ end if;
+
+ elsif The_Command = Bind then
+ Fail
+ ("'gnat bind -P' is no longer supported;" &
+ " use 'gprbuild -b' instead.");
+
+ elsif The_Command = Link then
+ Fail
+ ("'gnat Link -P' is no longer supported;" &
+ " use 'gprbuild -l' instead.");
end if;
when Clean =>
@@ -1224,6 +739,12 @@ begin
Get_Target := True;
end if;
+ when List =>
+ if Locate_Exec_On_Path (Gprls) /= null then
+ Program := new String'(Gprls);
+ Get_Target := True;
+ end if;
+
when others =>
null;
end case;
@@ -1242,15 +763,6 @@ begin
end if;
end if;
- -- For the tools where the GNAT driver processes the project files,
- -- allow shared library projects to import projects that are not shared
- -- library projects, to avoid adding a switch for these tools. For the
- -- builder (gnatmake), if a shared library project imports a project
- -- that is not a shared library project and the appropriate switch is
- -- not specified, the invocation of gnatmake will fail.
-
- Opt.Unchecked_Shared_Lib_Imports := True;
-
-- Locate the executable for the command
Exec_Path := Locate_Exec_On_Path (Program.all);
@@ -1270,30 +782,33 @@ begin
end loop;
end if;
- -- For BIND, FIND, LINK, LIST and XREF, look for project file related
- -- switches.
-
- case The_Command is
- when Bind =>
- Tool_Package_Name := Name_Binder;
- Packages_To_Check := Packages_To_Check_By_Binder;
- when Find =>
- Tool_Package_Name := Name_Finder;
- Packages_To_Check := Packages_To_Check_By_Finder;
- when Link =>
- Tool_Package_Name := Name_Linker;
- Packages_To_Check := Packages_To_Check_By_Linker;
- when List =>
- Tool_Package_Name := Name_Gnatls;
- Packages_To_Check := Packages_To_Check_By_Gnatls;
- when Xref =>
- Tool_Package_Name := Name_Cross_Reference;
- Packages_To_Check := Packages_To_Check_By_Xref;
- when others =>
- Tool_Package_Name := No_Name;
- end case;
-
- if Tool_Package_Name /= No_Name then
+ -- For FIND and XREF, look for switch -P. If it is specified, then
+ -- report an error indicating that the command is no longer supporting
+ -- project files.
+
+ if The_Command = Find or else The_Command = Xref then
+ declare
+ Argv : String_Access;
+ begin
+ for Arg_Num in 1 .. Last_Switches.Last loop
+ Argv := Last_Switches.Table (Arg_Num);
+
+ if Argv'Length >= 2 and then
+ Argv (Argv'First .. Argv'First + 1) = "-P"
+ then
+ if The_Command = Find then
+ Fail ("'gnat find -P' is no longer supported;");
+ else
+ Fail ("'gnat xref -P' is no longer supported;");
+ end if;
+ end if;
+ end loop;
+ end;
+ end if;
+
+ if The_Command = List and then not Call_GPR_Tool then
+ Tool_Package_Name := Name_Gnatls;
+ Packages_To_Check := Packages_To_Check_By_Gnatls;
-- Check that the switches are consistent. Detect project file
-- related switches.
@@ -1327,18 +842,6 @@ begin
Fail ("switch character cannot be followed by a blank");
end if;
- -- The two style project files (-p and -P) cannot be used
- -- together
-
- if (The_Command = Find or else The_Command = Xref)
- and then Argv (2) = 'p'
- then
- Old_Project_File_Used := True;
- if Project_File /= null then
- Fail ("-P and -p cannot be used together");
- end if;
- end if;
-
-- --subdirs=... Specify Subdirs
if Argv'Length > Makeutl.Subdirs_Option'Length
@@ -1420,12 +923,6 @@ begin
& ": second project file forbidden (first is """
& Project_File.all & """)");
- -- The two style project files (-p and -P) cannot be
- -- used together.
-
- elsif Old_Project_File_Used then
- Fail ("-p and -P cannot be used together");
-
elsif Argv'Length = 2 then
-- There is space between -P and the project file
@@ -1473,6 +970,14 @@ begin
Remove_Switch (Arg_Num);
+ -- --unchecked-shared-lib-imports
+
+ elsif Argv.all = "--unchecked-shared-lib-imports" then
+ Opt.Unchecked_Shared_Lib_Imports := True;
+ Remove_Switch (Arg_Num);
+
+ -- gnat list -U
+
elsif
The_Command = List
and then Argv'Length = 2
@@ -1680,42 +1185,6 @@ begin
Prj.Env.Set_Ada_Paths
(Project, Project_Tree, Including_Libraries => True);
- -- For gnatcheck, gnatstub, gnatmetric, gnatpp and gnatelim, create
- -- a configuration pragmas file, if necessary.
-
- if The_Command = Link then
- Process_Link;
- end if;
-
- if The_Command = Link or else The_Command = Bind then
-
- -- For files that are specified as relative paths with directory
- -- information, we convert them to absolute paths, with parent
- -- being the current working directory if specified on the command
- -- line and the project directory if specified in the project
- -- file. This is what gnatmake is doing for linker and binder
- -- arguments.
-
- for J in 1 .. Last_Switches.Last loop
- GNATCmd.Ensure_Absolute_Path
- (Last_Switches.Table (J), Current_Work_Dir);
- end loop;
-
- Get_Name_String (Project.Directory.Name);
-
- declare
- Project_Dir : constant String := Name_Buffer (1 .. Name_Len);
- begin
- for J in 1 .. First_Switches.Last loop
- GNATCmd.Ensure_Absolute_Path
- (First_Switches.Table (J), Project_Dir);
- end loop;
- end;
- end if;
-
- -- For gnat list, if no file has been put on the command line, call
- -- tool with all the sources of the main project.
-
if The_Command = List then
Check_Files;
end if;
@@ -1725,10 +1194,7 @@ begin
declare
The_Args : Argument_List
- (1 .. First_Switches.Last +
- Last_Switches.Last +
- Carg_Switches.Last +
- Rules_Switches.Last);
+ (1 .. First_Switches.Last + Last_Switches.Last);
Arg_Num : Natural := 0;
begin
@@ -1742,47 +1208,27 @@ begin
The_Args (Arg_Num) := Last_Switches.Table (J);
end loop;
- for J in 1 .. Carg_Switches.Last loop
- Arg_Num := Arg_Num + 1;
- The_Args (Arg_Num) := Carg_Switches.Table (J);
- end loop;
-
- for J in 1 .. Rules_Switches.Last loop
- Arg_Num := Arg_Num + 1;
- The_Args (Arg_Num) := Rules_Switches.Table (J);
- end loop;
-
if Verbose_Mode then
- Output.Write_Str (Exec_Path.all);
+ Put (Exec_Path.all);
for Arg in The_Args'Range loop
- Output.Write_Char (' ');
- Output.Write_Str (The_Args (Arg).all);
+ Put (" " & The_Args (Arg).all);
end loop;
- Output.Write_Eol;
+ New_Line;
end if;
- My_Exit_Status :=
- Exit_Status (Spawn (Exec_Path.all, The_Args));
- raise Normal_Exit;
+ My_Exit_Status := Exit_Status (Spawn (Exec_Path.all, The_Args));
+
+ if not Keep_Temporary_Files then
+ Delete_All_Temp_Files (Project_Tree.Shared);
+ end if;
+
+ Set_Exit_Status (My_Exit_Status);
end;
end;
exception
when Error_Exit =>
- if not Keep_Temporary_Files then
- Prj.Delete_All_Temp_Files (Project_Tree.Shared);
- Delete_Temp_Config_Files;
- end if;
-
Set_Exit_Status (Failure);
-
- when Normal_Exit =>
- if not Keep_Temporary_Files then
- Prj.Delete_All_Temp_Files (Project_Tree.Shared);
- Delete_Temp_Config_Files;
- end if;
-
- Set_Exit_Status (My_Exit_Status);
end GNATCmd;
diff --git a/gcc/ada/gnatdll.adb b/gcc/ada/gnatdll.adb
index 426c00f58b..94b39b8cc7 100644
--- a/gcc/ada/gnatdll.adb
+++ b/gcc/ada/gnatdll.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -271,7 +271,6 @@ procedure Gnatdll is
loop
case Getopt ("g h v q k a? b: d: e: l: n m I:") is
-
when ASCII.NUL =>
exit;
@@ -305,11 +304,9 @@ procedure Gnatdll is
end if;
when 'k' =>
-
MDLL.Kill_Suffix := True;
when 'a' =>
-
if Parameter = "" then
-- Default address for a relocatable dynamic library.
@@ -324,13 +321,10 @@ procedure Gnatdll is
Must_Build_Relocatable := False;
when 'b' =>
-
DLL_Address := To_Unbounded_String (Parameter);
-
Must_Build_Relocatable := True;
when 'e' =>
-
Def_Filename := To_Unbounded_String (Parameter);
when 'd' =>
@@ -347,11 +341,9 @@ procedure Gnatdll is
Build_Mode := Dynamic_Lib;
when 'm' =>
-
Gen_Map_File := True;
when 'n' =>
-
Build_Import := False;
when 'l' =>
@@ -398,14 +390,12 @@ procedure Gnatdll is
loop
case Getopt ("*") is
-
when ASCII.NUL =>
exit;
when others =>
Bopts (B) := new String'(Full_Switch);
B := B + 1;
-
end case;
end loop;
diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb
index 67b07b23e3..073c2c9531 100644
--- a/gcc/ada/gnatlink.adb
+++ b/gcc/ada/gnatlink.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -154,6 +154,8 @@ procedure Gnatlink is
Base_Command_Name : String_Access;
+ Target_Debuggable_Suffix : String_Access;
+
Tname : Temp_File_Name;
Tname_FD : File_Descriptor := Invalid_FD;
-- Temporary file used by linker to pass list of object files on
@@ -1646,12 +1648,14 @@ begin
Write_Header;
+ Target_Debuggable_Suffix := Get_Target_Debuggable_Suffix;
+
-- If no output name specified, then use the base name of .ali file name
if Output_File_Name = null then
Output_File_Name :=
new String'(Base_Name (Ali_File_Name.all)
- & Get_Target_Debuggable_Suffix.all);
+ & Target_Debuggable_Suffix.all);
end if;
Linker_Options.Increment_Last;
@@ -1680,10 +1684,10 @@ begin
-- Special warnings for worrisome file names on windows
- -- Windows-7 will not allow an executable file whose name contains any
- -- of the substrings "install", "setup", or "update" to load without
- -- special administration privileges. This rather incredible behavior
- -- is Microsoft's idea of a useful security precaution.
+ -- Recent versions of Windows by default cause privilege escalation if an
+ -- executable file name contains substrings "install", "setup", "update"
+ -- or "patch". A console application will typically fail to load as a
+ -- result, so we should warn the user.
Bad_File_Names_On_Windows : declare
FN : String := Output_File_Name.all;
@@ -1696,13 +1700,10 @@ begin
for J in 1 .. FN'Length - (S'Length - 1) loop
if FN (J .. J + (S'Length - 1)) = S then
Error_Msg
- ("warning: possible problem with executable name """
- & Output_File_Name.all & '"');
- Error_Msg
- ("file name contains substring """ & S & '"');
+ ("warning: executable file name """ & Output_File_Name.all
+ & """ contains substring """ & S & '"');
Error_Msg
- ("admin privileges may be required on Windows 7 "
- & "to load this file");
+ ("admin privileges may be required to run this file");
end if;
end loop;
end Check_File_Name;
@@ -1714,15 +1715,13 @@ begin
FN (J) := Csets.Fold_Lower (FN (J));
end loop;
- -- For now we detect windows by an output executable name ending with
- -- the suffix .exe.
+ -- For now we detect Windows by its executable suffix of .exe
- if FN'Length > 5
- and then FN (FN'Last - 3 .. FN'Last) = ".exe"
- then
+ if Target_Debuggable_Suffix.all = ".exe" then
Check_File_Name ("install");
Check_File_Name ("setup");
Check_File_Name ("update");
+ Check_File_Name ("patch");
end if;
end Bad_File_Names_On_Windows;
@@ -1869,25 +1868,6 @@ begin
Stack_Op : Boolean := False;
begin
- if AAMP_On_Target then
-
- -- Remove extraneous flags not relevant for AAMP
-
- for J in reverse Linker_Options.First .. Linker_Options.Last loop
- if Linker_Options.Table (J)'Length = 0
- or else Linker_Options.Table (J) (1 .. 3) = "-Wl"
- or else Linker_Options.Table (J) (1 .. 3) = "-sh"
- or else Linker_Options.Table (J) (1 .. 2) = "-O"
- or else Linker_Options.Table (J) (1 .. 2) = "-g"
- then
- Linker_Options.Table (J .. Linker_Options.Last - 1) :=
- Linker_Options.Table (J + 1 .. Linker_Options.Last);
- Linker_Options.Decrement_Last;
- Num_Args := Num_Args - 1;
- end if;
- end loop;
- end if;
-
-- Remove duplicate stack size setting from the Linker_Options table.
-- The stack setting option "-Xlinker --stack=R,C" can be found
-- in one line when set by a pragma Linker_Options or in two lines
diff --git a/gcc/ada/gnatname.adb b/gcc/ada/gnatname.adb
index a01bbb20ee..1030fde32a 100644
--- a/gcc/ada/gnatname.adb
+++ b/gcc/ada/gnatname.adb
@@ -660,8 +660,8 @@ begin
if Create_Project then
Write_Line
- ("warning: gnatname -P is obsolete and will not be available in the "
- & "next release; use gprname instead");
+ ("warning: gnatname -P is obsolete and will not be available in the" &
+ " next release; use gprname instead");
end if;
-- If no Ada or foreign pattern was specified, print the usage and return
diff --git a/gcc/ada/gnatvsn.ads b/gcc/ada/gnatvsn.ads
index 946c140be5..561ec445e1 100644
--- a/gcc/ada/gnatvsn.ads
+++ b/gcc/ada/gnatvsn.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -38,14 +38,14 @@ package Gnatvsn is
-- Static string identifying this version, that can be used as an argument
-- to e.g. pragma Ident.
- Library_Version : constant String := "6";
+ Library_Version : constant String := "7";
-- Library version. It needs to be updated whenever the major or
-- minor version number is changed.
--
-- Note: Makefile.in uses the library version string to construct the
-- soname value.
- Current_Year : constant String := "2016";
+ Current_Year : constant String := "2017";
-- Used in printing copyright messages
Verbose_Library_Version : constant String := "GNAT Lib v" & Library_Version;
diff --git a/gcc/ada/gprep.adb b/gcc/ada/gprep.adb
index c4bf8e91a5..cc7e24301b 100644
--- a/gcc/ada/gprep.adb
+++ b/gcc/ada/gprep.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -253,7 +253,15 @@ package body GPrep is
Scanner.Initialize_Scanner (Deffile);
- Prep.Parse_Def_File;
+ -- Parse the definition file without "replace in comments"
+
+ declare
+ Replace : constant Boolean := Opt.Replace_In_Comments;
+ begin
+ Opt.Replace_In_Comments := False;
+ Prep.Parse_Def_File;
+ Opt.Replace_In_Comments := Replace;
+ end;
end;
end if;
@@ -729,7 +737,6 @@ package body GPrep is
Switch := GNAT.Command_Line.Getopt ("D: a b c C r s T u v");
case Switch is
-
when ASCII.NUL =>
exit;
diff --git a/gcc/ada/gsocket.h b/gcc/ada/gsocket.h
index 31a3ccff18..b343b0942c 100644
--- a/gcc/ada/gsocket.h
+++ b/gcc/ada/gsocket.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 2004-2015, Free Software Foundation, Inc. *
+ * Copyright (C) 2004-2016, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -29,7 +29,7 @@
* *
****************************************************************************/
-#if defined(VTHREADS) || defined(__PikeOS__)
+#if defined(VTHREADS) || defined(__PikeOS__) || defined(__DJGPP__)
/* Sockets not supported on these platforms. */
#undef HAVE_SOCKETS
@@ -201,6 +201,7 @@
#include <netinet/tcp.h>
#include <sys/ioctl.h>
#include <netdb.h>
+#include <unistd.h>
#endif
#ifdef __ANDROID__
diff --git a/gcc/ada/i-cobol.adb b/gcc/ada/i-cobol.adb
index ed5b0ab6a3..bd331b48c9 100644
--- a/gcc/ada/i-cobol.adb
+++ b/gcc/ada/i-cobol.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -543,7 +543,6 @@ package body Interfaces.COBOL is
Val := abs Val;
Convert (1, Length);
Embed_Sign (Length);
-
end case;
return Result;
diff --git a/gcc/ada/i-cobol.ads b/gcc/ada/i-cobol.ads
index ad885e4a91..9edcc0194d 100644
--- a/gcc/ada/i-cobol.ads
+++ b/gcc/ada/i-cobol.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (ASCII Version) --
-- --
--- Copyright (C) 1993-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1993-2015, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -439,8 +439,8 @@ package Interfaces.COBOL is
function To_Decimal (Item : Binary) return Num;
function To_Decimal (Item : Long_Binary) return Num;
- function To_Binary (Item : Num) return Binary;
- function To_Long_Binary (Item : Num) return Long_Binary;
+ function To_Binary (Item : Num) return Binary;
+ function To_Long_Binary (Item : Num) return Long_Binary;
private
pragma Inline (Length);
diff --git a/gcc/ada/a-intsig.adb b/gcc/ada/i-vxinco.adb
index 9470128b6b..6418af13cd 100644
--- a/gcc/ada/a-intsig.adb
+++ b/gcc/ada/i-vxinco.adb
@@ -2,11 +2,11 @@
-- --
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
--- A D A . I N T E R R U P T S . S I G N A L --
+-- I N T E R F A C E S . V X W O R K S . I N T _ C O N N E C T I O N --
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 2016, AdaCore
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,18 +29,20 @@
-- --
------------------------------------------------------------------------------
-with System.Interrupt_Management.Operations;
+package body Interfaces.VxWorks.Int_Connection is
-package body Ada.Interrupts.Signal is
+ Connection_Routine : Interrupt_Connector;
+ pragma Import (C, Connection_Routine, "__gnat_user_int_connect");
+ -- Declared in System.Interrupts. Defaults to the standard OS connector in
+ -- System.OS_Interface (or Interfaces.VxWorks for restricted runtimes).
- ------------------------
- -- Generate_Interrupt --
- ------------------------
+ -------------
+ -- Connect --
+ -------------
- procedure Generate_Interrupt (Interrupt : Interrupt_ID) is
+ procedure Connect (Connector : Interrupt_Connector) is
begin
- System.Interrupt_Management.Operations.Interrupt_Self_Process
- (System.Interrupt_Management.Interrupt_ID (Interrupt));
- end Generate_Interrupt;
+ Connection_Routine := Connector;
+ end Connect;
-end Ada.Interrupts.Signal;
+end Interfaces.VxWorks.Int_Connection;
diff --git a/gcc/ada/a-intsig.ads b/gcc/ada/i-vxinco.ads
index 9d98f9de37..04ae6cfe0a 100644
--- a/gcc/ada/a-intsig.ads
+++ b/gcc/ada/i-vxinco.ads
@@ -2,11 +2,11 @@
-- --
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
-- --
--- A D A . I N T E R R U P T S . S I G N A L --
+-- I N T E R F A C E S . V X W O R K S . I N T _ C O N N E C T I O N --
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 2016, AdaCore
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,14 +29,28 @@
-- --
------------------------------------------------------------------------------
--- This package encapsulates the procedures for generating interrupts
--- by user programs and avoids importing low level children of System
--- (e.g. System.Interrupt_Management.Operations), or defining an interface
--- to complex system calls.
+-- This package provides users with the ability to use a custom routine for
+-- connecting hardware interrupts for VxWorks environments that support the
+-- capability to handle them. The custom routine must have the same profile
+-- as the VxWorks intConnect() routine.
-package Ada.Interrupts.Signal is
+with System;
- procedure Generate_Interrupt (Interrupt : Interrupt_ID);
- -- Generate interrupt at the process level
+package Interfaces.VxWorks.Int_Connection is
-end Ada.Interrupts.Signal;
+ type Interrupt_Connector is access function
+ (Vector : Interrupt_Vector;
+ Handler : VOIDFUNCPTR;
+ Parameter : System.Address := System.Null_Address) return STATUS;
+ pragma Convention (C, Interrupt_Connector);
+ -- Convention C for compatibility with intConnect(). User alternatives are
+ -- likely to be imports of C routines anyway.
+
+ procedure Connect (Connector : Interrupt_Connector);
+ -- Set user-defined interrupt connection routine. Must precede calls to
+ -- Ada.Interrupts.Attach_Handler, or the default connector from
+ -- System.OS_Interface (or Interfaces.VxWorks for Ravenscar Cert) will be
+ -- used. Can be called multiple times to change the connection routine for
+ -- subsequent calls to Attach_Handler.
+
+end Interfaces.VxWorks.Int_Connection;
diff --git a/gcc/ada/impunit.adb b/gcc/ada/impunit.adb
index 45b937944b..e1cce65742 100644
--- a/gcc/ada/impunit.adb
+++ b/gcc/ada/impunit.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -351,6 +351,7 @@ package body Impunit is
("i-java ", F), -- Interfaces.Java
("i-javjni", F), -- Interfaces.Java.JNI
("i-pacdec", F), -- Interfaces.Packed_Decimal
+ ("i-vxinco", F), -- Interfaces.VxWorks.Int_Connection
("i-vxwoio", F), -- Interfaces.VxWorks.IO
("i-vxwork", F), -- Interfaces.VxWorks
diff --git a/gcc/ada/init-vxsim.c b/gcc/ada/init-vxsim.c
deleted file mode 100644
index 9466dbc791..0000000000
--- a/gcc/ada/init-vxsim.c
+++ /dev/null
@@ -1,62 +0,0 @@
-/****************************************************************************
- * *
- * GNAT COMPILER COMPONENTS *
- * *
- * I N I T - V X S I M *
- * *
- * C Implementation File *
- * *
- * Copyright (C) 1992-2015, Free Software Foundation, Inc. *
- * *
- * GNAT is free software; you can redistribute it and/or modify it under *
- * terms of the GNU General Public License as published by the Free Soft- *
- * ware Foundation; either version 3, or (at your option) any later ver- *
- * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
- * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
- * or FITNESS FOR A PARTICULAR PURPOSE. *
- * *
- * As a special exception under Section 7 of GPL version 3, you are granted *
- * additional permissions described in the GCC Runtime Library Exception, *
- * version 3.1, as published by the Free Software Foundation. *
- * *
- * You should have received a copy of the GNU General Public License and *
- * a copy of the GCC Runtime Library Exception along with this program; *
- * see the files COPYING3 and COPYING.RUNTIME respectively. If not, see *
- * <http://www.gnu.org/licenses/>. *
- * *
- * GNAT was originally developed by the GNAT team at New York University. *
- * Extensive contributions were provided by Ada Core Technologies Inc. *
- * *
- ****************************************************************************/
-
-/* This file is an addition to init.c that must be compiled with the CPU
- specified for running under vxsim for x86-vxworks6, as the signal context
- structure is different for vxsim vs. real hardware. */
-
-#undef CPU
-#define CPU __VXSIM_CPU__
-
-#include "vxWorks.h"
-#include "tconfig.h"
-
-#include <signal.h>
-#include <taskLib.h>
-
-#ifndef __RTP__
-#include <intLib.h>
-#include <iv.h>
-#endif
-
-extern void
-__gnat_map_signal (int sig, siginfo_t *si ATTRIBUTE_UNUSED,
- void *sc ATTRIBUTE_UNUSED);
-
-/* Process the vxsim signal context. */
-void
-__gnat_vxsim_error_handler (int sig, siginfo_t *si, void *sc)
-{
- #include "sigtramp.h"
-
- __gnat_sigtramp_vxsim (sig, (void *)si, (void *)sc,
- (__sigtramphandler_t *)&__gnat_map_signal);
-}
diff --git a/gcc/ada/init.c b/gcc/ada/init.c
index 2f01c8dce7..e180f3cfb0 100644
--- a/gcc/ada/init.c
+++ b/gcc/ada/init.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2015, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2016, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -503,6 +503,15 @@ __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext)
#elif defined (__ARMEL__)
/* ARM Bump has to be an even number because of odd/even architecture. */
mcontext->arm_pc+=2;
+#ifdef __thumb2__
+#define CPSR_THUMB_BIT 5
+ /* For thumb, the return address much have the low order bit set, otherwise
+ the unwinder will reset to "arm" mode upon return. As long as the
+ compilation unit containing the landing pad is compiled with the same
+ mode (arm vs thumb) as the signaling compilation unit, this works. */
+ if (mcontext->arm_cpsr & (1<<CPSR_THUMB_BIT))
+ mcontext->arm_pc+=1;
+#endif
#endif
}
@@ -1705,17 +1714,22 @@ __gnat_install_handler (void)
#include <signal.h>
#include <taskLib.h>
-#if defined (__i386__) && !defined (VTHREADS)
+#if (defined (__i386__) || defined (__x86_64__)) && !defined (VTHREADS)
#include <sysLib.h>
#endif
+#include "sigtramp.h"
+
#ifndef __RTP__
#include <intLib.h>
#include <iv.h>
#endif
-#if defined (ARMEL) && (_WRS_VXWORKS_MAJOR == 6) && !defined(__RTP__)
+#if ((defined (ARMEL) && (_WRS_VXWORKS_MAJOR == 6)) || defined (__x86_64__)) && !defined(__RTP__)
+#define VXWORKS_FORCE_GUARD_PAGE 1
#include <vmLib.h>
+extern size_t vxIntStackOverflowSize;
+#define INT_OVERFLOW_SIZE vxIntStackOverflowSize
#endif
#ifdef VTHREADS
@@ -1726,13 +1740,13 @@ __gnat_install_handler (void)
/* Directly vectored Interrupt routines are not supported when using RTPs. */
-extern int __gnat_inum_to_ivec (int);
+extern void * __gnat_inum_to_ivec (int);
/* This is needed by the GNAT run time to handle Vxworks interrupts. */
-int
+void *
__gnat_inum_to_ivec (int num)
{
- return (int) ((long) INUM_TO_IVEC ((long) num));
+ return (void *) INUM_TO_IVEC (num);
}
#endif
@@ -1750,6 +1764,51 @@ getpid (void)
}
#endif
+/* When stack checking is performed by probing a guard page on the stack,
+ sometimes this guard page is not properly reset on VxWorks. We need to
+ manually reset it in this case.
+ This function returns TRUE in case the guard page was hit by the
+ signal. */
+static int
+__gnat_reset_guard_page (int sig)
+{
+ /* On ARM VxWorks 6.x and x86_64 VxWorks 7, the guard page is left un-armed
+ by the kernel after being violated, so subsequent violations aren't
+ detected.
+ So we retrieve the address of the guard page from the TCB and compare it
+ with the page that is violated and re-arm that page if there's a match. */
+#if defined (VXWORKS_FORCE_GUARD_PAGE)
+
+ /* Ignore signals that are not stack overflow signals */
+ if (sig != SIGSEGV && sig != SIGBUS && sig != SIGILL) return FALSE;
+
+ /* If the target does not support guard pages, INT_OVERFLOW_SIZE will be 0 */
+ if (INT_OVERFLOW_SIZE == 0) return FALSE;
+
+ TASK_ID tid = taskIdSelf ();
+ WIND_TCB *pTcb = taskTcb (tid);
+ VIRT_ADDR guardPage = (VIRT_ADDR) pTcb->pStackEnd - INT_OVERFLOW_SIZE;
+ UINT stateMask = VM_STATE_MASK_VALID;
+ UINT guardState = VM_STATE_VALID_NOT;
+
+#if (_WRS_VXWORKS_MAJOR >= 7)
+ stateMask |= MMU_ATTR_SPL_MSK;
+ guardState |= MMU_ATTR_NO_BLOCK;
+#endif
+
+ UINT nState;
+ vmStateGet (NULL, guardPage, &nState);
+ if ((nState & VM_STATE_MASK_VALID) != VM_STATE_VALID_NOT)
+ {
+ /* If the guard page has a valid state, we need to reset to
+ invalid state here */
+ vmStateSet (NULL, guardPage, INT_OVERFLOW_SIZE, stateMask, guardState);
+ return TRUE;
+ }
+#endif /* VXWORKS_FORCE_GUARD_PAGE */
+ return FALSE;
+}
+
/* VxWorks 653 vThreads expects the field excCnt to be zeroed when a signal is.
handled. The VxWorks version of longjmp does this; GCC's builtin_longjmp
doesn't. */
@@ -1766,8 +1825,9 @@ __gnat_clear_exception_count (void)
/* Handle different SIGnal to exception mappings in different VxWorks
versions. */
void
-__gnat_map_signal (int sig, siginfo_t *si ATTRIBUTE_UNUSED,
- void *sc ATTRIBUTE_UNUSED)
+__gnat_map_signal (int sig,
+ siginfo_t *si ATTRIBUTE_UNUSED,
+ void *sc ATTRIBUTE_UNUSED)
{
struct Exception_Data *exception;
const char *msg;
@@ -1854,61 +1914,29 @@ __gnat_map_signal (int sig, siginfo_t *si ATTRIBUTE_UNUSED,
msg = "unhandled signal";
}
- /* On ARM VxWorks 6.x, the guard page is left un-armed by the kernel
- after being violated, so subsequent violations aren't detected.
- so we retrieve the address of the guard page from the TCB and compare it
- with the page that is violated (pREG 12 in the context) and re-arm that
- page if there's a match. Additionally we're are assured this is a
- genuine stack overflow condition and and set the message and exception
- to that effect. */
-#if defined (ARMEL) && (_WRS_VXWORKS_MAJOR == 6) && !defined(__RTP__)
-
- /* We re-arm the guard page by marking it invalid */
-
-#define PAGE_SIZE 4096
-#define REG_IP 12
-
- if (sig == SIGSEGV || sig == SIGBUS || sig == SIGILL)
+ if (__gnat_reset_guard_page (sig))
{
- TASK_ID tid = taskIdSelf ();
- WIND_TCB *pTcb = taskTcb (tid);
- unsigned long violated_page
- = ((struct sigcontext *) sc)->sc_pregs->r[REG_IP] & ~(PAGE_SIZE - 1);
+ /* Set the exception message: we know for sure that we have a
+ stack overflow here */
+ exception = &storage_error;
- if ((unsigned long) (pTcb->pStackEnd - PAGE_SIZE) == violated_page)
+ switch (sig)
{
- vmStateSet (NULL, violated_page,
- PAGE_SIZE, VM_STATE_MASK_VALID, VM_STATE_VALID_NOT);
- exception = &storage_error;
-
- switch (sig)
- {
- case SIGSEGV:
- msg = "SIGSEGV: stack overflow";
- break;
- case SIGBUS:
- msg = "SIGBUS: stack overflow";
- break;
- case SIGILL:
- msg = "SIGILL: stack overflow";
- break;
- }
- }
+ case SIGSEGV:
+ msg = "SIGSEGV: stack overflow";
+ break;
+ case SIGBUS:
+ msg = "SIGBUS: stack overflow";
+ break;
+ case SIGILL:
+ msg = "SIGILL: stack overflow";
+ break;
+ }
}
-#endif /* defined (ARMEL) && (_WRS_VXWORKS_MAJOR == 6) && !defined(__RTP__) */
-
__gnat_clear_exception_count ();
Raise_From_Signal_Handler (exception, msg);
}
-#if defined (__i386__) && !defined (VTHREADS) && _WRS_VXWORKS_MAJOR < 7
-
-extern void
-__gnat_vxsim_error_handler (int sig, siginfo_t *si, void *sc);
-
-static int is_vxsim = 0;
-#endif
-
#if defined (ARMEL) && (_WRS_VXWORKS_MAJOR >= 7)
/* ARM-vx7 case with arm unwinding exceptions */
@@ -1956,14 +1984,17 @@ __gnat_error_handler (int sig, siginfo_t *si, void *sc)
when they contain SPE instructions, we need to set it back before doing
anything else.
This mechanism is only need in kernel mode. */
-#if !(defined (__RTP__) || defined (CERT)) && ((CPU == PPCE500V2) || (CPU == PPC85XX))
+#if !(defined (__RTP__) || defined (VTHREADS)) && ((CPU == PPCE500V2) || (CPU == PPC85XX))
register unsigned msr;
/* Read the MSR value */
asm volatile ("mfmsr %0" : "=r" (msr));
- /* Force the SPE bit */
- msr |= 0x02000000;
- /* Store to MSR */
- asm volatile ("mtmsr %0" : : "r" (msr));
+ /* Force the SPE bit if not set. */
+ if ((msr & 0x02000000) == 0)
+ {
+ msr |= 0x02000000;
+ /* Store to MSR */
+ asm volatile ("mtmsr %0" : : "r" (msr));
+ }
#endif
/* VxWorks will always mask out the signal during the signal handler and
@@ -1989,19 +2020,8 @@ __gnat_error_handler (int sig, siginfo_t *si, void *sc)
__gnat_adjust_context_for_raise (sig, sc);
#endif
-#if defined (__i386__) && !defined (VTHREADS) && (__WRS_VXWORKS_MAJOR < 7)
- /* On x86, the vxsim signal context is subtly different and is processeed
- by a handler compiled especially for vxsim.
- Vxsim is not supported anymore on our vxworks-7 port. */
-
- if (is_vxsim)
- __gnat_vxsim_error_handler (sig, si, sc);
-#endif
-
-# include "sigtramp.h"
-
__gnat_sigtramp (sig, (void *)si, (void *)sc,
- (__sigtramphandler_t *)&__gnat_map_signal);
+ (__sigtramphandler_t *)&__gnat_map_signal);
#else
__gnat_map_signal (sig, si, sc);
@@ -2031,7 +2051,6 @@ void
__gnat_install_handler (void)
{
struct sigaction act;
- char *model ATTRIBUTE_UNUSED;
/* Setup signal handler to map synchronous signals to appropriate
exceptions. Make sure that the handler isn't interrupted by another
@@ -2082,13 +2101,17 @@ __gnat_install_handler (void)
trap_0_entry->inst_fourth = 0xa1480000;
#endif
-#if defined (__i386__) && !defined (VTHREADS) && _WRS_VXWORKS_MAJOR != 7
+#ifdef __HANDLE_VXSIM_SC
/* By experiment, found that sysModel () returns the following string
prefix for vxsim when running on Linux and Windows. */
- model = sysModel ();
- if ((strncmp (model, "Linux", 5) == 0)
- || (strncmp (model, "Windows", 7) == 0))
- is_vxsim = 1;
+ {
+ char *model = sysModel ();
+ if ((strncmp (model, "Linux", 5) == 0)
+ || (strncmp (model, "Windows", 7) == 0)
+ || (strncmp (model, "SIMLINUX", 8) == 0) /* vx7 */
+ || (strncmp (model, "SIMNT", 5) == 0)) /* ditto */
+ __gnat_set_is_vxsim (TRUE);
+ }
#endif
__gnat_handler_installed = 1;
@@ -2115,9 +2138,9 @@ __gnat_init_float (void)
#endif
#endif
-#if (defined (__i386__) && !defined (VTHREADS))
+#if (defined (__i386__) || defined (__x86_64__)) && !defined (VTHREADS)
/* This is used to properly initialize the FPU on an x86 for each
- process thread. Is this needed for x86_64 ??? */
+ process thread. */
asm ("finit");
#endif
@@ -2493,6 +2516,14 @@ __gnat_install_handler (void)
__gnat_handler_installed = 1;
}
+#elif defined (__DJGPP__)
+
+void
+__gnat_install_handler ()
+{
+ __gnat_handler_installed = 1;
+}
+
#elif defined(__ANDROID__)
/*******************/
diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb
index bc7bc32416..78d921a75d 100644
--- a/gcc/ada/inline.adb
+++ b/gcc/ada/inline.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -390,6 +390,40 @@ package body Inline is
return;
end if;
+ -- Find out whether the call must be inlined. Unless the result is
+ -- Dont_Inline, Must_Inline also creates an edge for the call in the
+ -- callgraph; however, it will not be activated until after Is_Called
+ -- is set on the subprogram.
+
+ Level := Must_Inline;
+
+ if Level = Dont_Inline then
+ return;
+ end if;
+
+ -- If the call was generated by the compiler and is to a subprogram in
+ -- a run-time unit, we need to suppress debugging information for it,
+ -- so that the code that is eventually inlined will not affect the
+ -- debugging of the program. We do not do it if the call comes from
+ -- source because, even if the call is inlined, the user may expect it
+ -- to be present in the debugging information.
+
+ if not Comes_From_Source (N)
+ and then In_Extended_Main_Source_Unit (N)
+ and then
+ Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (E)))
+ then
+ Set_Needs_Debug_Info (E, False);
+ end if;
+
+ -- If the subprogram is an expression function, then there is no need to
+ -- load any package body since the body of the function is in the spec.
+
+ if Is_Expression_Function (E) then
+ Set_Is_Called (E);
+ return;
+ end if;
+
-- Find unit containing E, and add to list of inlined bodies if needed.
-- If the body is already present, no need to load any other unit. This
-- is the case for an initialization procedure, which appears in the
@@ -403,77 +437,49 @@ package body Inline is
-- no enclosing package to retrieve. In this case, it is the body of
-- the function that will have to be loaded.
- Level := Must_Inline;
-
- if Level /= Dont_Inline then
- declare
- Pack : constant Entity_Id := Get_Code_Unit_Entity (E);
-
- begin
- -- Ensure that Analyze_Inlined_Bodies will be invoked after
- -- completing the analysis of the current unit.
+ declare
+ Pack : constant Entity_Id := Get_Code_Unit_Entity (E);
- Inline_Processing_Required := True;
+ begin
+ if Pack = E then
+ Set_Is_Called (E);
+ Inlined_Bodies.Increment_Last;
+ Inlined_Bodies.Table (Inlined_Bodies.Last) := E;
- if Pack = E then
+ elsif Ekind (Pack) = E_Package then
+ Set_Is_Called (E);
- -- Library-level inlined function. Add function itself to
- -- list of needed units.
+ if Is_Generic_Instance (Pack) then
+ null;
- Set_Is_Called (E);
+ -- Do not inline the package if the subprogram is an init proc
+ -- or other internally generated subprogram, because in that
+ -- case the subprogram body appears in the same unit that
+ -- declares the type, and that body is visible to the back end.
+ -- Do not inline it either if it is in the main unit.
+ -- Extend the -gnatn2 processing to -gnatn1 for Inline_Always
+ -- calls if the back-end takes care of inlining the call.
+ -- Note that Level in Inline_Package | Inline_Call here.
+
+ elsif ((Level = Inline_Call
+ and then Has_Pragma_Inline_Always (E)
+ and then Back_End_Inlining)
+ or else Level = Inline_Package)
+ and then not Is_Inlined (Pack)
+ and then not Is_Internal (E)
+ and then not In_Main_Unit_Or_Subunit (Pack)
+ then
+ Set_Is_Inlined (Pack);
Inlined_Bodies.Increment_Last;
- Inlined_Bodies.Table (Inlined_Bodies.Last) := E;
-
- elsif Ekind (Pack) = E_Package then
- Set_Is_Called (E);
-
- if Is_Generic_Instance (Pack) then
- null;
-
- -- Do not inline the package if the subprogram is an init proc
- -- or other internally generated subprogram, because in that
- -- case the subprogram body appears in the same unit that
- -- declares the type, and that body is visible to the back end.
- -- Do not inline it either if it is in the main unit.
-
- elsif Level = Inline_Package
- and then not Is_Inlined (Pack)
- and then not Is_Internal (E)
- and then not In_Main_Unit_Or_Subunit (Pack)
- then
- Set_Is_Inlined (Pack);
- Inlined_Bodies.Increment_Last;
- Inlined_Bodies.Table (Inlined_Bodies.Last) := Pack;
-
- -- Extend the -gnatn2 processing to -gnatn1 for Inline_Always
- -- calls if the back-end takes care of inlining the call.
-
- elsif Level = Inline_Call
- and then Has_Pragma_Inline_Always (E)
- and then Back_End_Inlining
- then
- Set_Is_Inlined (Pack);
- Inlined_Bodies.Increment_Last;
- Inlined_Bodies.Table (Inlined_Bodies.Last) := Pack;
- end if;
+ Inlined_Bodies.Table (Inlined_Bodies.Last) := Pack;
end if;
+ end if;
- -- If the call was generated by the compiler and is to a function
- -- in a run-time unit, we need to suppress debugging information
- -- for it, so that the code that is eventually inlined will not
- -- affect debugging of the program. We do not do it if the call
- -- comes from source because, even if the call is inlined, the
- -- user may expect it to be present in the debugging information.
-
- if not Comes_From_Source (N)
- and then In_Extended_Main_Source_Unit (N)
- and then
- Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (E)))
- then
- Set_Needs_Debug_Info (E, False);
- end if;
- end;
- end if;
+ -- Ensure that Analyze_Inlined_Bodies will be invoked after
+ -- completing the analysis of the current unit.
+
+ Inline_Processing_Required := True;
+ end;
end Add_Inlined_Body;
----------------------------
@@ -952,6 +958,7 @@ package body Inline is
-----------------------------------------
function Has_Single_Return_In_GNATprove_Mode return Boolean is
+ Body_To_Inline : constant Node_Id := N;
Last_Statement : Node_Id := Empty;
function Check_Return (N : Node_Id) return Traverse_Result;
@@ -964,18 +971,29 @@ package body Inline is
function Check_Return (N : Node_Id) return Traverse_Result is
begin
- if Nkind_In (N, N_Simple_Return_Statement,
- N_Extended_Return_Statement)
- then
- if N = Last_Statement then
- return OK;
- else
- return Abandon;
- end if;
+ case Nkind (N) is
+ when N_Extended_Return_Statement
+ | N_Simple_Return_Statement
+ =>
+ if N = Last_Statement then
+ return OK;
+ else
+ return Abandon;
+ end if;
- else
- return OK;
- end if;
+ -- Skip locally declared subprogram bodies inside the body to
+ -- inline, as the return statements inside those do not count.
+
+ when N_Subprogram_Body =>
+ if N = Body_To_Inline then
+ return OK;
+ else
+ return Skip;
+ end if;
+
+ when others =>
+ return OK;
+ end case;
end Check_Return;
function Check_All_Returns is new Traverse_Func (Check_Return);
@@ -1143,7 +1161,7 @@ package body Inline is
Make_Defining_Identifier (Sloc (N), Name_uParent));
Set_Corresponding_Spec (Original_Body, Empty);
- -- Remove all aspects/pragmas that have no meaining in an inlined body
+ -- Remove all aspects/pragmas that have no meaning in an inlined body
Remove_Aspects_And_Pragmas (Original_Body);
@@ -1198,138 +1216,36 @@ package body Inline is
Set_Is_Inlined (Spec_Id);
end Build_Body_To_Inline;
- -------------------
- -- Cannot_Inline --
- -------------------
+ -------------------------------------------
+ -- Call_Can_Be_Inlined_In_GNATprove_Mode --
+ -------------------------------------------
- procedure Cannot_Inline
- (Msg : String;
- N : Node_Id;
- Subp : Entity_Id;
- Is_Serious : Boolean := False)
+ function Call_Can_Be_Inlined_In_GNATprove_Mode
+ (N : Node_Id;
+ Subp : Entity_Id) return Boolean
is
- begin
- -- In GNATprove mode, inlining is the technical means by which the
- -- higher-level goal of contextual analysis is reached, so issue
- -- messages about failure to apply contextual analysis to a
- -- subprogram, rather than failure to inline it.
-
- if GNATprove_Mode
- and then Msg (Msg'First .. Msg'First + 12) = "cannot inline"
- then
- declare
- Len1 : constant Positive :=
- String (String'("cannot inline"))'Length;
- Len2 : constant Positive :=
- String (String'("info: no contextual analysis of"))'Length;
-
- New_Msg : String (1 .. Msg'Length + Len2 - Len1);
-
- begin
- New_Msg (1 .. Len2) := "info: no contextual analysis of";
- New_Msg (Len2 + 1 .. Msg'Length + Len2 - Len1) :=
- Msg (Msg'First + Len1 .. Msg'Last);
- Cannot_Inline (New_Msg, N, Subp, Is_Serious);
- return;
- end;
- end if;
-
- pragma Assert (Msg (Msg'Last) = '?');
+ F : Entity_Id;
+ A : Node_Id;
- -- Legacy front end inlining model
-
- if not Back_End_Inlining then
-
- -- Do not emit warning if this is a predefined unit which is not
- -- the main unit. With validity checks enabled, some predefined
- -- subprograms may contain nested subprograms and become ineligible
- -- for inlining.
-
- if Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Subp)))
- and then not In_Extended_Main_Source_Unit (Subp)
+ begin
+ F := First_Formal (Subp);
+ A := First_Actual (N);
+ while Present (F) loop
+ if Ekind (F) /= E_Out_Parameter
+ and then not Same_Type (Etype (F), Etype (A))
+ and then
+ (Is_By_Reference_Type (Etype (A))
+ or else Is_Limited_Type (Etype (A)))
then
- null;
-
- -- In GNATprove mode, issue a warning, and indicate that the
- -- subprogram is not always inlined by setting flag Is_Inlined_Always
- -- to False.
-
- elsif GNATprove_Mode then
- Set_Is_Inlined_Always (Subp, False);
- Error_Msg_NE (Msg & "p?", N, Subp);
-
- elsif Has_Pragma_Inline_Always (Subp) then
-
- -- Remove last character (question mark) to make this into an
- -- error, because the Inline_Always pragma cannot be obeyed.
-
- Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
-
- elsif Ineffective_Inline_Warnings then
- Error_Msg_NE (Msg & "p?", N, Subp);
+ return False;
end if;
- -- New semantics relying on back end inlining
-
- elsif Is_Serious then
-
- -- Remove last character (question mark) to make this into an error.
-
- Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
-
- -- In GNATprove mode, issue a warning, and indicate that the subprogram
- -- is not always inlined by setting flag Is_Inlined_Always to False.
-
- elsif GNATprove_Mode then
- Set_Is_Inlined_Always (Subp, False);
- Error_Msg_NE (Msg & "p?", N, Subp);
-
- else
-
- -- Do not emit warning if this is a predefined unit which is not
- -- the main unit. This behavior is currently provided for backward
- -- compatibility but it will be removed when we enforce the
- -- strictness of the new rules.
-
- if Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Subp)))
- and then not In_Extended_Main_Source_Unit (Subp)
- then
- null;
-
- elsif Has_Pragma_Inline_Always (Subp) then
-
- -- Emit a warning if this is a call to a runtime subprogram
- -- which is located inside a generic. Previously this call
- -- was silently skipped.
-
- if Is_Generic_Instance (Subp) then
- declare
- Gen_P : constant Entity_Id := Generic_Parent (Parent (Subp));
- begin
- if Is_Predefined_File_Name
- (Unit_File_Name (Get_Source_Unit (Gen_P)))
- then
- Set_Is_Inlined (Subp, False);
- Error_Msg_NE (Msg & "p?", N, Subp);
- return;
- end if;
- end;
- end if;
-
- -- Remove last character (question mark) to make this into an
- -- error, because the Inline_Always pragma cannot be obeyed.
-
- Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
-
- else
- Set_Is_Inlined (Subp, False);
+ Next_Formal (F);
+ Next_Actual (A);
+ end loop;
- if Ineffective_Inline_Warnings then
- Error_Msg_NE (Msg & "p?", N, Subp);
- end if;
- end if;
- end if;
- end Cannot_Inline;
+ return True;
+ end Call_Can_Be_Inlined_In_GNATprove_Mode;
--------------------------------------
-- Can_Be_Inlined_In_GNATprove_Mode --
@@ -1400,8 +1316,8 @@ package body Inline is
Formal : Entity_Id;
Formal_Typ : Entity_Id;
- -- Start of processing for
- -- Has_Formal_With_Discriminant_Dependent_Component
+ -- Start of processing for
+ -- Has_Formal_With_Discriminant_Dependent_Fields
begin
-- Inspect all parameters of the subprogram looking for a formal
@@ -1484,7 +1400,8 @@ package body Inline is
-- Local declarations
- Id : Entity_Id; -- Procedure or function entity for the subprogram
+ Id : Entity_Id;
+ -- Procedure or function entity for the subprogram
-- Start of processing for Can_Be_Inlined_In_GNATprove_Mode
@@ -1553,7 +1470,8 @@ package body Inline is
elsif Present (Spec_Id)
and then
(No (SPARK_Pragma (Spec_Id))
- or else Get_SPARK_Mode_From_Pragma (SPARK_Pragma (Spec_Id)) /= On)
+ or else
+ Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Spec_Id)) /= On)
then
return False;
@@ -1586,6 +1504,139 @@ package body Inline is
end if;
end Can_Be_Inlined_In_GNATprove_Mode;
+ -------------------
+ -- Cannot_Inline --
+ -------------------
+
+ procedure Cannot_Inline
+ (Msg : String;
+ N : Node_Id;
+ Subp : Entity_Id;
+ Is_Serious : Boolean := False)
+ is
+ begin
+ -- In GNATprove mode, inlining is the technical means by which the
+ -- higher-level goal of contextual analysis is reached, so issue
+ -- messages about failure to apply contextual analysis to a
+ -- subprogram, rather than failure to inline it.
+
+ if GNATprove_Mode
+ and then Msg (Msg'First .. Msg'First + 12) = "cannot inline"
+ then
+ declare
+ Len1 : constant Positive :=
+ String (String'("cannot inline"))'Length;
+ Len2 : constant Positive :=
+ String (String'("info: no contextual analysis of"))'Length;
+
+ New_Msg : String (1 .. Msg'Length + Len2 - Len1);
+
+ begin
+ New_Msg (1 .. Len2) := "info: no contextual analysis of";
+ New_Msg (Len2 + 1 .. Msg'Length + Len2 - Len1) :=
+ Msg (Msg'First + Len1 .. Msg'Last);
+ Cannot_Inline (New_Msg, N, Subp, Is_Serious);
+ return;
+ end;
+ end if;
+
+ pragma Assert (Msg (Msg'Last) = '?');
+
+ -- Legacy front end inlining model
+
+ if not Back_End_Inlining then
+
+ -- Do not emit warning if this is a predefined unit which is not
+ -- the main unit. With validity checks enabled, some predefined
+ -- subprograms may contain nested subprograms and become ineligible
+ -- for inlining.
+
+ if Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Subp)))
+ and then not In_Extended_Main_Source_Unit (Subp)
+ then
+ null;
+
+ -- In GNATprove mode, issue a warning, and indicate that the
+ -- subprogram is not always inlined by setting flag Is_Inlined_Always
+ -- to False.
+
+ elsif GNATprove_Mode then
+ Set_Is_Inlined_Always (Subp, False);
+ Error_Msg_NE (Msg & "p?", N, Subp);
+
+ elsif Has_Pragma_Inline_Always (Subp) then
+
+ -- Remove last character (question mark) to make this into an
+ -- error, because the Inline_Always pragma cannot be obeyed.
+
+ Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
+
+ elsif Ineffective_Inline_Warnings then
+ Error_Msg_NE (Msg & "p?", N, Subp);
+ end if;
+
+ -- New semantics relying on back end inlining
+
+ elsif Is_Serious then
+
+ -- Remove last character (question mark) to make this into an error.
+
+ Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
+
+ -- In GNATprove mode, issue a warning, and indicate that the subprogram
+ -- is not always inlined by setting flag Is_Inlined_Always to False.
+
+ elsif GNATprove_Mode then
+ Set_Is_Inlined_Always (Subp, False);
+ Error_Msg_NE (Msg & "p?", N, Subp);
+
+ else
+
+ -- Do not emit warning if this is a predefined unit which is not
+ -- the main unit. This behavior is currently provided for backward
+ -- compatibility but it will be removed when we enforce the
+ -- strictness of the new rules.
+
+ if Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (Subp)))
+ and then not In_Extended_Main_Source_Unit (Subp)
+ then
+ null;
+
+ elsif Has_Pragma_Inline_Always (Subp) then
+
+ -- Emit a warning if this is a call to a runtime subprogram
+ -- which is located inside a generic. Previously this call
+ -- was silently skipped.
+
+ if Is_Generic_Instance (Subp) then
+ declare
+ Gen_P : constant Entity_Id := Generic_Parent (Parent (Subp));
+ begin
+ if Is_Predefined_File_Name
+ (Unit_File_Name (Get_Source_Unit (Gen_P)))
+ then
+ Set_Is_Inlined (Subp, False);
+ Error_Msg_NE (Msg & "p?", N, Subp);
+ return;
+ end if;
+ end;
+ end if;
+
+ -- Remove last character (question mark) to make this into an
+ -- error, because the Inline_Always pragma cannot be obeyed.
+
+ Error_Msg_NE (Msg (Msg'First .. Msg'Last - 1), N, Subp);
+
+ else
+ Set_Is_Inlined (Subp, False);
+
+ if Ineffective_Inline_Warnings then
+ Error_Msg_NE (Msg & "p?", N, Subp);
+ end if;
+ end if;
+ end if;
+ end Cannot_Inline;
+
--------------------------------------------
-- Check_And_Split_Unconstrained_Function --
--------------------------------------------
@@ -2241,7 +2292,7 @@ package body Inline is
Lab_Decl : Node_Id;
Lab_Id : Node_Id;
New_A : Node_Id;
- Num_Ret : Int := 0;
+ Num_Ret : Nat := 0;
Ret_Type : Entity_Id;
Targ : Node_Id;
@@ -2263,6 +2314,10 @@ package body Inline is
-- If the type returned by the function is unconstrained and the call
-- can be inlined, special processing is required.
+ procedure Declare_Postconditions_Result;
+ -- When generating C code, declare _Result, which may be used in the
+ -- inlined _Postconditions procedure to verify the return value.
+
procedure Make_Exit_Label;
-- Build declaration for exit label to be used in Return statements,
-- sets Exit_Lab (the label node) and Lab_Decl (corresponding implicit
@@ -2299,6 +2354,45 @@ package body Inline is
function Formal_Is_Used_Once (Formal : Entity_Id) return Boolean;
-- Determine whether a formal parameter is used only once in Orig_Bod
+ -----------------------------------
+ -- Declare_Postconditions_Result --
+ -----------------------------------
+
+ procedure Declare_Postconditions_Result is
+ Enclosing_Subp : constant Entity_Id := Scope (Subp);
+
+ begin
+ pragma Assert
+ (Modify_Tree_For_C
+ and then Is_Subprogram (Enclosing_Subp)
+ and then Present (Postconditions_Proc (Enclosing_Subp)));
+
+ if Ekind (Enclosing_Subp) = E_Function then
+ if Nkind (First (Parameter_Associations (N))) in
+ N_Numeric_Or_String_Literal
+ then
+ Append_To (Declarations (Blk),
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uResult),
+ Constant_Present => True,
+ Object_Definition =>
+ New_Occurrence_Of (Etype (Enclosing_Subp), Loc),
+ Expression =>
+ New_Copy_Tree (First (Parameter_Associations (N)))));
+ else
+ Append_To (Declarations (Blk),
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uResult),
+ Subtype_Mark =>
+ New_Occurrence_Of (Etype (Enclosing_Subp), Loc),
+ Name =>
+ New_Copy_Tree (First (Parameter_Associations (N)))));
+ end if;
+ end if;
+ end Declare_Postconditions_Result;
+
---------------------
-- Make_Exit_Label --
---------------------
@@ -2376,6 +2470,7 @@ package body Inline is
elsif Nkind (N) = N_Simple_Return_Statement then
if No (Expression (N)) then
+ Num_Ret := Num_Ret + 1;
Make_Exit_Label;
Rewrite (N,
Make_Goto_Statement (Loc, Name => New_Copy (Lab_Id)));
@@ -2400,13 +2495,12 @@ package body Inline is
-- errors, e.g. when the expression is a numeric literal and
-- the context is private. If the expression is an aggregate,
-- use a qualified expression, because an aggregate is not a
- -- legal argument of a conversion. Ditto for numeric literals,
- -- which must be resolved to a specific type.
+ -- legal argument of a conversion. Ditto for numeric literals
+ -- and attributes that yield a universal type, because those
+ -- must be resolved to a specific type.
- if Nkind_In (Expression (N), N_Aggregate,
- N_Null,
- N_Real_Literal,
- N_Integer_Literal)
+ if Nkind_In (Expression (N), N_Aggregate, N_Null)
+ or else Yields_Universal_Type (Expression (N))
then
Ret :=
Make_Qualified_Expression (Sloc (N),
@@ -2755,17 +2849,9 @@ package body Inline is
-- subprograms this must be done explicitly.
if In_Open_Scopes (Subp) then
- Error_Msg_N ("call to recursive subprogram cannot be inlined??", N);
+ Cannot_Inline
+ ("cannot inline call to recursive subprogram?", N, Subp);
Set_Is_Inlined (Subp, False);
-
- -- In GNATprove mode, issue a warning, and indicate that the
- -- subprogram is not always inlined by setting flag Is_Inlined_Always
- -- to False.
-
- if GNATprove_Mode then
- Set_Is_Inlined_Always (Subp, False);
- end if;
-
return;
-- Skip inlining if this is not a true inlining since the attribute
@@ -2781,8 +2867,8 @@ package body Inline is
elsif Is_Unc
and then
- Nkind (First (Statements (Handled_Statement_Sequence (Orig_Bod))))
- = N_Extended_Return_Statement
+ Nkind (First (Statements (Handled_Statement_Sequence (Orig_Bod)))) =
+ N_Extended_Return_Statement
and then not Back_End_Inlining
then
return;
@@ -2836,6 +2922,16 @@ package body Inline is
Set_Declarations (Blk, New_List);
end if;
+ -- When generating C code, declare _Result, which may be used to
+ -- verify the return value.
+
+ if Modify_Tree_For_C
+ and then Nkind (N) = N_Procedure_Call_Statement
+ and then Chars (Name (N)) = Name_uPostconditions
+ then
+ Declare_Postconditions_Result;
+ end if;
+
-- For the unconstrained case, capture the name of the local
-- variable that holds the result. This must be the first
-- declaration in the block, because its bounds cannot depend
@@ -3002,8 +3098,10 @@ package body Inline is
elsif Base_Type (Etype (F)) = Base_Type (Etype (A))
and then Etype (F) /= Base_Type (Etype (F))
+ and then Is_Constrained (Etype (F))
then
Temp_Typ := Etype (F);
+
else
Temp_Typ := Etype (A);
end if;
@@ -3013,19 +3111,26 @@ package body Inline is
-- If the actual is a literal and the formal has its address taken,
-- we cannot pass the literal itself as an argument, so its value
- -- must be captured in a temporary.
+ -- must be captured in a temporary. Skip this optimization in
+ -- GNATprove mode, to make sure any check on a type conversion
+ -- will be issued.
if (Is_Entity_Name (A)
and then
- (not Is_Scalar_Type (Etype (A))
- or else Ekind (Entity (A)) = E_Enumeration_Literal))
+ (not Is_Scalar_Type (Etype (A))
+ or else Ekind (Entity (A)) = E_Enumeration_Literal)
+ and then not GNATprove_Mode)
-- When the actual is an identifier and the corresponding formal is
-- used only once in the original body, the formal can be substituted
- -- directly with the actual parameter.
+ -- directly with the actual parameter. Skip this optimization in
+ -- GNATprove mode, to make sure any check on a type conversion
+ -- will be issued.
- or else (Nkind (A) = N_Identifier
- and then Formal_Is_Used_Once (F))
+ or else
+ (Nkind (A) = N_Identifier
+ and then Formal_Is_Used_Once (F)
+ and then not GNATprove_Mode)
or else
(Nkind_In (A, N_Real_Literal,
@@ -3058,8 +3163,17 @@ package body Inline is
Subtype_Mark => New_Occurrence_Of (Etype (F), Loc),
Expression => Relocate_Node (Expression (A)));
- elsif Etype (F) /= Etype (A) then
- New_A := Unchecked_Convert_To (Etype (F), Relocate_Node (A));
+ -- In GNATprove mode, keep the most precise type of the actual for
+ -- the temporary variable, when the formal type is unconstrained.
+ -- Otherwise, the AST may contain unexpected assignment statements
+ -- to a temporary variable of unconstrained type renaming a local
+ -- variable of constrained type, which is not expected by
+ -- GNATprove.
+
+ elsif Etype (F) /= Etype (A)
+ and then (not GNATprove_Mode or else Is_Constrained (Etype (F)))
+ then
+ New_A := Unchecked_Convert_To (Etype (F), Relocate_Node (A));
Temp_Typ := Etype (F);
else
@@ -3095,7 +3209,29 @@ package body Inline is
Constant_Present => True,
Object_Definition => New_Occurrence_Of (Temp_Typ, Loc),
Expression => New_A);
+
else
+ -- In GNATprove mode, make an explicit copy of input
+ -- parameters when formal and actual types differ, to make
+ -- sure any check on the type conversion will be issued.
+ -- The legality of the copy is ensured by calling first
+ -- Call_Can_Be_Inlined_In_GNATprove_Mode.
+
+ if GNATprove_Mode
+ and then Ekind (F) /= E_Out_Parameter
+ and then not Same_Type (Etype (F), Etype (A))
+ then
+ pragma Assert (not (Is_By_Reference_Type (Etype (A))));
+ pragma Assert (not (Is_Limited_Type (Etype (A))));
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Make_Temporary (Loc, 'C'),
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Temp_Typ, Loc),
+ Expression => New_Copy_Tree (New_A)));
+ end if;
+
Decl :=
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Temp,
@@ -3284,8 +3420,9 @@ package body Inline is
elsif Present (Exit_Lab) then
- -- If the body was a single expression, the single return statement
- -- and the corresponding label are useless.
+ -- If there's a single return statement at the end of the subprogram,
+ -- the corresponding goto statement and the corresponding label are
+ -- useless.
if Num_Ret = 1
and then
@@ -3817,7 +3954,7 @@ package body Inline is
-- the body is an internal error.
procedure Instantiate_Bodies is
- J : Int;
+ J : Nat;
Info : Pending_Body_Info;
begin
@@ -3866,7 +4003,6 @@ package body Inline is
-- We can now complete the cleanup actions of scopes that contain
-- pending instantiations (skipped for generic units, since we
-- never need any cleanups in generic units).
- -- pending instantiations.
if Expander_Active
and then not Is_Generic_Unit (Main_Unit_Entity)
@@ -4096,7 +4232,8 @@ package body Inline is
Name_Refined_Post,
Name_Test_Case,
Name_Unmodified,
- Name_Unreferenced)
+ Name_Unreferenced,
+ Name_Unused)
then
Remove (Item);
end if;
@@ -4110,6 +4247,11 @@ package body Inline is
begin
Remove_Items (Aspect_Specifications (Body_Decl));
Remove_Items (Declarations (Body_Decl));
+
+ -- Pragmas Unmodified, Unreferenced, and Unused may additionally appear
+ -- in the body of the subprogram.
+
+ Remove_Items (Statements (Handled_Statement_Sequence (Body_Decl)));
end Remove_Aspects_And_Pragmas;
--------------------------
diff --git a/gcc/ada/inline.ads b/gcc/ada/inline.ads
index b007b36cb6..96cff58223 100644
--- a/gcc/ada/inline.ads
+++ b/gcc/ada/inline.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -74,9 +74,9 @@ package Inline is
-- must be inhibited.
Current_Sem_Unit : Unit_Number_Type;
- -- The semantic unit within which the instantiation is found. Must
- -- be restored when compiling the body, to insure that internal enti-
- -- ties use the same counter and are unique over spec and body.
+ -- The semantic unit within which the instantiation is found. Must be
+ -- restored when compiling the body, to insure that internal entities
+ -- use the same counter and are unique over spec and body.
Scope_Suppress : Suppress_Record;
Local_Suppress_Stack_Top : Suppress_Stack_Entry_Ptr;
@@ -167,6 +167,13 @@ package Inline is
-- enabled and the subprogram contains a construct that cannot be inlined,
-- the problematic construct is flagged accordingly.
+ function Call_Can_Be_Inlined_In_GNATprove_Mode
+ (N : Node_Id;
+ Subp : Entity_Id) return Boolean;
+ -- Returns False if the call in node N to subprogram Subp cannot be inlined
+ -- in GNATprove mode, because it may lead to missing a check on type
+ -- conversion of input parameters otherwise. Returns True otherwise.
+
function Can_Be_Inlined_In_GNATprove_Mode
(Spec_Id : Entity_Id;
Body_Id : Entity_Id) return Boolean;
diff --git a/gcc/ada/interfac.ads b/gcc/ada/interfac.ads
index 2c501a2dd2..3bda2f4665 100644
--- a/gcc/ada/interfac.ads
+++ b/gcc/ada/interfac.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2002-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2016, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -36,6 +36,7 @@
pragma Compiler_Unit_Warning;
package Interfaces is
+ pragma No_Elaboration_Code_All;
pragma Pure;
-- All identifiers in this unit are implementation defined
diff --git a/gcc/ada/krunch.adb b/gcc/ada/krunch.adb
index 79f9de1c82..a4e0caba3c 100644
--- a/gcc/ada/krunch.adb
+++ b/gcc/ada/krunch.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -95,7 +95,24 @@ begin
Startloc := 3;
Buffer (2 .. Len - 9) := Buffer (11 .. Len);
Curlen := Len - 9;
- Krlen := 8;
+
+ -- Only fully krunch historical units. For new units, simply use
+ -- the 'i-' prefix instead of 'interfaces-'. Packages Interfaces.C
+ -- and Interfaces.Cobol are already in the right form. Package
+ -- Interfaces.Definitions is krunched for backward compatibility.
+
+ if (Curlen > 3 and then Buffer (3 .. 4) = "c-")
+ or else (Curlen > 3 and then Buffer (3 .. 4) = "c_")
+ or else (Curlen = 13 and then Buffer (3 .. 13) = "definitions")
+ or else (Curlen = 9 and then Buffer (3 .. 9) = "fortran")
+ or else (Curlen = 16 and then Buffer (3 .. 16) = "packed_decimal")
+ or else (Curlen > 8 and then Buffer (3 .. 9) = "vxworks")
+ or else (Curlen > 5 and then Buffer (3 .. 6) = "java")
+ then
+ Krlen := 8;
+ else
+ Krlen := Maxlen;
+ end if;
-- For the renamings in the obsolescent section, we also force krunching
-- to 8 characters, but no other special processing is required here.
diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb
index c8d7ed7f6c..4373a970ec 100644
--- a/gcc/ada/layout.adb
+++ b/gcc/ada/layout.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -668,13 +668,12 @@ package body Layout is
type Val_Status_Type is (Const, Dynamic);
- type Val_Type (Status : Val_Status_Type := Const) is
- record
- case Status is
- when Const => Val : Uint;
- when Dynamic => Nod : Node_Id;
- end case;
- end record;
+ type Val_Type (Status : Val_Status_Type := Const) is record
+ case Status is
+ when Const => Val : Uint;
+ when Dynamic => Nod : Node_Id;
+ end case;
+ end record;
-- Shows the status of the value so far. Const means that the value is
-- constant, and Val is the current constant value. Dynamic means that
-- the value is dynamic, and in this case Nod is the Node_Id of the
@@ -932,19 +931,19 @@ package body Layout is
type Val_Status_Type is (Const, Dynamic, Discrim);
- type Val_Type (Status : Val_Status_Type := Const) is
- record
- case Status is
- when Const =>
- Val : Uint;
- -- Calculated value so far if Val_Status = Const
-
- when Dynamic | Discrim =>
- Nod : Node_Id;
- -- Expression value so far if Val_Status /= Const
-
- end case;
- end record;
+ type Val_Type (Status : Val_Status_Type := Const) is record
+ case Status is
+ when Const =>
+ Val : Uint;
+ -- Calculated value so far if Val_Status = Const
+
+ when Discrim
+ | Dynamic
+ =>
+ Nod : Node_Id;
+ -- Expression value so far if Val_Status /= Const
+ end case;
+ end record;
-- Records the value or expression computed so far. Const means that
-- the value is constant, and Val is the current constant value.
-- Dynamic means that the value is dynamic, and in this case Nod is
@@ -2501,24 +2500,6 @@ package body Layout is
then
Init_Size (E, 2 * System_Address_Size);
- -- When the target is AAMP, access-to-subprogram types are fat
- -- pointers consisting of the subprogram address and a static link,
- -- with the exception of library-level access types (including
- -- library-level anonymous access types, such as for components),
- -- where a simple subprogram address is used.
-
- elsif AAMP_On_Target
- and then
- ((Ekind (E) = E_Access_Subprogram_Type
- and then Present (Enclosing_Subprogram (E)))
- or else
- (Ekind (E) = E_Anonymous_Access_Subprogram_Type
- and then
- (not Is_Local_Anonymous_Access (E)
- or else Present (Enclosing_Subprogram (E)))))
- then
- Init_Size (E, 2 * System_Address_Size);
-
-- Normal case of thin pointer
else
@@ -3247,7 +3228,7 @@ package body Layout is
A := 2 * A;
end loop;
- -- If alignment is currently not set, then we can safetly set it to
+ -- If alignment is currently not set, then we can safely set it to
-- this new calculated value.
if Unknown_Alignment (E) then
@@ -3256,7 +3237,7 @@ package body Layout is
-- Cases where we have inherited an alignment
-- For constructed types, always reset the alignment, these are
- -- Generally invisible to the user anyway, and that way we are
+ -- generally invisible to the user anyway, and that way we are
-- sure that no constructed types have weird alignments.
elsif not Comes_From_Source (E) then
@@ -3268,80 +3249,114 @@ package body Layout is
elsif Alignment (E) = A then
null;
- -- Now we come to the difficult cases where we have inherited an
- -- alignment and size, but overridden the size but not the alignment.
-
- elsif Has_Size_Clause (E) or else Has_Object_Size_Clause (E) then
-
- -- This is tricky, it might be thought that we should try to
- -- inherit the alignment, since that's what the RM implies, but
- -- that leads to complex rules and oddities. Consider for example:
-
- -- type R is new Character;
- -- for R'Size use 16;
-
- -- It seems quite bogus in this case to inherit an alignment of 1
- -- from the parent type Character. Furthermore, if that's what the
- -- programmer really wanted for some odd reason, then they could
- -- specify the alignment they wanted.
-
- -- Furthermore we really don't want to inherit the alignment in
- -- the case of a specified Object_Size for a subtype, since then
- -- there would be no way of overriding to give a reasonable value
- -- (we don't have an Object_Subtype attribute). Consider:
-
- -- subtype R is new Character;
- -- for R'Object_Size use 16;
-
- -- If we inherit the alignment of 1, then we have an odd
- -- inefficient alignment for the subtype, which cannot be fixed.
-
- -- So we make the decision that if Size (or Object_Size) is given
- -- (and, in the case of a first subtype, the alignment is not set
- -- with a specific alignment clause). We reset the alignment to
- -- the appropriate value for the specified size. This is a nice
- -- simple rule to implement and document.
-
- -- There is one slight glitch, which is that a confirming size
- -- clause can now change the alignment, which, if we really think
- -- that confirming rep clauses should have no effect, is a no-no.
-
- -- type R is new Character;
- -- for R'Alignment use 2;
- -- type S is new R;
- -- for S'Size use Character'Size;
-
- -- Now the alignment of S is 1 instead of 2, as a result of
- -- applying the above rule to the confirming rep clause for S. Not
- -- clear this is worth worrying about. If we recorded whether a
- -- size clause was confirming we could avoid this, but right now
- -- we have no way of doing that or easily figuring it out, so we
- -- don't bother.
-
- -- Historical note. In versions of GNAT prior to Nov 6th, 2010, an
- -- odd distinction was made between inherited alignments greater
- -- than the computed alignment (where the larger alignment was
- -- inherited) and inherited alignments smaller than the computed
- -- alignment (where the smaller alignment was overridden). This
- -- was a dubious fix to get around an ACATS problem which seems
- -- to have disappeared anyway, and in any case, this peculiarity
- -- was never documented.
+ else
+ -- Now we come to the difficult cases of subtypes for which we
+ -- have inherited an alignment different from the computed one.
+ -- We resort to the presence of alignment and size clauses to
+ -- guide our choices. Note that they can generally be present
+ -- only on the first subtype (except for Object_Size) and that
+ -- we need to look at the Rep_Item chain to correctly handle
+ -- derived types.
- Init_Alignment (E, A);
+ declare
+ FST : constant Entity_Id := First_Subtype (E);
- -- If no Size (or Object_Size) was specified, then we inherited the
- -- object size, so we should inherit the alignment as well and not
- -- modify it. This takes care of cases like:
+ function Has_Attribute_Clause
+ (E : Entity_Id;
+ Id : Attribute_Id) return Boolean;
+ -- Wrapper around Get_Attribute_Definition_Clause which tests
+ -- for the presence of the specified attribute clause.
- -- type R is new Integer;
- -- for R'Alignment use 1;
- -- subtype S is R;
+ --------------------------
+ -- Has_Attribute_Clause --
+ --------------------------
- -- Here we have R has a default Object_Size of 32, and a specified
- -- alignment of 1, and it seeems right for S to inherit both values.
+ function Has_Attribute_Clause
+ (E : Entity_Id;
+ Id : Attribute_Id) return Boolean is
+ begin
+ return Present (Get_Attribute_Definition_Clause (E, Id));
+ end Has_Attribute_Clause;
- else
- null;
+ begin
+ -- If the alignment comes from a clause, then we respect it.
+ -- Consider for example:
+
+ -- type R is new Character;
+ -- for R'Alignment use 1;
+ -- for R'Size use 16;
+ -- subtype S is R;
+
+ -- Here R has a specified size of 16 and a specified alignment
+ -- of 1, and it seems right for S to inherit both values.
+
+ if Has_Attribute_Clause (FST, Attribute_Alignment) then
+ null;
+
+ -- Now we come to the cases where we have inherited alignment
+ -- and size, and overridden the size but not the alignment.
+
+ elsif Has_Attribute_Clause (FST, Attribute_Size)
+ or else Has_Attribute_Clause (FST, Attribute_Object_Size)
+ or else Has_Attribute_Clause (E, Attribute_Object_Size)
+ then
+ -- This is tricky, it might be thought that we should try to
+ -- inherit the alignment, since that's what the RM implies,
+ -- but that leads to complex rules and oddities. Consider
+ -- for example:
+
+ -- type R is new Character;
+ -- for R'Size use 16;
+
+ -- It seems quite bogus in this case to inherit an alignment
+ -- of 1 from the parent type Character. Furthermore, if that
+ -- is what the programmer really wanted for some odd reason,
+ -- then he could specify the alignment directly.
+
+ -- Moreover we really don't want to inherit the alignment in
+ -- the case of a specified Object_Size for a subtype, since
+ -- there would be no way of overriding to give a reasonable
+ -- value (as we don't have an Object_Alignment attribute).
+ -- Consider for example:
+
+ -- subtype R is Character;
+ -- for R'Object_Size use 16;
+
+ -- If we inherit the alignment of 1, then it will be very
+ -- inefficient for the subtype and this cannot be fixed.
+
+ -- So we make the decision that if Size (or Object_Size) is
+ -- given and the alignment is not specified with a clause,
+ -- we reset the alignment to the appropriate value for the
+ -- specified size. This is a nice simple rule to implement
+ -- and document.
+
+ -- There is a theoretical glitch, which is that a confirming
+ -- size clause could now change the alignment, which, if we
+ -- really think that confirming rep clauses should have no
+ -- effect, could be seen as a no-no. However that's already
+ -- implemented by Alignment_Check_For_Size_Change so we do
+ -- not change the philosophy here.
+
+ -- Historical note: in versions prior to Nov 6th, 2011, an
+ -- odd distinction was made between inherited alignments
+ -- larger than the computed alignment (where the larger
+ -- alignment was inherited) and inherited alignments smaller
+ -- than the computed alignment (where the smaller alignment
+ -- was overridden). This was a dubious fix to get around an
+ -- ACATS problem which seems to have disappeared anyway, and
+ -- in any case, this peculiarity was never documented.
+
+ Init_Alignment (E, A);
+
+ -- If no Size (or Object_Size) was specified, then we have
+ -- inherited the object size, so we should also inherit the
+ -- alignment and not modify it.
+
+ else
+ null;
+ end if;
+ end;
end if;
end;
end Set_Elem_Alignment;
diff --git a/gcc/ada/lib-load.adb b/gcc/ada/lib-load.adb
index 83d3576eeb..c66fd7264d 100644
--- a/gcc/ada/lib-load.adb
+++ b/gcc/ada/lib-load.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -784,7 +784,7 @@ package body Lib.Load is
-- Generate message if unit required
- if Required and then Present (Error_Node) then
+ if Required then
if Is_Predefined_File_Name (Fname) then
-- This is a predefined library unit which is not present
@@ -799,7 +799,9 @@ package body Lib.Load is
-- the message about the restriction violation is generated,
-- if needed.
- Check_Restricted_Unit (Load_Name, Error_Node);
+ if Present (Error_Node) then
+ Check_Restricted_Unit (Load_Name, Error_Node);
+ end if;
Error_Msg_Unit_1 := Uname_Actual;
Error_Msg -- CODEFIX
diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb
index e7925651f7..981656552a 100644
--- a/gcc/ada/lib-writ.adb
+++ b/gcc/ada/lib-writ.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -43,6 +43,7 @@ with Par;
with Par_SCO; use Par_SCO;
with Restrict; use Restrict;
with Rident; use Rident;
+with Stand; use Stand;
with Scn; use Scn;
with Sem_Eval; use Sem_Eval;
with Sinfo; use Sinfo;
@@ -155,8 +156,9 @@ package body Lib.Writ is
OA_Setting => 'O',
SPARK_Mode_Pragma => Empty);
- -- Parse system.ads so that the checksum is set right
- -- Style checks are not applied.
+ -- Parse system.ads so that the checksum is set right. Style checks are
+ -- not applied. The Ekind is set to ensure that this reference is always
+ -- present in the ali file.
declare
Save_Mindex : constant Nat := Multiple_Unit_Index;
@@ -166,6 +168,8 @@ package body Lib.Writ is
Style_Check := False;
Initialize_Scanner (Units.Last, System_Source_File_Index);
Discard_List (Par (Configuration_Pragmas => False));
+ Set_Ekind (Cunit_Entity (Units.Last), E_Package);
+ Set_Scope (Cunit_Entity (Units.Last), Standard_Standard);
Style_Check := Save_Style;
Multiple_Unit_Index := Save_Mindex;
end;
@@ -668,7 +672,7 @@ package body Lib.Writ is
Write_Info_Initiate ('N');
Write_Info_Char (' ');
- case Chars (Pragma_Identifier (N)) is
+ case Pragma_Name_Unmapped (N) is
when Name_Annotate =>
C := 'A';
when Name_Comment =>
@@ -747,16 +751,16 @@ package body Lib.Writ is
----------------------
procedure Write_With_Lines is
- With_Table : Unit_Ref_Table (1 .. Pos (Last_Unit - Units.First + 1));
- Num_Withs : Int := 0;
- Unum : Unit_Number_Type;
- Cunit : Node_Id;
- Uname : Unit_Name_Type;
- Fname : File_Name_Type;
Pname : constant Unit_Name_Type :=
Get_Parent_Spec_Name (Unit_Name (Main_Unit));
Body_Fname : File_Name_Type;
Body_Index : Nat;
+ Cunit : Node_Id;
+ Fname : File_Name_Type;
+ Num_Withs : Int := 0;
+ Unum : Unit_Number_Type;
+ Uname : Unit_Name_Type;
+ With_Table : Unit_Ref_Table (1 .. Pos (Last_Unit - Units.First + 1));
procedure Write_With_File_Names
(Nam : in out File_Name_Type;
@@ -814,10 +818,18 @@ package body Lib.Writ is
Sort (With_Table (1 .. Num_Withs));
for J in 1 .. Num_Withs loop
- Unum := With_Table (J);
- Cunit := Units.Table (Unum).Cunit;
- Uname := Units.Table (Unum).Unit_Name;
- Fname := Units.Table (Unum).Unit_File_Name;
+ Unum := With_Table (J);
+
+ -- Do not generate a with line for an ignored Ghost unit because
+ -- the unit does not have an ALI file.
+
+ if Is_Ignored_Ghost_Entity (Cunit_Entity (Unum)) then
+ goto Next_With_Line;
+ end if;
+
+ Cunit := Units.Table (Unum).Cunit;
+ Uname := Units.Table (Unum).Unit_Name;
+ Fname := Units.Table (Unum).Unit_File_Name;
if Implicit_With (Unum) = Yes then
Write_Info_Initiate ('Z');
@@ -914,6 +926,9 @@ package body Lib.Writ is
end if;
Write_Info_EOL;
+
+ <<Next_With_Line>>
+ null;
end loop;
-- Finally generate the special lines for cases of Restriction_Set
@@ -932,7 +947,7 @@ package body Lib.Writ is
for U in 0 .. Last_Unit loop
if Unit_Name (U) = Unam then
- goto Continue;
+ goto Next_Restriction_Set;
end if;
end loop;
@@ -943,7 +958,7 @@ package body Lib.Writ is
Write_Info_Name (Unam);
Write_Info_EOL;
- <<Continue>>
+ <<Next_Restriction_Set>>
null;
end loop;
end;
@@ -975,8 +990,27 @@ package body Lib.Writ is
if Cunit_Entity (Unum) = Empty
or else not From_Limited_With (Cunit_Entity (Unum))
then
- Num_Sdep := Num_Sdep + 1;
- Sdep_Table (Num_Sdep) := Unum;
+ -- Units that are not analyzed need not appear in the dependency
+ -- list. These units are either units appearing in limited_with
+ -- clauses of other units, or units loaded for inlining that end
+ -- up not inlined by a later decision of the inlining code, to
+ -- prevent circularities. We want to exclude these files from the
+ -- list of dependencies, so that the dependency number of other
+ -- is correctly set, as that number is used by cross-reference
+ -- tools to relate entity information to the unit in which they
+ -- are declared.
+
+ if Present (Cunit_Entity (Unum))
+ and then Ekind (Cunit_Entity (Unum)) = E_Void
+ and then Nkind (Unit (Cunit (Unum))) /= N_Subunit
+ and then Serious_Errors_Detected = 0
+ then
+ null;
+
+ else
+ Num_Sdep := Num_Sdep + 1;
+ Sdep_Table (Num_Sdep) := Unum;
+ end if;
end if;
end loop;
@@ -996,8 +1030,8 @@ package body Lib.Writ is
end if;
end if;
- -- Otherwise acquire compilation arguments and prepare to write
- -- out a new ali file.
+ -- Otherwise acquire compilation arguments and prepare to write out a
+ -- new ali file.
Create_Output_Library_Info;
@@ -1441,6 +1475,18 @@ package body Lib.Writ is
Write_Info_Char (' ');
Write_Info_Str (Get_Hex_String (Source_Checksum (Sind)));
+ -- If the dependency comes from a limited_with clause, record
+ -- limited_checksum. This is disabled until full checksum
+ -- changes are checked.
+
+ -- if Present (Cunit_Entity (Unum))
+ -- and then From_Limited_With (Cunit_Entity (Unum))
+ -- then
+ -- Write_Info_Char (' ');
+ -- Write_Info_Char ('Y');
+ -- Write_Info_Str (Get_Hex_String (Limited_Chk_Sum (Sind)));
+ -- end if;
+
-- If subunit, add unit name, omitting the %b at the end
if Present (Cunit (Unum)) then
diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads
index dce65f04ee..f113b0a599 100644
--- a/gcc/ada/lib-writ.ads
+++ b/gcc/ada/lib-writ.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -192,8 +192,8 @@ package Lib.Writ is
-- the units in this file, where x is the first character
-- (upper case) of the policy name (e.g. 'C' for Concurrent).
- -- FX Units in this file use front-end exceptions, with explicit
- -- handlers to trigger AT-END actions on exception paths.
+ -- FX Units in this file use front-end exceptions, with explicit
+ -- handlers to trigger AT-END actions on exception paths.
-- GP Set if this compilation was done in GNATprove mode, either
-- from direct use of GNATprove, or from use of -gnatdF.
@@ -240,12 +240,12 @@ package Lib.Writ is
-- (upper case) of the corresponding policy name (e.g. 'F'
-- for FIFO_Within_Priorities).
- -- UA Unreserve_All_Interrupts pragma was processed in one or
- -- more units in this file
+ -- UA Unreserve_All_Interrupts pragma was processed in one or
+ -- more units in this file
- -- ZX Units in this file use zero-cost exceptions and have
- -- generated exception tables. If ZX is not present, the
- -- longjmp/setjmp exception scheme is in use.
+ -- ZX Units in this file use zero-cost exceptions and have
+ -- generated exception tables. If ZX is not present, the
+ -- longjmp/setjmp exception scheme is in use.
-- Note that language defined units never output policy (Lx, Tx, Qx)
-- parameters. Language defined units must correctly handle all
@@ -570,22 +570,22 @@ package Lib.Writ is
-- code is required. Set if N_Compilation_Unit node has flag
-- Has_No_Elaboration_Code set.
- -- OL The units in this file are compiled with a local pragma
- -- Optimize_Alignment, so no consistency requirement applies
- -- to these units. All internal units have this status since
- -- they have an automatic default of Optimize_Alignment (Off).
+ -- OL The units in this file are compiled with a local pragma
+ -- Optimize_Alignment, so no consistency requirement applies
+ -- to these units. All internal units have this status since
+ -- they have an automatic default of Optimize_Alignment (Off).
--
- -- OO Optimize_Alignment (Off) is the default setting for all
- -- units in this file. All files in the partition that specify
- -- a default must specify the same default.
+ -- OO Optimize_Alignment (Off) is the default setting for all
+ -- units in this file. All files in the partition that specify
+ -- a default must specify the same default.
- -- OS Optimize_Alignment (Space) is the default setting for all
- -- units in this file. All files in the partition that specify
- -- a default must specify the same default.
+ -- OS Optimize_Alignment (Space) is the default setting for all
+ -- units in this file. All files in the partition that specify
+ -- a default must specify the same default.
- -- OT Optimize_Alignment (Time) is the default setting for all
- -- units in this file. All files in the partition that specify
- -- a default must specify the same default.
+ -- OT Optimize_Alignment (Time) is the default setting for all
+ -- units in this file. All files in the partition that specify
+ -- a default must specify the same default.
-- PF The unit has a library-level (package) finalizer
diff --git a/gcc/ada/lib-xref-spark_specific.adb b/gcc/ada/lib-xref-spark_specific.adb
index c857b0f694..dfbe4dd341 100644
--- a/gcc/ada/lib-xref-spark_specific.adb
+++ b/gcc/ada/lib-xref-spark_specific.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -54,9 +54,9 @@ package body SPARK_Specific is
-- True for each reference type used in SPARK
SPARK_References : constant array (Character) of Boolean :=
- ('m' => True,
- 'r' => True,
- 's' => True,
+ ('m' => True,
+ 'r' => True,
+ 's' => True,
others => False);
type Entity_Hashed_Range is range 0 .. 255;
@@ -85,63 +85,170 @@ package body SPARK_Specific is
-- Local Subprograms --
-----------------------
- procedure Add_SPARK_File (Ubody, Uspec : Unit_Number_Type; Dspec : Nat);
+ procedure Add_SPARK_File (Uspec, Ubody : Unit_Number_Type; Dspec : Nat);
-- Add file and corresponding scopes for unit to the tables
- -- SPARK_File_Table and SPARK_Scope_Table. When two units are present for
- -- the same compilation unit, as it happens for library-level
- -- instantiations of generics, then Ubody /= Uspec, and all scopes are
- -- added to the same SPARK file. Otherwise Ubody = Uspec.
-
- procedure Add_SPARK_Scope (N : Node_Id);
- -- Add scope N to the table SPARK_Scope_Table
+ -- SPARK_File_Table and SPARK_Scope_Table. When two units are present
+ -- for the same compilation unit, as it happens for library-level
+ -- instantiations of generics, then Ubody is the number of the body
+ -- unit; otherwise it is No_Unit.
procedure Add_SPARK_Xrefs;
-- Filter table Xrefs to add all references used in SPARK to the table
-- SPARK_Xref_Table.
- procedure Detect_And_Add_SPARK_Scope (N : Node_Id);
- -- Call Add_SPARK_Scope on scopes
-
function Entity_Hash (E : Entity_Id) return Entity_Hashed_Range;
-- Hash function for hash table
- procedure Traverse_Declaration_Or_Statement
- (N : Node_Id;
- Process : Node_Processing;
- Inside_Stubs : Boolean);
- procedure Traverse_Declarations_Or_Statements
- (L : List_Id;
- Process : Node_Processing;
- Inside_Stubs : Boolean);
- procedure Traverse_Handled_Statement_Sequence
- (N : Node_Id;
- Process : Node_Processing;
- Inside_Stubs : Boolean);
- procedure Traverse_Protected_Body
- (N : Node_Id;
- Process : Node_Processing;
- Inside_Stubs : Boolean);
- procedure Traverse_Package_Body
- (N : Node_Id;
- Process : Node_Processing;
- Inside_Stubs : Boolean);
- procedure Traverse_Subprogram_Body
- (N : Node_Id;
- Process : Node_Processing;
- Inside_Stubs : Boolean);
- -- Traverse corresponding construct, calling Process on all declarations
-
--------------------
-- Add_SPARK_File --
--------------------
- procedure Add_SPARK_File (Ubody, Uspec : Unit_Number_Type; Dspec : Nat) is
+ procedure Add_SPARK_File (Uspec, Ubody : Unit_Number_Type; Dspec : Nat) is
File : constant Source_File_Index := Source_Index (Uspec);
- From : Scope_Index;
+ From : constant Scope_Index := SPARK_Scope_Table.Last + 1;
+
+ Scope_Id : Pos := 1;
+
+ procedure Add_SPARK_Scope (N : Node_Id);
+ -- Add scope N to the table SPARK_Scope_Table
+
+ procedure Detect_And_Add_SPARK_Scope (N : Node_Id);
+ -- Call Add_SPARK_Scope on scopes
+
+ ---------------------
+ -- Add_SPARK_Scope --
+ ---------------------
+
+ procedure Add_SPARK_Scope (N : Node_Id) is
+ E : constant Entity_Id := Defining_Entity (N);
+ Loc : constant Source_Ptr := Sloc (E);
+
+ -- The character describing the kind of scope is chosen to be the
+ -- same as the one describing the corresponding entity in cross
+ -- references, see Xref_Entity_Letters in lib-xrefs.ads
+
+ Typ : Character;
+
+ begin
+ -- Ignore scopes without a proper location
+
+ if Sloc (N) = No_Location then
+ return;
+ end if;
+
+ case Ekind (E) is
+ when E_Entry
+ | E_Entry_Family
+ | E_Generic_Function
+ | E_Generic_Package
+ | E_Generic_Procedure
+ | E_Package
+ | E_Protected_Type
+ | E_Task_Type
+ =>
+ Typ := Xref_Entity_Letters (Ekind (E));
+
+ when E_Function
+ | E_Procedure
+ =>
+ -- In SPARK we need to distinguish protected functions and
+ -- procedures from ordinary subprograms, but there are no
+ -- special Xref letters for them. Since this distiction is
+ -- only needed to detect protected calls, we pretend that
+ -- such calls are entry calls.
+
+ if Ekind (Scope (E)) = E_Protected_Type then
+ Typ := Xref_Entity_Letters (E_Entry);
+ else
+ Typ := Xref_Entity_Letters (Ekind (E));
+ end if;
+
+ when E_Package_Body
+ | E_Protected_Body
+ | E_Subprogram_Body
+ | E_Task_Body
+ =>
+ Typ := Xref_Entity_Letters (Ekind (Unique_Entity (E)));
+
+ when E_Void =>
+
+ -- Compilation of prj-attr.adb with -gnatn creates a node with
+ -- entity E_Void for the package defined at a-charac.ads16:13.
+ -- ??? TBD
+
+ return;
+
+ when others =>
+ raise Program_Error;
+ end case;
+
+ -- File_Num and Scope_Num are filled later. From_Xref and To_Xref
+ -- are filled even later, but are initialized to represent an empty
+ -- range.
+
+ SPARK_Scope_Table.Append
+ ((Scope_Name => new String'(Unique_Name (E)),
+ File_Num => Dspec,
+ Scope_Num => Scope_Id,
+ Spec_File_Num => 0,
+ Spec_Scope_Num => 0,
+ Line => Nat (Get_Logical_Line_Number (Loc)),
+ Stype => Typ,
+ Col => Nat (Get_Column_Number (Loc)),
+ From_Xref => 1,
+ To_Xref => 0,
+ Scope_Entity => E));
+
+ Scope_Id := Scope_Id + 1;
+ end Add_SPARK_Scope;
+
+ --------------------------------
+ -- Detect_And_Add_SPARK_Scope --
+ --------------------------------
+
+ procedure Detect_And_Add_SPARK_Scope (N : Node_Id) is
+ begin
+ -- Entries
+
+ if Nkind_In (N, N_Entry_Body, N_Entry_Declaration)
+
+ -- Packages
+
+ or else Nkind_In (N, N_Package_Body,
+ N_Package_Body_Stub,
+ N_Package_Declaration)
+ -- Protected units
+
+ or else Nkind_In (N, N_Protected_Body,
+ N_Protected_Body_Stub,
+ N_Protected_Type_Declaration)
+
+ -- Subprograms
+
+ or else Nkind_In (N, N_Subprogram_Body,
+ N_Subprogram_Body_Stub,
+ N_Subprogram_Declaration)
+
+ -- Task units
+
+ or else Nkind_In (N, N_Task_Body,
+ N_Task_Body_Stub,
+ N_Task_Type_Declaration)
+ then
+ Add_SPARK_Scope (N);
+ end if;
+ end Detect_And_Add_SPARK_Scope;
+
+ procedure Traverse_Scopes is new
+ Traverse_Compilation_Unit (Detect_And_Add_SPARK_Scope);
+
+ -- Local variables
File_Name : String_Ptr;
Unit_File_Name : String_Ptr;
+ -- Start of processing for Add_SPARK_File
+
begin
-- Source file could be inexistant as a result of an error, if option
-- gnatQ is used.
@@ -150,69 +257,23 @@ package body SPARK_Specific is
return;
end if;
- From := SPARK_Scope_Table.Last + 1;
+ -- Subunits are traversed as part of the top-level unit to which they
+ -- belong.
- -- Unit might not have an associated compilation unit, as seen in code
- -- filling Sdep_Table in Write_ALI.
-
- if Present (Cunit (Ubody)) then
- Traverse_Compilation_Unit
- (CU => Cunit (Ubody),
- Process => Detect_And_Add_SPARK_Scope'Access,
- Inside_Stubs => True);
+ if Nkind (Unit (Cunit (Uspec))) = N_Subunit then
+ return;
end if;
+ Traverse_Scopes (CU => Cunit (Uspec), Inside_Stubs => True);
+
-- When two units are present for the same compilation unit, as it
-- happens for library-level instantiations of generics, then add all
-- scopes to the same SPARK file.
- if Ubody /= Uspec then
- if Present (Cunit (Uspec)) then
- Traverse_Compilation_Unit
- (CU => Cunit (Uspec),
- Process => Detect_And_Add_SPARK_Scope'Access,
- Inside_Stubs => True);
- end if;
+ if Ubody /= No_Unit then
+ Traverse_Scopes (CU => Cunit (Ubody), Inside_Stubs => True);
end if;
- -- Update scope numbers
-
- declare
- Scope_Id : Int;
- begin
- Scope_Id := 1;
- for Index in From .. SPARK_Scope_Table.Last loop
- declare
- S : SPARK_Scope_Record renames SPARK_Scope_Table.Table (Index);
- begin
- S.Scope_Num := Scope_Id;
- S.File_Num := Dspec;
- Scope_Id := Scope_Id + 1;
- end;
- end loop;
- end;
-
- -- Remove those scopes previously marked for removal
-
- declare
- Scope_Id : Scope_Index;
-
- begin
- Scope_Id := From;
- for Index in From .. SPARK_Scope_Table.Last loop
- declare
- S : SPARK_Scope_Record renames SPARK_Scope_Table.Table (Index);
- begin
- if S.Scope_Num /= 0 then
- SPARK_Scope_Table.Table (Scope_Id) := S;
- Scope_Id := Scope_Id + 1;
- end if;
- end;
- end loop;
-
- SPARK_Scope_Table.Set_Last (Scope_Id - 1);
- end;
-
-- Make entry for new file in file table
Get_Name_String (Reference_Name (File));
@@ -221,12 +282,13 @@ package body SPARK_Specific is
-- For subunits, also retrieve the file name of the unit. Only do so if
-- unit has an associated compilation unit.
- if Present (Cunit (Uspec))
- and then Present (Cunit (Unit (File)))
+ if Present (Cunit (Unit (File)))
and then Nkind (Unit (Cunit (Unit (File)))) = N_Subunit
then
Get_Name_String (Reference_Name (Main_Source_File));
Unit_File_Name := new String'(Name_Buffer (1 .. Name_Len));
+ else
+ Unit_File_Name := null;
end if;
SPARK_File_Table.Append (
@@ -238,71 +300,6 @@ package body SPARK_Specific is
end Add_SPARK_File;
---------------------
- -- Add_SPARK_Scope --
- ---------------------
-
- procedure Add_SPARK_Scope (N : Node_Id) is
- E : constant Entity_Id := Defining_Entity (N);
- Loc : constant Source_Ptr := Sloc (E);
-
- -- The character describing the kind of scope is chosen to be the same
- -- as the one describing the corresponding entity in cross references,
- -- see Xref_Entity_Letters in lib-xrefs.ads
-
- Typ : Character;
-
- begin
- -- Ignore scopes without a proper location
-
- if Sloc (N) = No_Location then
- return;
- end if;
-
- case Ekind (E) is
- when E_Entry
- | E_Entry_Family
- | E_Function
- | E_Generic_Function
- | E_Generic_Package
- | E_Generic_Procedure
- | E_Package
- | E_Procedure
- =>
- Typ := Xref_Entity_Letters (Ekind (E));
-
- when E_Package_Body | E_Subprogram_Body | E_Task_Body =>
- Typ := Xref_Entity_Letters (Ekind (Unique_Entity (E)));
-
- when E_Void =>
-
- -- Compilation of prj-attr.adb with -gnatn creates a node with
- -- entity E_Void for the package defined at a-charac.ads16:13.
- -- ??? TBD
-
- return;
-
- when others =>
- raise Program_Error;
- end case;
-
- -- File_Num and Scope_Num are filled later. From_Xref and To_Xref are
- -- filled even later, but are initialized to represent an empty range.
-
- SPARK_Scope_Table.Append (
- (Scope_Name => new String'(Unique_Name (E)),
- File_Num => 0,
- Scope_Num => 0,
- Spec_File_Num => 0,
- Spec_Scope_Num => 0,
- Line => Nat (Get_Logical_Line_Number (Loc)),
- Stype => Typ,
- Col => Nat (Get_Column_Number (Loc)),
- From_Xref => 1,
- To_Xref => 0,
- Scope_Entity => E));
- end Add_SPARK_Scope;
-
- ---------------------
-- Add_SPARK_Xrefs --
---------------------
@@ -313,6 +310,9 @@ package body SPARK_Specific is
function Get_Entity_Type (E : Entity_Id) return Character;
-- Return a character representing the type of entity
+ function Get_Scope_Num (N : Entity_Id) return Nat;
+ -- Return the scope number associated to entity N
+
function Is_Constant_Object_Without_Variable_Input
(E : Entity_Id) return Boolean;
-- Return True if E is known to have no variable input, as defined in
@@ -339,6 +339,9 @@ package body SPARK_Specific is
procedure Move (From : Natural; To : Natural);
-- Move procedure for Sort call
+ procedure Set_Scope_Num (N : Entity_Id; Num : Nat);
+ -- Associate entity N to scope number Num
+
procedure Update_Scope_Range
(S : Scope_Index;
From : Xref_Index;
@@ -347,12 +350,6 @@ package body SPARK_Specific is
package Sorting is new GNAT.Heap_Sort_G (Move, Lt);
- function Get_Scope_Num (N : Entity_Id) return Nat;
- -- Return the scope number associated to entity N
-
- procedure Set_Scope_Num (N : Entity_Id; Num : Nat);
- -- Associate entity N to scope number Num
-
No_Scope : constant Nat := 0;
-- Initial scope counter
@@ -369,7 +366,7 @@ package body SPARK_Specific is
Key => Entity_Id,
Hash => Entity_Hash,
Equal => "=");
- -- Package used to build a correspondance between entities and scope
+ -- Package used to build a correspondence between entities and scope
-- numbers used in SPARK cross references.
Nrefs : Nat := Xrefs.Last;
@@ -384,7 +381,7 @@ package body SPARK_Specific is
Rnums : array (0 .. Nrefs + Nrefs_Add) of Nat;
-- This array contains numbers of references in the Xrefs table. This
-- list is sorted in output order. The extra 0'th entry is convenient
- -- for the call to sort. When we sort the table, we move the entries in
+ -- for the call to sort. When we sort the table, we move the indices in
-- Rnums around, but we do not move the original table entries.
---------------------
@@ -455,7 +452,9 @@ package body SPARK_Specific is
end if;
end;
- when E_Loop_Parameter | E_In_Parameter =>
+ when E_In_Parameter
+ | E_Loop_Parameter
+ =>
Result := True;
when others =>
@@ -526,13 +525,6 @@ package body SPARK_Specific is
if Ekind (E) in Overloadable_Kind then
return Typ = 's';
- -- Objects of task or protected types are not SPARK references
-
- elsif Present (Etype (E))
- and then Ekind (Etype (E)) in Concurrent_Kind
- then
- return False;
-
-- In all other cases, result is true for reference/modify cases,
-- and false for all other cases.
@@ -557,7 +549,7 @@ package body SPARK_Specific is
-- Lt --
--------
- function Lt (Op1, Op2 : Natural) return Boolean is
+ function Lt (Op1 : Natural; Op2 : Natural) return Boolean is
T1 : constant Xref_Entry := Xrefs.Table (Rnums (Nat (Op1)));
T2 : constant Xref_Entry := Xrefs.Table (Rnums (Nat (Op2)));
@@ -591,6 +583,8 @@ package body SPARK_Specific is
-- Both entities must be equal at this point
pragma Assert (T1.Key.Ent = T2.Key.Ent);
+ pragma Assert (T1.Key.Ent_Scope = T2.Key.Ent_Scope);
+ pragma Assert (T1.Ent_Scope_File = T2.Ent_Scope_File);
-- Fourth test: if reference is in same unit as entity definition,
-- sort first.
@@ -689,7 +683,7 @@ package body SPARK_Specific is
Col : Nat;
From_Index : Xref_Index;
Line : Nat;
- Loc : Source_Ptr;
+ Prev_Loc : Source_Ptr;
Prev_Typ : Character;
Ref_Count : Nat;
Ref_Id : Entity_Id;
@@ -707,18 +701,13 @@ package body SPARK_Specific is
end;
end loop;
- -- Set up the pointer vector for the sort
-
- for Index in 1 .. Nrefs loop
- Rnums (Index) := Index;
- end loop;
-
- for Index in Drefs.First .. Drefs.Last loop
- Xrefs.Append (Drefs.Table (Index));
-
- Nrefs := Nrefs + 1;
- Rnums (Nrefs) := Xrefs.Last;
- end loop;
+ declare
+ Drefs_Table : Drefs.Table_Type
+ renames Drefs.Table (Drefs.First .. Drefs.Last);
+ begin
+ Xrefs.Append_All (Xrefs.Table_Type (Drefs_Table));
+ Nrefs := Nrefs + Drefs_Table'Length;
+ end;
-- Capture the definition Sloc values. As in the case of normal cross
-- references, we have to wait until now to get the correct value.
@@ -736,7 +725,7 @@ package body SPARK_Specific is
for Index in 1 .. Ref_Count loop
declare
- Ref : Xref_Key renames Xrefs.Table (Rnums (Index)).Key;
+ Ref : Xref_Key renames Xrefs.Table (Index).Key;
begin
if SPARK_Entities (Ekind (Ref.Ent))
@@ -751,7 +740,7 @@ package body SPARK_Specific is
and then Get_Scope_Num (Ref.Ref_Scope) /= No_Scope
then
Nrefs := Nrefs + 1;
- Rnums (Nrefs) := Rnums (Index);
+ Rnums (Nrefs) := Index;
end if;
end;
end loop;
@@ -771,9 +760,7 @@ package body SPARK_Specific is
Nrefs := 1;
for Index in 2 .. Ref_Count loop
- if Xrefs.Table (Rnums (Index)) /=
- Xrefs.Table (Rnums (Nrefs))
- then
+ if Xrefs.Table (Rnums (Index)) /= Xrefs.Table (Rnums (Nrefs)) then
Nrefs := Nrefs + 1;
Rnums (Nrefs) := Rnums (Index);
end if;
@@ -786,7 +773,7 @@ package body SPARK_Specific is
Ref_Count := Nrefs;
Nrefs := 0;
- Loc := No_Location;
+ Prev_Loc := No_Location;
Prev_Typ := 'm';
for Index in 1 .. Ref_Count loop
@@ -794,10 +781,10 @@ package body SPARK_Specific is
Ref : Xref_Key renames Xrefs.Table (Rnums (Index)).Key;
begin
- if Ref.Loc /= Loc
+ if Ref.Loc /= Prev_Loc
or else (Prev_Typ = 'm' and then Ref.Typ = 'r')
then
- Loc := Ref.Loc;
+ Prev_Loc := Ref.Loc;
Prev_Typ := Ref.Typ;
Nrefs := Nrefs + 1;
Rnums (Nrefs) := Rnums (Index);
@@ -857,8 +844,8 @@ package body SPARK_Specific is
Line := 0;
Col := 0;
else
- Line := Int (Get_Logical_Line_Number (Ref_Entry.Def));
- Col := Int (Get_Column_Number (Ref_Entry.Def));
+ Line := Nat (Get_Logical_Line_Number (Ref_Entry.Def));
+ Col := Nat (Get_Column_Number (Ref_Entry.Def));
end if;
-- References to constant objects without variable inputs (see
@@ -882,9 +869,9 @@ package body SPARK_Specific is
Entity_Col => Col,
File_Num => Dependency_Num (Ref.Lun),
Scope_Num => Get_Scope_Num (Ref.Ref_Scope),
- Line => Int (Get_Logical_Line_Number (Ref.Loc)),
+ Line => Nat (Get_Logical_Line_Number (Ref.Loc)),
Rtype => Typ,
- Col => Int (Get_Column_Number (Ref.Loc))));
+ Col => Nat (Get_Column_Number (Ref.Loc))));
end;
end loop;
@@ -904,8 +891,19 @@ package body SPARK_Specific is
(Sdep_Table : Unit_Ref_Table;
Num_Sdep : Nat)
is
- D1 : Nat;
- D2 : Nat;
+ Sdep : Pos;
+ Sdep_Next : Pos;
+ -- Index of the current and next source dependency
+
+ Sdep_File : Pos;
+ -- Index of the file to which the scopes need to be assigned; for
+ -- library-level instances of generic units this points to the unit
+ -- of the body, because this is where references are assigned to.
+
+ Ubody : Unit_Number_Type;
+ Uspec : Unit_Number_Type;
+ -- Unit numbers for the dependency spec and possibly its body (only in
+ -- the case of library-level instance of a generic package).
begin
-- Cross-references should have been computed first
@@ -916,36 +914,87 @@ package body SPARK_Specific is
-- Generate file and scope SPARK cross-reference information
- D1 := 1;
- while D1 <= Num_Sdep loop
+ Sdep := 1;
+ while Sdep <= Num_Sdep loop
- -- In rare cases, when treating the library-level instantiation of a
- -- generic, two consecutive units refer to the same compilation unit
- -- node and entity. In that case, treat them as a single unit for the
- -- sake of SPARK cross references by passing to Add_SPARK_File.
+ -- Skip dependencies with no entity node, e.g. configuration files
+ -- with pragmas (.adc) or target description (.atp), since they
+ -- present no interest for SPARK cross references.
+
+ if No (Cunit_Entity (Sdep_Table (Sdep))) then
+ Sdep_Next := Sdep + 1;
+
+ -- For library-level instantiation of a generic, two consecutive
+ -- units refer to the same compilation unit node and entity (one to
+ -- body, one to spec). In that case, treat them as a single unit for
+ -- the sake of SPARK cross references by passing to Add_SPARK_File.
- if D1 < Num_Sdep
- and then Cunit_Entity (Sdep_Table (D1)) =
- Cunit_Entity (Sdep_Table (D1 + 1))
- then
- D2 := D1 + 1;
else
- D2 := D1;
- end if;
+ if Sdep < Num_Sdep
+ and then Cunit_Entity (Sdep_Table (Sdep)) =
+ Cunit_Entity (Sdep_Table (Sdep + 1))
+ then
+ declare
+ Cunit1 : Node_Id renames Cunit (Sdep_Table (Sdep));
+ Cunit2 : Node_Id renames Cunit (Sdep_Table (Sdep + 1));
+
+ begin
+ -- Both Cunits point to compilation unit nodes
+
+ pragma Assert
+ (Nkind (Cunit1) = N_Compilation_Unit
+ and then Nkind (Cunit2) = N_Compilation_Unit);
+
+ -- Do not depend on the sorting order, which is based on
+ -- Unit_Name, and for library-level instances of nested
+ -- generic packages they are equal.
+
+ -- If declaration comes before the body
+
+ if Nkind (Unit (Cunit1)) = N_Package_Declaration
+ and then Nkind (Unit (Cunit2)) = N_Package_Body
+ then
+ Uspec := Sdep_Table (Sdep);
+ Ubody := Sdep_Table (Sdep + 1);
+
+ Sdep_File := Sdep + 1;
+
+ -- If body comes before declaration
+
+ elsif Nkind (Unit (Cunit1)) = N_Package_Body
+ and then Nkind (Unit (Cunit2)) = N_Package_Declaration
+ then
+ Uspec := Sdep_Table (Sdep + 1);
+ Ubody := Sdep_Table (Sdep);
+
+ Sdep_File := Sdep;
+
+ -- Otherwise it is an error
+
+ else
+ raise Program_Error;
+ end if;
+
+ Sdep_Next := Sdep + 2;
+ end;
- -- Some files do not correspond to Ada units, and as such present no
- -- interest for SPARK cross references. Skip these files, as printing
- -- their name may require printing the full name with spaces, which
- -- is not handled in the code doing I/O of SPARK cross references.
+ -- ??? otherwise?
+
+ else
+ Uspec := Sdep_Table (Sdep);
+ Ubody := No_Unit;
+
+ Sdep_File := Sdep;
+ Sdep_Next := Sdep + 1;
+ end if;
- if Present (Cunit_Entity (Sdep_Table (D1))) then
Add_SPARK_File
- (Ubody => Sdep_Table (D1),
- Uspec => Sdep_Table (D2),
- Dspec => D2);
+ (Uspec => Uspec,
+ Ubody => Ubody,
+ Dspec => Sdep_File);
end if;
- D1 := D2 + 1;
+ Sdep := Sdep_Next;
end loop;
-- Fill in the spec information when relevant
@@ -1002,30 +1051,6 @@ package body SPARK_Specific is
Add_SPARK_Xrefs;
end Collect_SPARK_Xrefs;
- --------------------------------
- -- Detect_And_Add_SPARK_Scope --
- --------------------------------
-
- procedure Detect_And_Add_SPARK_Scope (N : Node_Id) is
- begin
- if Nkind_In (N, N_Entry_Body, -- entries
- N_Entry_Declaration)
- or else
- Nkind_In (N, N_Package_Body, -- packages
- N_Package_Body_Stub,
- N_Package_Declaration)
- or else
- Nkind_In (N, N_Subprogram_Body, -- subprograms
- N_Subprogram_Body_Stub,
- N_Subprogram_Declaration)
- or else
- Nkind_In (N, N_Task_Body, -- tasks
- N_Task_Body_Stub)
- then
- Add_SPARK_Scope (N);
- end if;
- end Detect_And_Add_SPARK_Scope;
-
-------------------------------------
-- Enclosing_Subprogram_Or_Package --
-------------------------------------
@@ -1033,63 +1058,44 @@ package body SPARK_Specific is
function Enclosing_Subprogram_Or_Library_Package
(N : Node_Id) return Entity_Id
is
- Result : Entity_Id;
+ Context : Entity_Id;
begin
-- If N is the defining identifier for a subprogram, then return the
-- enclosing subprogram or package, not this subprogram.
if Nkind_In (N, N_Defining_Identifier, N_Defining_Operator_Symbol)
- and then Nkind (Parent (N)) in N_Subprogram_Specification
+ and then (Ekind (N) in Entry_Kind
+ or else Ekind (N) = E_Subprogram_Body
+ or else Ekind (N) in Generic_Subprogram_Kind
+ or else Ekind (N) in Subprogram_Kind)
then
- Result := Parent (Parent (Parent (N)));
+ Context := Parent (Unit_Declaration_Node (N));
- -- If this was a library-level subprogram then replace Result with
+ -- If this was a library-level subprogram then replace Context with
-- its Unit, which points to N_Subprogram_* node.
- if Nkind (Result) = N_Compilation_Unit then
- Result := Unit (Result);
+ if Nkind (Context) = N_Compilation_Unit then
+ Context := Unit (Context);
end if;
else
- Result := N;
+ Context := N;
end if;
- while Present (Result) loop
- case Nkind (Result) is
- when N_Package_Specification =>
-
+ while Present (Context) loop
+ case Nkind (Context) is
+ when N_Package_Body
+ | N_Package_Specification
+ =>
-- Only return a library-level package
- if Is_Library_Level_Entity (Defining_Entity (Result)) then
- Result := Defining_Entity (Result);
+ if Is_Library_Level_Entity (Defining_Entity (Context)) then
+ Context := Defining_Entity (Context);
exit;
else
- Result := Parent (Result);
+ Context := Parent (Context);
end if;
- when N_Package_Body =>
-
- -- Only return a library-level package
-
- if Is_Library_Level_Entity (Defining_Entity (Result)) then
- Result := Defining_Entity (Result);
- exit;
- else
- Result := Parent (Result);
- end if;
-
- when N_Subprogram_Specification =>
- Result := Defining_Unit_Name (Result);
- exit;
-
- when N_Subprogram_Declaration =>
- Result := Defining_Unit_Name (Specification (Result));
- exit;
-
- when N_Subprogram_Body =>
- Result := Defining_Unit_Name (Specification (Result));
- exit;
-
when N_Pragma =>
-- The enclosing subprogram for a precondition, postcondition,
@@ -1097,43 +1103,47 @@ package body SPARK_Specific is
-- pragma (skipping any other pragmas between this pragma and
-- this declaration.
- while Nkind (Result) = N_Pragma
- and then Is_List_Member (Result)
- and then Present (Prev (Result))
+ while Nkind (Context) = N_Pragma
+ and then Is_List_Member (Context)
+ and then Present (Prev (Context))
loop
- Result := Prev (Result);
+ Context := Prev (Context);
end loop;
- if Nkind (Result) = N_Pragma then
- Result := Parent (Result);
+ if Nkind (Context) = N_Pragma then
+ Context := Parent (Context);
end if;
- when N_Entry_Body =>
- Result := Defining_Identifier (Result);
- exit;
-
- when N_Task_Body =>
- Result := Defining_Identifier (Result);
+ when N_Entry_Body
+ | N_Entry_Declaration
+ | N_Protected_Type_Declaration
+ | N_Subprogram_Body
+ | N_Subprogram_Declaration
+ | N_Subprogram_Specification
+ | N_Task_Body
+ | N_Task_Type_Declaration
+ =>
+ Context := Defining_Entity (Context);
exit;
when others =>
- Result := Parent (Result);
+ Context := Parent (Context);
end case;
end loop;
- if Nkind (Result) = N_Defining_Program_Unit_Name then
- Result := Defining_Identifier (Result);
+ if Nkind (Context) = N_Defining_Program_Unit_Name then
+ Context := Defining_Identifier (Context);
end if;
-- Do not return a scope without a proper location
- if Present (Result)
- and then Sloc (Result) = No_Location
+ if Present (Context)
+ and then Sloc (Context) = No_Location
then
return Empty;
end if;
- return Result;
+ return Context;
end Enclosing_Subprogram_Or_Library_Package;
-----------------
@@ -1175,20 +1185,16 @@ package body SPARK_Specific is
-- Local variables
- Loc : constant Source_Ptr := Sloc (N);
- Index : Nat;
- Ref_Scope : Entity_Id;
+ Loc : constant Source_Ptr := Sloc (N);
-- Start of processing for Generate_Dereference
begin
-
if Loc > No_Location then
Drefs.Increment_Last;
- Index := Drefs.Last;
declare
- Deref_Entry : Xref_Entry renames Drefs.Table (Index);
+ Deref_Entry : Xref_Entry renames Drefs.Table (Drefs.Last);
Deref : Xref_Key renames Deref_Entry.Key;
begin
@@ -1196,24 +1202,24 @@ package body SPARK_Specific is
Create_Heap;
end if;
- Ref_Scope := Enclosing_Subprogram_Or_Library_Package (N);
-
Deref.Ent := Heap;
Deref.Loc := Loc;
Deref.Typ := Typ;
- -- It is as if the special "Heap" was defined in every scope where
- -- it is referenced.
+ -- It is as if the special "Heap" was defined in the main unit,
+ -- in the scope of the entity for the main unit. This single
+ -- definition point is required to ensure that sorting cross
+ -- references works for "Heap" references as well.
- Deref.Eun := Get_Code_Unit (Loc);
- Deref.Lun := Get_Code_Unit (Loc);
+ Deref.Eun := Main_Unit;
+ Deref.Lun := Get_Top_Level_Code_Unit (Loc);
- Deref.Ref_Scope := Ref_Scope;
- Deref.Ent_Scope := Ref_Scope;
+ Deref.Ref_Scope := Enclosing_Subprogram_Or_Library_Package (N);
+ Deref.Ent_Scope := Cunit_Entity (Main_Unit);
Deref_Entry.Def := No_Location;
- Deref_Entry.Ent_Scope_File := Get_Code_Unit (N);
+ Deref_Entry.Ent_Scope_File := Main_Unit;
end;
end if;
end Generate_Dereference;
@@ -1224,320 +1230,312 @@ package body SPARK_Specific is
procedure Traverse_Compilation_Unit
(CU : Node_Id;
- Process : Node_Processing;
Inside_Stubs : Boolean)
is
- Lu : Node_Id;
+ procedure Traverse_Block (N : Node_Id);
+ procedure Traverse_Declaration_Or_Statement (N : Node_Id);
+ procedure Traverse_Declarations_And_HSS (N : Node_Id);
+ procedure Traverse_Declarations_Or_Statements (L : List_Id);
+ procedure Traverse_Handled_Statement_Sequence (N : Node_Id);
+ procedure Traverse_Package_Body (N : Node_Id);
+ procedure Traverse_Visible_And_Private_Parts (N : Node_Id);
+ procedure Traverse_Protected_Body (N : Node_Id);
+ procedure Traverse_Subprogram_Body (N : Node_Id);
+ procedure Traverse_Task_Body (N : Node_Id);
+
+ -- Traverse corresponding construct, calling Process on all declarations
- begin
- -- Get Unit (checking case of subunit)
+ --------------------
+ -- Traverse_Block --
+ --------------------
- Lu := Unit (CU);
+ procedure Traverse_Block (N : Node_Id) renames
+ Traverse_Declarations_And_HSS;
- if Nkind (Lu) = N_Subunit then
- Lu := Proper_Body (Lu);
- end if;
+ ---------------------------------------
+ -- Traverse_Declaration_Or_Statement --
+ ---------------------------------------
- -- Do not add scopes for generic units
+ procedure Traverse_Declaration_Or_Statement (N : Node_Id) is
+ function Traverse_Stub (N : Node_Id) return Boolean;
+ -- Returns True iff stub N should be traversed
- if Nkind (Lu) = N_Package_Body
- and then Ekind (Corresponding_Spec (Lu)) in Generic_Unit_Kind
- then
- return;
- end if;
+ function Traverse_Stub (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (Nkind_In (N, N_Package_Body_Stub,
+ N_Protected_Body_Stub,
+ N_Subprogram_Body_Stub,
+ N_Task_Body_Stub));
- -- Call Process on all declarations
+ return Inside_Stubs and then Present (Library_Unit (N));
+ end Traverse_Stub;
- if Nkind (Lu) in N_Declaration
- or else Nkind (Lu) in N_Later_Decl_Item
- then
- Process (Lu);
- end if;
+ -- Start of processing for Traverse_Declaration_Or_Statement
- -- Traverse the unit
+ begin
+ case Nkind (N) is
+ when N_Package_Declaration =>
+ Traverse_Visible_And_Private_Parts (Specification (N));
- Traverse_Declaration_Or_Statement (Lu, Process, Inside_Stubs);
- end Traverse_Compilation_Unit;
+ when N_Package_Body =>
+ Traverse_Package_Body (N);
- ---------------------------------------
- -- Traverse_Declaration_Or_Statement --
- ---------------------------------------
+ when N_Package_Body_Stub =>
+ if Traverse_Stub (N) then
+ Traverse_Package_Body (Get_Body_From_Stub (N));
+ end if;
- procedure Traverse_Declaration_Or_Statement
- (N : Node_Id;
- Process : Node_Processing;
- Inside_Stubs : Boolean)
- is
- begin
- case Nkind (N) is
- when N_Package_Declaration =>
- declare
- Spec : constant Node_Id := Specification (N);
- begin
- Traverse_Declarations_Or_Statements
- (Visible_Declarations (Spec), Process, Inside_Stubs);
- Traverse_Declarations_Or_Statements
- (Private_Declarations (Spec), Process, Inside_Stubs);
- end;
+ when N_Subprogram_Body =>
+ Traverse_Subprogram_Body (N);
- when N_Package_Body =>
- if Ekind (Defining_Entity (N)) /= E_Generic_Package then
- Traverse_Package_Body (N, Process, Inside_Stubs);
- end if;
+ when N_Entry_Body =>
+ Traverse_Subprogram_Body (N);
- when N_Package_Body_Stub =>
- if Present (Library_Unit (N)) then
- declare
- Body_N : constant Node_Id := Get_Body_From_Stub (N);
- begin
- if Inside_Stubs
- and then
- Ekind (Defining_Entity (Body_N)) /= E_Generic_Package
- then
- Traverse_Package_Body (Body_N, Process, Inside_Stubs);
- end if;
- end;
- end if;
+ when N_Subprogram_Body_Stub =>
+ if Traverse_Stub (N) then
+ Traverse_Subprogram_Body (Get_Body_From_Stub (N));
+ end if;
- when N_Subprogram_Declaration =>
- null;
+ when N_Protected_Body =>
+ Traverse_Protected_Body (N);
- when N_Entry_Body | N_Subprogram_Body =>
- if not Is_Generic_Subprogram (Defining_Entity (N)) then
- Traverse_Subprogram_Body (N, Process, Inside_Stubs);
- end if;
+ when N_Protected_Body_Stub =>
+ if Traverse_Stub (N) then
+ Traverse_Protected_Body (Get_Body_From_Stub (N));
+ end if;
- when N_Subprogram_Body_Stub =>
- if Present (Library_Unit (N)) then
- declare
- Body_N : constant Node_Id := Get_Body_From_Stub (N);
- begin
- if Inside_Stubs
- and then
- not Is_Generic_Subprogram (Defining_Entity (Body_N))
- then
- Traverse_Subprogram_Body (Body_N, Process, Inside_Stubs);
- end if;
- end;
- end if;
+ when N_Protected_Type_Declaration =>
+ Traverse_Visible_And_Private_Parts (Protected_Definition (N));
- when N_Protected_Body =>
- Traverse_Protected_Body (N, Process, Inside_Stubs);
+ when N_Task_Definition =>
+ Traverse_Visible_And_Private_Parts (N);
- when N_Protected_Body_Stub =>
- if Present (Library_Unit (N)) then
- declare
- Body_N : constant Node_Id := Get_Body_From_Stub (N);
- begin
- if Inside_Stubs then
- Traverse_Declarations_Or_Statements
- (Declarations (Body_N), Process, Inside_Stubs);
- end if;
- end;
- end if;
+ when N_Task_Body =>
+ Traverse_Task_Body (N);
- when N_Protected_Type_Declaration | N_Single_Protected_Declaration =>
- declare
- Def : constant Node_Id := Protected_Definition (N);
- begin
- Traverse_Declarations_Or_Statements
- (Visible_Declarations (Def), Process, Inside_Stubs);
- Traverse_Declarations_Or_Statements
- (Private_Declarations (Def), Process, Inside_Stubs);
- end;
+ when N_Task_Body_Stub =>
+ if Traverse_Stub (N) then
+ Traverse_Task_Body (Get_Body_From_Stub (N));
+ end if;
- when N_Task_Definition =>
- Traverse_Declarations_Or_Statements
- (Visible_Declarations (N), Process, Inside_Stubs);
- Traverse_Declarations_Or_Statements
- (Private_Declarations (N), Process, Inside_Stubs);
+ when N_Block_Statement =>
+ Traverse_Block (N);
- when N_Task_Body =>
- Traverse_Declarations_Or_Statements
- (Declarations (N), Process, Inside_Stubs);
- Traverse_Handled_Statement_Sequence
- (Handled_Statement_Sequence (N), Process, Inside_Stubs);
+ when N_If_Statement =>
- when N_Task_Body_Stub =>
- if Present (Library_Unit (N)) then
- declare
- Body_N : constant Node_Id := Get_Body_From_Stub (N);
- begin
- if Inside_Stubs then
- Traverse_Declarations_Or_Statements
- (Declarations (Body_N), Process, Inside_Stubs);
- Traverse_Handled_Statement_Sequence
- (Handled_Statement_Sequence (Body_N), Process,
- Inside_Stubs);
- end if;
- end;
- end if;
+ -- Traverse the statements in the THEN part
- when N_Block_Statement =>
- Traverse_Declarations_Or_Statements
- (Declarations (N), Process, Inside_Stubs);
- Traverse_Handled_Statement_Sequence
- (Handled_Statement_Sequence (N), Process, Inside_Stubs);
+ Traverse_Declarations_Or_Statements (Then_Statements (N));
- when N_If_Statement =>
+ -- Loop through ELSIF parts if present
- -- Traverse the statements in the THEN part
+ if Present (Elsif_Parts (N)) then
+ declare
+ Elif : Node_Id := First (Elsif_Parts (N));
- Traverse_Declarations_Or_Statements
- (Then_Statements (N), Process, Inside_Stubs);
+ begin
+ while Present (Elif) loop
+ Traverse_Declarations_Or_Statements
+ (Then_Statements (Elif));
+ Next (Elif);
+ end loop;
+ end;
+ end if;
- -- Loop through ELSIF parts if present
+ -- Finally traverse the ELSE statements if present
- if Present (Elsif_Parts (N)) then
- declare
- Elif : Node_Id := First (Elsif_Parts (N));
+ Traverse_Declarations_Or_Statements (Else_Statements (N));
+
+ when N_Case_Statement =>
+
+ -- Process case branches
+ declare
+ Alt : Node_Id := First (Alternatives (N));
begin
- while Present (Elif) loop
- Traverse_Declarations_Or_Statements
- (Then_Statements (Elif), Process, Inside_Stubs);
- Next (Elif);
+ loop
+ Traverse_Declarations_Or_Statements (Statements (Alt));
+ Next (Alt);
+ exit when No (Alt);
end loop;
end;
+
+ when N_Extended_Return_Statement =>
+ Traverse_Handled_Statement_Sequence
+ (Handled_Statement_Sequence (N));
+
+ when N_Loop_Statement =>
+ Traverse_Declarations_Or_Statements (Statements (N));
+
+ -- Generic declarations are ignored
+
+ when others =>
+ null;
+ end case;
+ end Traverse_Declaration_Or_Statement;
+
+ -----------------------------------
+ -- Traverse_Declarations_And_HSS --
+ -----------------------------------
+
+ procedure Traverse_Declarations_And_HSS (N : Node_Id) is
+ begin
+ Traverse_Declarations_Or_Statements (Declarations (N));
+ Traverse_Handled_Statement_Sequence (Handled_Statement_Sequence (N));
+ end Traverse_Declarations_And_HSS;
+
+ -----------------------------------------
+ -- Traverse_Declarations_Or_Statements --
+ -----------------------------------------
+
+ procedure Traverse_Declarations_Or_Statements (L : List_Id) is
+ N : Node_Id;
+
+ begin
+ -- Loop through statements or declarations
+
+ N := First (L);
+ while Present (N) loop
+
+ -- Call Process on all declarations
+
+ if Nkind (N) in N_Declaration
+ or else Nkind (N) in N_Later_Decl_Item
+ or else Nkind (N) = N_Entry_Body
+ then
+ Process (N);
end if;
- -- Finally traverse the ELSE statements if present
+ Traverse_Declaration_Or_Statement (N);
- Traverse_Declarations_Or_Statements
- (Else_Statements (N), Process, Inside_Stubs);
+ Next (N);
+ end loop;
+ end Traverse_Declarations_Or_Statements;
- when N_Case_Statement =>
+ -----------------------------------------
+ -- Traverse_Handled_Statement_Sequence --
+ -----------------------------------------
- -- Process case branches
+ procedure Traverse_Handled_Statement_Sequence (N : Node_Id) is
+ Handler : Node_Id;
- declare
- Alt : Node_Id;
- begin
- Alt := First (Alternatives (N));
- while Present (Alt) loop
- Traverse_Declarations_Or_Statements
- (Statements (Alt), Process, Inside_Stubs);
- Next (Alt);
+ begin
+ if Present (N) then
+ Traverse_Declarations_Or_Statements (Statements (N));
+
+ if Present (Exception_Handlers (N)) then
+ Handler := First (Exception_Handlers (N));
+ while Present (Handler) loop
+ Traverse_Declarations_Or_Statements (Statements (Handler));
+ Next (Handler);
end loop;
- end;
+ end if;
+ end if;
+ end Traverse_Handled_Statement_Sequence;
- when N_Extended_Return_Statement =>
- Traverse_Handled_Statement_Sequence
- (Handled_Statement_Sequence (N), Process, Inside_Stubs);
+ ---------------------------
+ -- Traverse_Package_Body --
+ ---------------------------
- when N_Loop_Statement =>
- Traverse_Declarations_Or_Statements
- (Statements (N), Process, Inside_Stubs);
+ procedure Traverse_Package_Body (N : Node_Id) is
+ Spec_E : constant Entity_Id := Unique_Defining_Entity (N);
- -- Generic declarations are ignored
+ begin
+ case Ekind (Spec_E) is
+ when E_Package =>
+ Traverse_Declarations_And_HSS (N);
- when others =>
- null;
- end case;
- end Traverse_Declaration_Or_Statement;
+ when E_Generic_Package =>
+ null;
- -----------------------------------------
- -- Traverse_Declarations_Or_Statements --
- -----------------------------------------
+ when others =>
+ raise Program_Error;
+ end case;
+ end Traverse_Package_Body;
- procedure Traverse_Declarations_Or_Statements
- (L : List_Id;
- Process : Node_Processing;
- Inside_Stubs : Boolean)
- is
- N : Node_Id;
+ -----------------------------
+ -- Traverse_Protected_Body --
+ -----------------------------
- begin
- -- Loop through statements or declarations
+ procedure Traverse_Protected_Body (N : Node_Id) is
+ begin
+ Traverse_Declarations_Or_Statements (Declarations (N));
+ end Traverse_Protected_Body;
- N := First (L);
- while Present (N) loop
- -- Call Process on all declarations
+ ------------------------------
+ -- Traverse_Subprogram_Body --
+ ------------------------------
- if Nkind (N) in N_Declaration
- or else
- Nkind (N) in N_Later_Decl_Item
- or else
- Nkind (N) = N_Entry_Body
- then
- Process (N);
- end if;
+ procedure Traverse_Subprogram_Body (N : Node_Id) is
+ Spec_E : constant Entity_Id := Unique_Defining_Entity (N);
- Traverse_Declaration_Or_Statement (N, Process, Inside_Stubs);
+ begin
+ case Ekind (Spec_E) is
+ when Entry_Kind
+ | E_Function
+ | E_Procedure
+ =>
+ Traverse_Declarations_And_HSS (N);
- Next (N);
- end loop;
- end Traverse_Declarations_Or_Statements;
+ when Generic_Subprogram_Kind =>
+ null;
- -----------------------------------------
- -- Traverse_Handled_Statement_Sequence --
- -----------------------------------------
+ when others =>
+ raise Program_Error;
+ end case;
+ end Traverse_Subprogram_Body;
- procedure Traverse_Handled_Statement_Sequence
- (N : Node_Id;
- Process : Node_Processing;
- Inside_Stubs : Boolean)
- is
- Handler : Node_Id;
+ ------------------------
+ -- Traverse_Task_Body --
+ ------------------------
+
+ procedure Traverse_Task_Body (N : Node_Id) renames
+ Traverse_Declarations_And_HSS;
+
+ ----------------------------------------
+ -- Traverse_Visible_And_Private_Parts --
+ ----------------------------------------
+
+ procedure Traverse_Visible_And_Private_Parts (N : Node_Id) is
+ begin
+ Traverse_Declarations_Or_Statements (Visible_Declarations (N));
+ Traverse_Declarations_Or_Statements (Private_Declarations (N));
+ end Traverse_Visible_And_Private_Parts;
+
+ -- Local variables
+
+ Lu : Node_Id;
+
+ -- Start of processing for Traverse_Compilation_Unit
begin
- if Present (N) then
- Traverse_Declarations_Or_Statements
- (Statements (N), Process, Inside_Stubs);
-
- if Present (Exception_Handlers (N)) then
- Handler := First (Exception_Handlers (N));
- while Present (Handler) loop
- Traverse_Declarations_Or_Statements
- (Statements (Handler), Process, Inside_Stubs);
- Next (Handler);
- end loop;
- end if;
+ -- Get Unit (checking case of subunit)
+
+ Lu := Unit (CU);
+
+ if Nkind (Lu) = N_Subunit then
+ Lu := Proper_Body (Lu);
+ end if;
+
+ -- Do not add scopes for generic units
+
+ if Nkind (Lu) = N_Package_Body
+ and then Ekind (Corresponding_Spec (Lu)) in Generic_Unit_Kind
+ then
+ return;
end if;
- end Traverse_Handled_Statement_Sequence;
- ---------------------------
- -- Traverse_Package_Body --
- ---------------------------
+ -- Call Process on all declarations
- procedure Traverse_Package_Body
- (N : Node_Id;
- Process : Node_Processing;
- Inside_Stubs : Boolean) is
- begin
- Traverse_Declarations_Or_Statements
- (Declarations (N), Process, Inside_Stubs);
- Traverse_Handled_Statement_Sequence
- (Handled_Statement_Sequence (N), Process, Inside_Stubs);
- end Traverse_Package_Body;
-
- -----------------------------
- -- Traverse_Protected_Body --
- -----------------------------
-
- procedure Traverse_Protected_Body
- (N : Node_Id;
- Process : Node_Processing;
- Inside_Stubs : Boolean) is
- begin
- Traverse_Declarations_Or_Statements
- (Declarations (N), Process, Inside_Stubs);
- end Traverse_Protected_Body;
+ if Nkind (Lu) in N_Declaration
+ or else Nkind (Lu) in N_Later_Decl_Item
+ then
+ Process (Lu);
+ end if;
- ------------------------------
- -- Traverse_Subprogram_Body --
- ------------------------------
+ -- Traverse the unit
- procedure Traverse_Subprogram_Body
- (N : Node_Id;
- Process : Node_Processing;
- Inside_Stubs : Boolean)
- is
- begin
- Traverse_Declarations_Or_Statements
- (Declarations (N), Process, Inside_Stubs);
- Traverse_Handled_Statement_Sequence
- (Handled_Statement_Sequence (N), Process, Inside_Stubs);
- end Traverse_Subprogram_Body;
+ Traverse_Declaration_Or_Statement (Lu);
+ end Traverse_Compilation_Unit;
end SPARK_Specific;
diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb
index 4751cd3266..4d9fe6919e 100644
--- a/gcc/ada/lib-xref.adb
+++ b/gcc/ada/lib-xref.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -191,8 +191,7 @@ package body Lib.Xref is
Set_Has_Xref_Entry (Key.Ent);
- -- It was already in Xref_Set, so throw away the tentatively-added
- -- entry.
+ -- It was already in Xref_Set, so throw away the tentatively-added entry
else
Xrefs.Decrement_Last;
@@ -373,16 +372,16 @@ package body Lib.Xref is
Set_Ref : Boolean := True;
Force : Boolean := False)
is
- Actual_Typ : Character := Typ;
- Call : Node_Id;
- Def : Source_Ptr;
- Ent : Entity_Id;
- Ent_Scope : Entity_Id;
- Formal : Entity_Id;
- Kind : Entity_Kind;
- Nod : Node_Id;
- Ref : Source_Ptr;
- Ref_Scope : Entity_Id;
+ Actual_Typ : Character := Typ;
+ Call : Node_Id;
+ Def : Source_Ptr;
+ Ent : Entity_Id;
+ Ent_Scope : Entity_Id;
+ Formal : Entity_Id;
+ Kind : Entity_Kind;
+ Nod : Node_Id;
+ Ref : Source_Ptr;
+ Ref_Scope : Entity_Id;
function Get_Through_Renamings (E : Entity_Id) return Entity_Id;
-- Get the enclosing entity through renamings, which may come from
@@ -526,9 +525,10 @@ package body Lib.Xref is
P := Parent (P);
if Nkind (P) = N_Pragma then
- if Nam_In (Pragma_Name (P), Name_Warnings,
- Name_Unmodified,
- Name_Unreferenced)
+ if Nam_In (Pragma_Name_Unmapped (P),
+ Name_Warnings,
+ Name_Unmodified,
+ Name_Unreferenced)
then
return False;
end if;
@@ -842,6 +842,8 @@ package body Lib.Xref is
-- Check for pragma Unreferenced given and reference is within
-- this source unit (occasion for possible warning to be issued).
+ -- Note that the entity may be marked as unreferenced by pragma
+ -- Unused.
if Has_Unreferenced (E)
and then In_Same_Extended_Unit (E, N)
@@ -861,6 +863,14 @@ package body Lib.Xref is
elsif Is_On_LHS (N) then
null;
+ -- No warning if the reference is in a call that does not come
+ -- from source (e.g. a call to a controlled type primitive).
+
+ elsif not Comes_From_Source (Parent (N))
+ and then Nkind (Parent (N)) = N_Procedure_Call_Statement
+ then
+ null;
+
-- For entry formals, we want to place the warning message on the
-- corresponding entity in the accept statement. The current scope
-- is the body of the accept, so we find the formal whose name
@@ -876,8 +886,13 @@ package body Lib.Xref is
BE := First_Entity (Current_Scope);
while Present (BE) loop
if Chars (BE) = Chars (E) then
- Error_Msg_NE -- CODEFIX
- ("??pragma Unreferenced given for&!", N, BE);
+ if Has_Pragma_Unused (E) then
+ Error_Msg_NE -- CODEFIX
+ ("??pragma Unused given for&!", N, BE);
+ else
+ Error_Msg_NE -- CODEFIX
+ ("??pragma Unreferenced given for&!", N, BE);
+ end if;
exit;
end if;
@@ -887,6 +902,9 @@ package body Lib.Xref is
-- Here we issue the warning, since this is a real reference
+ elsif Has_Pragma_Unused (E) then
+ Error_Msg_NE -- CODEFIX
+ ("??pragma Unused given for&!", N, E);
else
Error_Msg_NE -- CODEFIX
("??pragma Unreferenced given for&!", N, E);
@@ -1076,11 +1094,11 @@ package body Lib.Xref is
((Ent => Ent,
Loc => Ref,
Typ => Actual_Typ,
- Eun => Get_Code_Unit (Def),
- Lun => Get_Code_Unit (Ref),
+ Eun => Get_Top_Level_Code_Unit (Def),
+ Lun => Get_Top_Level_Code_Unit (Ref),
Ref_Scope => Ref_Scope,
Ent_Scope => Ent_Scope),
- Ent_Scope_File => Get_Code_Unit (Ent));
+ Ent_Scope_File => Get_Top_Level_Code_Unit (Ent));
else
Ref := Original_Location (Sloc (Nod));
@@ -1174,8 +1192,7 @@ package body Lib.Xref is
while Present (Formal) loop
if Ekind (Formal) = E_In_Parameter then
- if Nkind (Parameter_Type (Parent (Formal)))
- = N_Access_Definition
+ if Nkind (Parameter_Type (Parent (Formal))) = N_Access_Definition
then
Generate_Reference (E, Formal, '^', False);
else
@@ -1220,6 +1237,21 @@ package body Lib.Xref is
return E;
end Get_Key;
+ ----------------------------
+ -- Has_Deferred_Reference --
+ ----------------------------
+
+ function Has_Deferred_Reference (Ent : Entity_Id) return Boolean is
+ begin
+ for J in Deferred_References.First .. Deferred_References.Last loop
+ if Deferred_References.Table (J).E = Ent then
+ return True;
+ end if;
+ end loop;
+
+ return False;
+ end Has_Deferred_Reference;
+
----------
-- Hash --
----------
@@ -1468,17 +1500,31 @@ package body Lib.Xref is
-- initialized with a tag-indeterminate call gets a subtype
-- of the classwide type during expansion. See if the original
-- type in the declaration is named, and return it instead
- -- of going to the root type.
+ -- of going to the root type. The expression may be a class-
+ -- wide function call whose result is on the secondary stack,
+ -- which forces the declaration to be rewritten as a renaming,
+ -- so examine the source declaration.
- if Ekind (Tref) = E_Class_Wide_Subtype
- and then Nkind (Parent (Ent)) = N_Object_Declaration
- and then
- Nkind (Original_Node (Object_Definition (Parent (Ent))))
- = N_Identifier
+ if Ekind (Tref) = E_Class_Wide_Subtype then
+ declare
+ Decl : constant Node_Id := Original_Node (Parent (Ent));
+ begin
+ if Nkind (Decl) = N_Object_Declaration
+ and then Is_Entity_Name
+ (Original_Node (Object_Definition (Decl)))
+ then
+ Tref :=
+ Entity (Original_Node (Object_Definition (Decl)));
+ end if;
+ end;
+
+ -- For a function that returns a class-wide type, Tref is
+ -- already correct.
+
+ elsif Is_Overloadable (Ent)
+ and then Is_Class_Wide_Type (Tref)
then
- Tref :=
- Entity
- (Original_Node ((Object_Definition (Parent (Ent)))));
+ return;
end if;
-- For anything else, exit
diff --git a/gcc/ada/lib-xref.ads b/gcc/ada/lib-xref.ads
index 33e20ee2ae..ecb70b60f1 100644
--- a/gcc/ada/lib-xref.ads
+++ b/gcc/ada/lib-xref.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -509,9 +509,9 @@ package Lib.Xref is
E_Void => ' ',
-- The following entities are not ones to which we gather the cross-
- -- references, since it does not make sense to do so (e.g. references to
- -- a package are to the spec, not the body) Indeed the occurrence of the
- -- body entity is considered to be a reference to the spec entity.
+ -- references, since it does not make sense to do so (e.g. references
+ -- to a package are to the spec, not the body). Indeed the occurrence of
+ -- the body entity is considered to be a reference to the spec entity.
E_Package_Body => ' ',
E_Protected_Body => ' ',
@@ -611,7 +611,12 @@ package Lib.Xref is
Table_Name => "Name_Deferred_References");
procedure Process_Deferred_References;
- -- This procedure is called from Frontend to process these table entries.
+ -- This procedure is called from Frontend to process these table entries
+
+ function Has_Deferred_Reference (Ent : Entity_Id) return Boolean;
+ -- Determine whether arbitrary entity Ent has a pending reference in order
+ -- to suppress premature warnings about useless assignments. See comments
+ -- in Analyze_Assignment in sem_ch5.adb.
-----------------------------
-- SPARK Xrefs Information --
@@ -634,16 +639,6 @@ package Lib.Xref is
-- This procedure is called to record a dereference. N is the location
-- of the dereference.
- type Node_Processing is access procedure (N : Node_Id);
-
- procedure Traverse_Compilation_Unit
- (CU : Node_Id;
- Process : Node_Processing;
- Inside_Stubs : Boolean);
- -- Call Process on all declarations in compilation unit CU. If
- -- Inside_Stubs is True, then the body of stubs is also traversed.
- -- Generic declarations are ignored.
-
procedure Collect_SPARK_Xrefs
(Sdep_Table : Unit_Ref_Table;
Num_Sdep : Nat);
@@ -656,6 +651,15 @@ package Lib.Xref is
-- the information collected in the tables in library package called
-- SPARK_Xrefs, and using routines in Lib.Util.
+ generic
+ with procedure Process (N : Node_Id) is <>;
+ procedure Traverse_Compilation_Unit
+ (CU : Node_Id;
+ Inside_Stubs : Boolean);
+ -- Call Process on all declarations within compilation unit CU. If
+ -- Inside_Stubs is True, then the body of stubs is also traversed.
+ -- Generic declarations are ignored.
+
end SPARK_Specific;
-----------------
@@ -696,7 +700,7 @@ package Lib.Xref is
-- the spec. The entity in the body is treated as a reference with type
-- 'b'. Similar handling for references to subprogram formals.
--
- -- The call has no effect if N is not in the extended main source unit
+ -- The call has no effect if N is not in the extended main source unit.
-- This check is omitted for type 'e' references (where it is useful to
-- have structural scoping information for other than the main source),
-- and for 'p' (since we want to pick up inherited primitive operations
diff --git a/gcc/ada/lib.adb b/gcc/ada/lib.adb
index 08866b2fb5..0ba9f9ad24 100644
--- a/gcc/ada/lib.adb
+++ b/gcc/ada/lib.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -38,6 +38,7 @@ with Csets; use Csets;
with Einfo; use Einfo;
with Fname; use Fname;
with Nlists; use Nlists;
+with Opt; use Opt;
with Output; use Output;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
@@ -68,9 +69,14 @@ package body Lib is
function Get_Code_Or_Source_Unit
(S : Source_Ptr;
- Unwind_Instances : Boolean) return Unit_Number_Type;
- -- Common code for Get_Code_Unit (get unit of instantiation for location)
- -- and Get_Source_Unit (get unit of template for location).
+ Unwind_Instances : Boolean;
+ Unwind_Subunits : Boolean) return Unit_Number_Type;
+ -- Common processing for routines Get_Code_Unit, Get_Source_Unit, and
+ -- Get_Top_Level_Code_Unit. Unwind_Instances is True when the unit for the
+ -- top-level instantiation should be returned instead of the unit for the
+ -- template, in the case of an instantiation. Unwind_Subunits is True when
+ -- the corresponding top-level unit should be returned instead of a
+ -- subunit, in the case of a subunit.
--------------------------------------------
-- Access Functions for Unit Table Fields --
@@ -254,18 +260,22 @@ package body Lib is
------------------------------
function Check_Same_Extended_Unit (S1, S2 : Source_Ptr) return SEU_Result is
- Sloc1 : Source_Ptr;
- Sloc2 : Source_Ptr;
- Sind1 : Source_File_Index;
- Sind2 : Source_File_Index;
- Inst1 : Source_Ptr;
- Inst2 : Source_Ptr;
- Unum1 : Unit_Number_Type;
- Unum2 : Unit_Number_Type;
- Unit1 : Node_Id;
- Unit2 : Node_Id;
- Depth1 : Nat;
- Depth2 : Nat;
+ Max_Iterations : constant Nat := Maximum_Instantiations * 2;
+ -- Limit to prevent a potential infinite loop
+
+ Counter : Nat := 0;
+ Depth1 : Nat;
+ Depth2 : Nat;
+ Inst1 : Source_Ptr;
+ Inst2 : Source_Ptr;
+ Sind1 : Source_File_Index;
+ Sind2 : Source_File_Index;
+ Sloc1 : Source_Ptr;
+ Sloc2 : Source_Ptr;
+ Unit1 : Node_Id;
+ Unit2 : Node_Id;
+ Unum1 : Unit_Number_Type;
+ Unum2 : Unit_Number_Type;
begin
if S1 = No_Location or else S2 = No_Location then
@@ -430,7 +440,20 @@ package body Lib is
return No;
<<Continue>>
- null;
+ Counter := Counter + 1;
+
+ -- Prevent looping forever
+
+ if Counter > Max_Iterations then
+ -- ??? Not quite right, but return a value to be able to generate
+ -- SCIL files and hope for the best.
+
+ if CodePeer_Mode then
+ return No;
+ else
+ raise Program_Error;
+ end if;
+ end if;
end loop;
end Check_Same_Extended_Unit;
@@ -573,7 +596,8 @@ package body Lib is
function Get_Code_Or_Source_Unit
(S : Source_Ptr;
- Unwind_Instances : Boolean) return Unit_Number_Type
+ Unwind_Instances : Boolean;
+ Unwind_Subunits : Boolean) return Unit_Number_Type
is
begin
-- Search table unless we have No_Location, which can happen if the
@@ -584,6 +608,7 @@ package body Lib is
declare
Source_File : Source_File_Index;
Source_Unit : Unit_Number_Type;
+ Unit_Node : Node_Id;
begin
Source_File := Get_Source_File_Index (S);
@@ -596,6 +621,21 @@ package body Lib is
Source_Unit := Unit (Source_File);
+ if Unwind_Subunits then
+ Unit_Node := Unit (Cunit (Source_Unit));
+
+ while Nkind (Unit_Node) = N_Subunit
+ and then Present (Corresponding_Stub (Unit_Node))
+ loop
+ Source_Unit :=
+ Get_Code_Or_Source_Unit
+ (Sloc (Corresponding_Stub (Unit_Node)),
+ Unwind_Instances => Unwind_Instances,
+ Unwind_Subunits => Unwind_Subunits);
+ Unit_Node := Unit (Cunit (Source_Unit));
+ end loop;
+ end if;
+
if Source_Unit /= No_Unit then
return Source_Unit;
end if;
@@ -615,8 +655,11 @@ package body Lib is
function Get_Code_Unit (S : Source_Ptr) return Unit_Number_Type is
begin
- return Get_Code_Or_Source_Unit (Top_Level_Location (S),
- Unwind_Instances => False);
+ return
+ Get_Code_Or_Source_Unit
+ (Top_Level_Location (S),
+ Unwind_Instances => False,
+ Unwind_Subunits => False);
end Get_Code_Unit;
function Get_Code_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type is
@@ -632,7 +675,6 @@ package body Lib is
begin
if N <= Compilation_Switches.Last then
return Compilation_Switches.Table (N);
-
else
return null;
end if;
@@ -691,7 +733,9 @@ package body Lib is
function Get_Source_Unit (S : Source_Ptr) return Unit_Number_Type is
begin
- return Get_Code_Or_Source_Unit (S, Unwind_Instances => True);
+ return
+ Get_Code_Or_Source_Unit
+ (S, Unwind_Instances => True, Unwind_Subunits => False);
end Get_Source_Unit;
function Get_Source_Unit (N : Node_Or_Entity_Id) return Unit_Number_Type is
@@ -699,6 +743,25 @@ package body Lib is
return Get_Source_Unit (Sloc (N));
end Get_Source_Unit;
+ -----------------------------
+ -- Get_Top_Level_Code_Unit --
+ -----------------------------
+
+ function Get_Top_Level_Code_Unit (S : Source_Ptr) return Unit_Number_Type is
+ begin
+ return
+ Get_Code_Or_Source_Unit
+ (Top_Level_Location (S),
+ Unwind_Instances => False,
+ Unwind_Subunits => True);
+ end Get_Top_Level_Code_Unit;
+
+ function Get_Top_Level_Code_Unit
+ (N : Node_Or_Entity_Id) return Unit_Number_Type is
+ begin
+ return Get_Top_Level_Code_Unit (Sloc (N));
+ end Get_Top_Level_Code_Unit;
+
--------------------------------
-- In_Extended_Main_Code_Unit --
--------------------------------
diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads
index 4e9471c43f..a6cfd5dff7 100644
--- a/gcc/ada/lib.ads
+++ b/gcc/ada/lib.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -261,7 +261,7 @@ package Lib is
-----------------
-- The units table has an entry for each unit (source file) read in by the
- -- current compilation. The table is indexed by the unit number value,
+ -- current compilation. The table is indexed by the unit number value.
-- The first entry in the table, subscript Main_Unit, is for the main file.
-- Each entry in this units table contains the following data.
@@ -286,7 +286,7 @@ package Lib is
-- Dynamic_Elab
-- A flag indicating if this unit was compiled with dynamic elaboration
-- checks specified (as the result of using the -gnatE compilation
- -- option or a pragma Elaboration_Checks (Dynamic).
+ -- option or a pragma Elaboration_Checks (Dynamic)).
-- Error_Location
-- This is copied from the Sloc field of the Enode argument passed
@@ -302,7 +302,7 @@ package Lib is
-- No_Name for the main unit.
-- Fatal_Error
- -- A flag that is initialized to None and gets set to Errorif a fatal
+ -- A flag that is initialized to None and gets set to Error if a fatal
-- error occurs during the processing of a unit. A fatal error is one
-- defined as serious enough to stop the next phase of the compiler
-- from running (i.e. fatal error during parsing stops semantics,
@@ -418,25 +418,25 @@ package Lib is
-- but tools can use this status (e.g. ASIS looking at the generated
-- tree) to know that a fatal error was detected.
- function Cunit (U : Unit_Number_Type) return Node_Id;
- function Cunit_Entity (U : Unit_Number_Type) return Entity_Id;
- function Dependency_Num (U : Unit_Number_Type) return Nat;
- function Dynamic_Elab (U : Unit_Number_Type) return Boolean;
- function Error_Location (U : Unit_Number_Type) return Source_Ptr;
- function Expected_Unit (U : Unit_Number_Type) return Unit_Name_Type;
- function Fatal_Error (U : Unit_Number_Type) return Fatal_Type;
- function Generate_Code (U : Unit_Number_Type) return Boolean;
- function Ident_String (U : Unit_Number_Type) return Node_Id;
- function Has_RACW (U : Unit_Number_Type) return Boolean;
- function Loading (U : Unit_Number_Type) return Boolean;
- function Main_CPU (U : Unit_Number_Type) return Int;
- function Main_Priority (U : Unit_Number_Type) return Int;
- function Munit_Index (U : Unit_Number_Type) return Nat;
- function No_Elab_Code_All (U : Unit_Number_Type) return Boolean;
- function OA_Setting (U : Unit_Number_Type) return Character;
- function Source_Index (U : Unit_Number_Type) return Source_File_Index;
- function Unit_File_Name (U : Unit_Number_Type) return File_Name_Type;
- function Unit_Name (U : Unit_Number_Type) return Unit_Name_Type;
+ function Cunit (U : Unit_Number_Type) return Node_Id;
+ function Cunit_Entity (U : Unit_Number_Type) return Entity_Id;
+ function Dependency_Num (U : Unit_Number_Type) return Nat;
+ function Dynamic_Elab (U : Unit_Number_Type) return Boolean;
+ function Error_Location (U : Unit_Number_Type) return Source_Ptr;
+ function Expected_Unit (U : Unit_Number_Type) return Unit_Name_Type;
+ function Fatal_Error (U : Unit_Number_Type) return Fatal_Type;
+ function Generate_Code (U : Unit_Number_Type) return Boolean;
+ function Ident_String (U : Unit_Number_Type) return Node_Id;
+ function Has_RACW (U : Unit_Number_Type) return Boolean;
+ function Loading (U : Unit_Number_Type) return Boolean;
+ function Main_CPU (U : Unit_Number_Type) return Int;
+ function Main_Priority (U : Unit_Number_Type) return Int;
+ function Munit_Index (U : Unit_Number_Type) return Nat;
+ function No_Elab_Code_All (U : Unit_Number_Type) return Boolean;
+ function OA_Setting (U : Unit_Number_Type) return Character;
+ function Source_Index (U : Unit_Number_Type) return Source_File_Index;
+ function Unit_File_Name (U : Unit_Number_Type) return File_Name_Type;
+ function Unit_Name (U : Unit_Number_Type) return Unit_Name_Type;
-- Get value of named field from given units table entry
procedure Set_Cunit (U : Unit_Number_Type; N : Node_Id);
@@ -485,7 +485,7 @@ package Lib is
function Exact_Source_Name (Loc : Source_Ptr) return String;
-- Return name of entity at location Loc exactly as written in the source.
- -- this includes copying the wide character encodings exactly as they were
+ -- This includes copying the wide character encodings exactly as they were
-- used in the source, so the caller must be aware of the possibility of
-- such encodings.
@@ -541,6 +541,20 @@ package Lib is
-- template, so it returns the unit number containing the code that
-- corresponds to the node N, or the source location S.
+ function Get_Top_Level_Code_Unit
+ (N : Node_Or_Entity_Id) return Unit_Number_Type;
+ pragma Inline (Get_Code_Unit);
+ function Get_Top_Level_Code_Unit (S : Source_Ptr) return Unit_Number_Type;
+ -- This is like Get_Code_Unit, except that in the case of subunits, it
+ -- returns the top-level unit to which the subunit belongs instead of
+ -- the subunit.
+ --
+ -- Note: for nodes and slocs in declarations of library-level instances of
+ -- generics these routines wrongly return the unit number corresponding to
+ -- the body of the instance. In effect, locations of SPARK references in
+ -- ALI files are bogus. However, fixing this is not worth the effort, since
+ -- these references are only used for debugging.
+
function In_Extended_Main_Code_Unit
(N : Node_Or_Entity_Id) return Boolean;
-- Return True if the node is in the generated code of the extended main
@@ -580,7 +594,7 @@ package Lib is
function In_Predefined_Unit (N : Node_Or_Entity_Id) return Boolean;
-- Returns True if the given node or entity appears within the source text
-- of a predefined unit (i.e. within Ada, Interfaces, System or within one
- -- of the descendent packages of one of these three packages).
+ -- of the descendant packages of one of these three packages).
function In_Predefined_Unit (S : Source_Ptr) return Boolean;
-- Same function as above but argument is a source pointer
diff --git a/gcc/ada/live.adb b/gcc/ada/live.adb
index 5366b513d6..0c09609ea7 100644
--- a/gcc/ada/live.adb
+++ b/gcc/ada/live.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -36,10 +36,10 @@ package body Live is
-- Name_Set
- -- The Name_Set type is used to store the temporary mark bits
- -- used by the garbage collection of entities. Using a separate
- -- array prevents using up any valuable per-node space and possibly
- -- results in better locality and cache usage.
+ -- The Name_Set type is used to store the temporary mark bits used by the
+ -- garbage collection of entities. Using a separate array prevents using up
+ -- any valuable per-node space and possibly results in better locality and
+ -- cache usage.
type Name_Set is array (Node_Id range <>) of Boolean;
pragma Pack (Name_Set);
@@ -66,14 +66,13 @@ package body Live is
-- The Mark phase is split into two phases:
procedure Init_Marked (Root : Node_Id; Marks : out Name_Set);
- -- For all subprograms, reset Is_Public flag if a pragma Eliminate
- -- applies to the entity, and set the Marked flag to Is_Public
+ -- For all subprograms, reset Is_Public flag if a pragma Eliminate applies
+ -- to the entity, and set the Marked flag to Is_Public.
procedure Trace_Marked (Root : Node_Id; Marks : in out Name_Set);
- -- Traverse the tree skipping any unmarked subprogram bodies.
- -- All visited entities are marked, as well as entities denoted
- -- by a visited identifier or operator. When an entity is first
- -- marked it is traced as well.
+ -- Traverse the tree skipping any unmarked subprogram bodies. All visited
+ -- entities are marked, as well as entities denoted by a visited identifier
+ -- or operator. When an entity is first marked it is traced as well.
-- Local functions
@@ -137,6 +136,10 @@ package body Live is
function Process (N : Node_Id) return Traverse_Result;
procedure Traverse is new Traverse_Proc (Process);
+ -------------
+ -- Process --
+ -------------
+
function Process (N : Node_Id) return Traverse_Result is
begin
case Nkind (N) is
@@ -233,6 +236,10 @@ package body Live is
function Process (N : Node_Id) return Traverse_Result;
procedure Traverse is new Traverse_Proc (Process);
+ -------------
+ -- Process --
+ -------------
+
function Process (N : Node_Id) return Traverse_Result is
begin
case Nkind (N) is
@@ -260,9 +267,12 @@ package body Live is
when others =>
null;
end case;
+
return OK;
end Process;
+ -- Start of processing for Sweep
+
begin
Traverse (Root);
end Sweep;
@@ -277,6 +287,10 @@ package body Live is
procedure Process (N : Node_Id);
procedure Traverse is new Traverse_Proc (Process);
+ -------------
+ -- Process --
+ -------------
+
procedure Process (N : Node_Id) is
Result : Traverse_Result;
pragma Warnings (Off, Result);
@@ -292,8 +306,11 @@ package body Live is
begin
case Nkind (N) is
- when N_Pragma | N_Generic_Declaration'Range |
- N_Subprogram_Declaration | N_Subprogram_Body_Stub =>
+ when N_Generic_Declaration'Range
+ | N_Pragma
+ | N_Subprogram_Body_Stub
+ | N_Subprogram_Declaration
+ =>
Result := Skip;
when N_Subprogram_Body =>
@@ -306,7 +323,10 @@ package body Live is
Traverse (Proper_Body (Unit (Library_Unit (N))));
end if;
- when N_Identifier | N_Operator_Symbol | N_Expanded_Name =>
+ when N_Expanded_Name
+ | N_Identifier
+ | N_Operator_Symbol
+ =>
E := Entity (N);
if E /= Empty and then not Marked (Marks, E) then
diff --git a/gcc/ada/live.ads b/gcc/ada/live.ads
index 016203d959..535d0e4c56 100644
--- a/gcc/ada/live.ads
+++ b/gcc/ada/live.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -23,14 +23,14 @@
-- --
------------------------------------------------------------------------------
--- This package implements a compiler phase that determines the set
--- of live entities. For now entities are considered live when they
--- have at least one execution time reference.
+-- This package implements a compiler phase that determines the set of live
+-- entities. For now entities are considered live when they have at least one
+-- execution time reference.
package Live is
procedure Collect_Garbage_Entities;
- -- Eliminate unreachable entities using a mark-and-sweep from
- -- the set of root entities, i.e. those having Is_Public set.
+ -- Eliminate unreachable entities using a mark-and-sweep from the set of
+ -- root entities, i.e. those having Is_Public set.
end Live;
diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb
index c5bf2b901b..4fd741c1be 100644
--- a/gcc/ada/make.adb
+++ b/gcc/ada/make.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -84,8 +84,11 @@ package body Make is
-- Make control characters visible
Standard_Library_Package_Body_Name : constant String := "s-stalib.adb";
- -- Every program depends on this package, that must then be checked,
- -- especially when -f and -a are used.
+ System_Package_Spec_Name : constant String := "system.ads";
+ -- Every program depends on one of these packages: usually the first one,
+ -- or if Supress_Standard_Library is true on the second one. The dependency
+ -- is not always explicit and considering it is important when -f and -a
+ -- are used.
type Sigint_Handler is access procedure;
pragma Convention (C, Sigint_Handler);
@@ -672,9 +675,6 @@ package body Make is
Gnatlink : String_Access := Program_Name ("gnatlink", "gnatmake");
-- Default compiler, binder, linker programs
- Globalizer : constant String := "codepeer_globalizer";
- -- CodePeer globalizer executable name
-
Saved_Gcc : String_Access := null;
Saved_Gnatbind : String_Access := null;
Saved_Gnatlink : String_Access := null;
@@ -689,10 +689,6 @@ package body Make is
-- Path for compiler, binder, linker programs, defaulted now for gnatdist.
-- Changed later if overridden on command line.
- Globalizer_Path : constant String_Access :=
- GNAT.OS_Lib.Locate_Exec_On_Path (Globalizer);
- -- Path for CodePeer globalizer
-
Comp_Flag : constant String_Access := new String'("-c");
Output_Flag : constant String_Access := new String'("-o");
Ada_Flag_1 : constant String_Access := new String'("-x");
@@ -1021,10 +1017,6 @@ package body Make is
-- during a compilation are also transitively included in the W section
-- of the originally compiled file.
- procedure Globalize (Success : out Boolean);
- -- Call the CodePeer globalizer on all the project's object directories,
- -- or on the current directory if no projects.
-
procedure Initialize
(Project_Node_Tree : out Project_Node_Tree_Ref;
Env : out Prj.Tree.Environment);
@@ -2171,15 +2163,15 @@ package body Make is
for Ptr in Template'Range loop
case Template (Ptr) is
- when '*' =>
+ when '*' =>
Add_Str_To_Name_Buffer (Name);
- when ';' =>
+ when ';' =>
File := Full_Lib_File_Name (Name_Find);
exit when File /= No_File;
Name_Len := 0;
- when NUL =>
+ when NUL =>
exit;
when others =>
@@ -2700,40 +2692,43 @@ package body Make is
procedure Check_Standard_Library is
begin
Need_To_Check_Standard_Library := False;
+ Name_Len := 0;
if not Targparm.Suppress_Standard_Library_On_Target then
- declare
- Sfile : File_Name_Type;
- Add_It : Boolean := True;
+ Add_Str_To_Name_Buffer (Standard_Library_Package_Body_Name);
+ else
+ Add_Str_To_Name_Buffer (System_Package_Spec_Name);
+ end if;
- begin
- Name_Len := 0;
- Add_Str_To_Name_Buffer (Standard_Library_Package_Body_Name);
- Sfile := Name_Enter;
+ declare
+ Add_It : Boolean := True;
+ Sfile : File_Name_Type;
- -- If we have a special runtime, we add the standard
- -- library only if we can find it.
+ begin
+ Sfile := Name_Enter;
- if RTS_Switch then
- Add_It := Full_Source_Name (Sfile) /= No_File;
- end if;
+ -- If we have a special runtime, we add the standard library only
+ -- if we can find it.
- if Add_It then
- if not Queue.Insert
- ((Format => Format_Gnatmake,
- File => Sfile,
- Unit => No_Unit_Name,
- Project => No_Project,
- Index => 0,
- Sid => No_Source))
- then
- if Is_In_Obsoleted (Sfile) then
- Executable_Obsolete := True;
- end if;
+ if RTS_Switch then
+ Add_It := Full_Source_Name (Sfile) /= No_File;
+ end if;
+
+ if Add_It then
+ if not Queue.Insert
+ ((Format => Format_Gnatmake,
+ File => Sfile,
+ Unit => No_Unit_Name,
+ Project => No_Project,
+ Index => 0,
+ Sid => No_Source))
+ then
+ if Is_In_Obsoleted (Sfile) then
+ Executable_Obsolete := True;
end if;
end if;
- end;
- end if;
+ end if;
+ end;
end Check_Standard_Library;
-----------------------------------
@@ -2978,7 +2973,7 @@ package body Make is
Comp_Last := Comp_Last + 1;
Comp_Args (Comp_Last) := AdaSCIL_Flag;
- elsif not Ada_File_Name (S) and then not Targparm.AAMP_On_Target then
+ elsif not Ada_File_Name (S) then
Comp_Last := Comp_Last + 1;
Comp_Args (Comp_Last) := Ada_Flag_1;
Comp_Last := Comp_Last + 1;
@@ -4081,55 +4076,6 @@ package body Make is
Obsoleted.Set (F2, True);
end Enter_Into_Obsoleted;
- ---------------
- -- Globalize --
- ---------------
-
- procedure Globalize (Success : out Boolean) is
- Quiet_Str : aliased String := "-quiet";
- Globalizer_Args : constant Argument_List :=
- (1 => Quiet_Str'Unchecked_Access);
- Previous_Dir : String_Access;
-
- procedure Globalize_Dir (Dir : String);
- -- Call CodePeer globalizer on Dir
-
- -------------------
- -- Globalize_Dir --
- -------------------
-
- procedure Globalize_Dir (Dir : String) is
- Result : Boolean;
- begin
- if Previous_Dir = null or else Dir /= Previous_Dir.all then
- Free (Previous_Dir);
- Previous_Dir := new String'(Dir);
- Change_Dir (Dir);
- GNAT.OS_Lib.Spawn (Globalizer_Path.all, Globalizer_Args, Result);
- Success := Success and Result;
- end if;
- end Globalize_Dir;
-
- procedure Globalize_Dirs is new
- Prj.Env.For_All_Object_Dirs (Globalize_Dir);
-
- -- Start of processing for Globalize
-
- begin
- Success := True;
- Display (Globalizer, Globalizer_Args);
-
- if Globalizer_Path = null then
- Make_Failed ("error, unable to locate " & Globalizer);
- end if;
-
- if Main_Project = No_Project then
- GNAT.OS_Lib.Spawn (Globalizer_Path.all, Globalizer_Args, Success);
- else
- Globalize_Dirs (Main_Project, Project_Tree);
- end if;
- end Globalize;
-
-------------------
-- Linking_Phase --
-------------------
@@ -5816,7 +5762,7 @@ package body Make is
Finish_Program (Project_Tree, E_Success);
else
- -- Call Get_Target_Parameters to ensure that AAMP_On_Target gets
+ -- Call Get_Target_Parameters to ensure that flags are properly
-- set before calling Usage.
Targparm.Get_Target_Parameters;
@@ -6184,23 +6130,6 @@ package body Make is
end if;
end loop Multiple_Main_Loop;
- if CodePeer_Mode then
- declare
- Success : Boolean := False;
- begin
- Globalize (Success);
-
- if not Success then
- Set_Standard_Error;
- Write_Str ("*** globalize failed.");
-
- if Commands_To_Stdout then
- Set_Standard_Output;
- end if;
- end if;
- end;
- end if;
-
if Failed_Links.Last > 0 then
for Index in 1 .. Successful_Links.Last loop
Write_Str ("Linking of """);
@@ -6413,16 +6342,29 @@ package body Make is
-- Scan again the switch and arguments, now that we are sure that they
-- do not include --version or --help.
- -- First, for native gnatmake, check for switch -P and, if found and
- -- gprbuild is available, silently invoke gprbuild.
+ -- First, check for switch -P and, if found and gprbuild is available,
+ -- silently invoke gprbuild, with switch --target if not on a native
+ -- platform.
- Find_Program_Name;
+ declare
+ Arg_Len : Natural := Argument_Count;
+ Call_Gprbuild : Boolean := False;
+ Gprbuild : String_Access := null;
+ Pos : Natural := 0;
+ Success : Boolean;
+ Target : String_Access := null;
- if Name_Buffer (1 .. Name_Len) = "gnatmake" then
- declare
- Call_Gprbuild : Boolean := False;
+ begin
+ Find_Program_Name;
+
+ if Name_Len >= 8
+ and then Name_Buffer (Name_Len - 7 .. Name_Len) = "gnatmake"
+ then
+ if Name_Len > 8 then
+ Target := new String'(Name_Buffer (1 .. Name_Len - 9));
+ Arg_Len := Arg_Len + 1;
+ end if;
- begin
for J in 1 .. Argument_Count loop
declare
Arg : constant String := Argument (J);
@@ -6437,16 +6379,20 @@ package body Make is
end loop;
if Call_Gprbuild then
- declare
- Gprbuild : String_Access :=
- Locate_Exec_On_Path (Exec_Name => "gprbuild");
- Args : Argument_List (1 .. Argument_Count);
- Success : Boolean;
+ Gprbuild := Locate_Exec_On_Path (Exec_Name => "gprbuild");
+
+ if Gprbuild /= null then
+ declare
+ Args : Argument_List (1 .. Arg_Len);
+ begin
+ if Target /= null then
+ Args (1) := new String'("--target=" & Target.all);
+ Pos := 1;
+ end if;
- begin
- if Gprbuild /= null then
for J in 1 .. Argument_Count loop
- Args (J) := new String'(Argument (J));
+ Pos := Pos + 1;
+ Args (Pos) := new String'(Argument (J));
end loop;
Spawn (Gprbuild.all, Args, Success);
@@ -6456,11 +6402,11 @@ package body Make is
if Success then
Exit_Program (E_Success);
end if;
- end if;
- end;
+ end;
+ end if;
end if;
- end;
- end if;
+ end if;
+ end;
Scan_Args : for Next_Arg in 1 .. Argument_Count loop
Scan_Make_Arg (Env, Argument (Next_Arg), And_Save => True);
@@ -6506,14 +6452,6 @@ package body Make is
Make_Failed ("-i and -D cannot be used simultaneously");
end if;
- -- Warn about 'gnatmake -P'
-
- if Project_File_Name /= null then
- Write_Line
- ("warning: gnatmake -P is obsolete and will not be available "
- & "in the next release; use gprbuild instead");
- end if;
-
-- If --subdirs= is specified, but not -P, this is equivalent to -D,
-- except that the directory is created if it does not exist.
diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb
index 997cbf003a..53233a02e3 100644
--- a/gcc/ada/makeutl.adb
+++ b/gcc/ada/makeutl.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2004-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -2375,13 +2375,15 @@ package body Makeutl is
begin
case S.Format is
when Format_Gprbuild =>
- return not Busy_Obj_Dirs.Get
- (S.Id.Project.Object_Directory.Name);
+ return
+ not Busy_Obj_Dirs.Get
+ (S.Id.Project.Object_Directory.Name);
when Format_Gnatmake =>
- return S.Project = No_Project
- or else
- not Busy_Obj_Dirs.Get (S.Project.Object_Directory.Name);
+ return
+ S.Project = No_Project
+ or else not Busy_Obj_Dirs.Get
+ (S.Project.Object_Directory.Name);
end case;
end Available_Obj_Dir;
@@ -2522,10 +2524,11 @@ package body Makeutl is
for J in 1 .. Q.Last loop
case Q.Table (J).Info.Format is
- when Format_Gprbuild =>
- Q.Table (J).Info.Id.In_The_Queue := False;
- when Format_Gnatmake =>
- null;
+ when Format_Gprbuild =>
+ Q.Table (J).Info.Id.In_The_Queue := False;
+
+ when Format_Gnatmake =>
+ null;
end case;
end loop;
@@ -2739,14 +2742,15 @@ package body Makeutl is
if Root_Found then
case Root_Source.Kind is
- when Impl =>
- null;
+ when Impl =>
+ null;
- when Spec =>
- Root_Found := Other_Part (Root_Source) = No_Source;
+ when Spec =>
+ Root_Found :=
+ Other_Part (Root_Source) = No_Source;
- when Sep =>
- Root_Found := False;
+ when Sep =>
+ Root_Found := False;
end case;
end if;
@@ -2886,6 +2890,7 @@ package body Makeutl is
case Q.Table (Rank).Info.Format is
when Format_Gprbuild =>
return Q.Table (Rank).Info.Id.File;
+
when Format_Gnatmake =>
return Q.Table (Rank).Info.File;
end case;
diff --git a/gcc/ada/mingw32.h b/gcc/ada/mingw32.h
index 77caec2642..cf2d9de171 100644
--- a/gcc/ada/mingw32.h
+++ b/gcc/ada/mingw32.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 2002-2014, Free Software Foundation, Inc. *
+ * Copyright (C) 2002-2016, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -78,14 +78,15 @@
#ifdef GNAT_UNICODE_SUPPORT
-extern UINT CurrentCodePage;
-extern UINT CurrentCCSEncoding;
+extern UINT __gnat_current_codepage;
+extern UINT __gnat_current_ccs_encoding;
-/* Macros to convert to/from the code page specified in CurrentCodePage. */
+/* Macros to convert to/from the code page specified in
+ __gnat_current_codepage. */
#define S2WSC(wstr,str,len) \
- MultiByteToWideChar (CurrentCodePage,0,str,-1,wstr,len)
+ MultiByteToWideChar (__gnat_current_codepage,0,str,-1,wstr,len)
#define WS2SC(str,wstr,len) \
- WideCharToMultiByte (CurrentCodePage,0,wstr,-1,str,len,NULL,NULL)
+ WideCharToMultiByte (__gnat_current_codepage,0,wstr,-1,str,len,NULL,NULL)
/* Macros to convert to/from UTF-8 code page. */
#define S2WSU(wstr,str,len) \
diff --git a/gcc/ada/mkdir.c b/gcc/ada/mkdir.c
index bdb0fa8f7b..9b0a926503 100644
--- a/gcc/ada/mkdir.c
+++ b/gcc/ada/mkdir.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2002-2014, Free Software Foundation, Inc. *
+ * Copyright (C) 2002-2016, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -60,8 +60,18 @@
int
__gnat_mkdir (char *dir_name, int encoding ATTRIBUTE_UNUSED)
{
-#if defined (__vxworks) && !(defined (__RTP__) && ((_WRS_VXWORKS_MAJOR == 7) || (_WRS_VXWORKS_MINOR != 0)))
- return mkdir (dir_name);
+#if defined (__vxworks)
+
+ /* Pretend that the system mkdir is posix compliant even though it
+ sometimes is not, not expecting the second argument in some
+ configurations (e.g. vxworks 653 2.2, difference from 2.5). The
+ second actual argument will just be ignored in this case. */
+
+ typedef int posix_mkdir (const char * name, mode_t mode);
+
+ posix_mkdir * vxmkdir = (posix_mkdir *)&mkdir;
+ return vxmkdir (dir_name, S_IRWXU | S_IRWXG | S_IRWXO);
+
#elif defined (__MINGW32__)
TCHAR wname [GNAT_MAX_PATH_LEN + 2];
diff --git a/gcc/ada/mlib-prj.adb b/gcc/ada/mlib-prj.adb
index 97797b468e..d830b66837 100644
--- a/gcc/ada/mlib-prj.adb
+++ b/gcc/ada/mlib-prj.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2015, AdaCore --
+-- Copyright (C) 2001-2016, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1898,7 +1898,9 @@ package body MLib.Prj is
-- Call procedure to build the library, depending on the build mode
case The_Build_Mode is
- when Dynamic | Relocatable =>
+ when Dynamic
+ | Relocatable
+ =>
Build_Dynamic_Library
(Ofiles => Object_Files.all,
Options => Options.all,
diff --git a/gcc/ada/namet-sp.ads b/gcc/ada/namet-sp.ads
index 87e082468e..1f42029f01 100644
--- a/gcc/ada/namet-sp.ads
+++ b/gcc/ada/namet-sp.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2012 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -31,7 +31,7 @@
-- This child package contains a spell checker for Name_Id values. It is
-- separated off as a child package, because of the extra dependencies,
--- in particular on GNAT.UTF_32_ Spelling_Checker. There are a number of
+-- in particular on GNAT.UTF_32_Spelling_Checker. There are a number of
-- packages that use Namet that do not need the spell checking feature,
-- and this separation helps in dealing with older versions of GNAT.
diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb
index 902f347b93..5bea77d93e 100644
--- a/gcc/ada/namet.adb
+++ b/gcc/ada/namet.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -73,16 +73,14 @@ package body Namet is
-- Local Subprograms --
-----------------------
- function Hash return Hash_Index_Type;
+ function Hash (Buf : Bounded_String) return Hash_Index_Type;
pragma Inline (Hash);
- -- Compute hash code for name stored in Name_Buffer (length in Name_Len)
+ -- Compute hash code for name stored in Buf
- procedure Strip_Qualification_And_Suffixes;
- -- Given an encoded entity name in Name_Buffer, remove package body
+ procedure Strip_Qualification_And_Suffixes (Buf : in out Bounded_String);
+ -- Given an encoded entity name in Buf, remove package body
-- suffix as described for Strip_Package_Body_Suffix, and also remove
- -- all qualification, i.e. names followed by two underscores. The
- -- contents of Name_Buffer is modified by this call, and on return
- -- Name_Buffer and Name_Len reflect the stripped name.
+ -- all qualification, i.e. names followed by two underscores.
-----------------------------
-- Add_Char_To_Name_Buffer --
@@ -90,10 +88,7 @@ package body Namet is
procedure Add_Char_To_Name_Buffer (C : Character) is
begin
- if Name_Len < Name_Buffer'Last then
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := C;
- end if;
+ Append (Global_Name_Buffer, C);
end Add_Char_To_Name_Buffer;
----------------------------
@@ -102,11 +97,7 @@ package body Namet is
procedure Add_Nat_To_Name_Buffer (V : Nat) is
begin
- if V >= 10 then
- Add_Nat_To_Name_Buffer (V / 10);
- end if;
-
- Add_Char_To_Name_Buffer (Character'Val (Character'Pos ('0') + V rem 10));
+ Append (Global_Name_Buffer, V);
end Add_Nat_To_Name_Buffer;
----------------------------
@@ -115,188 +106,82 @@ package body Namet is
procedure Add_Str_To_Name_Buffer (S : String) is
begin
- for J in S'Range loop
- Add_Char_To_Name_Buffer (S (J));
- end loop;
+ Append (Global_Name_Buffer, S);
end Add_Str_To_Name_Buffer;
- --------------
- -- Finalize --
- --------------
-
- procedure Finalize is
- F : array (Int range 0 .. 50) of Int;
- -- N'th entry is the number of chains of length N, except last entry,
- -- which is the number of chains of length F'Last or more.
-
- Max_Chain_Length : Int := 0;
- -- Maximum length of all chains
-
- Probes : Int := 0;
- -- Used to compute average number of probes
-
- Nsyms : Int := 0;
- -- Number of symbols in table
-
- Verbosity : constant Int range 1 .. 3 := 1;
- pragma Warnings (Off, Verbosity);
- -- This constant indicates the level of verbosity in the output from
- -- this procedure. Currently this can only be changed by editing the
- -- declaration above and recompiling. That's good enough in practice,
- -- since we very rarely need to use this debug option. Settings are:
- --
- -- 1 => print basic summary information
- -- 2 => in addition print number of entries per hash chain
- -- 3 => in addition print content of entries
-
- Zero : constant Int := Character'Pos ('0');
+ ------------
+ -- Append --
+ ------------
+ procedure Append (Buf : in out Bounded_String; C : Character) is
begin
- if not Debug_Flag_H then
- return;
+ if Buf.Length >= Buf.Chars'Last then
+ raise Program_Error;
end if;
- for J in F'Range loop
- F (J) := 0;
- end loop;
-
- for J in Hash_Index_Type loop
- if Hash_Table (J) = No_Name then
- F (0) := F (0) + 1;
-
- else
- declare
- C : Int;
- N : Name_Id;
- S : Int;
-
- begin
- C := 0;
- N := Hash_Table (J);
-
- while N /= No_Name loop
- N := Name_Entries.Table (N).Hash_Link;
- C := C + 1;
- end loop;
-
- Nsyms := Nsyms + 1;
- Probes := Probes + (1 + C) * 100;
+ Buf.Length := Buf.Length + 1;
+ Buf.Chars (Buf.Length) := C;
+ end Append;
- if C > Max_Chain_Length then
- Max_Chain_Length := C;
- end if;
-
- if Verbosity >= 2 then
- Write_Str ("Hash_Table (");
- Write_Int (J);
- Write_Str (") has ");
- Write_Int (C);
- Write_Str (" entries");
- Write_Eol;
- end if;
-
- if C < F'Last then
- F (C) := F (C) + 1;
- else
- F (F'Last) := F (F'Last) + 1;
- end if;
-
- if Verbosity >= 3 then
- N := Hash_Table (J);
- while N /= No_Name loop
- S := Name_Entries.Table (N).Name_Chars_Index;
-
- Write_Str (" ");
-
- for J in 1 .. Name_Entries.Table (N).Name_Len loop
- Write_Char (Name_Chars.Table (S + Int (J)));
- end loop;
+ procedure Append (Buf : in out Bounded_String; V : Nat) is
+ begin
+ if V >= 10 then
+ Append (Buf, V / 10);
+ end if;
- Write_Eol;
+ Append (Buf, Character'Val (Character'Pos ('0') + V rem 10));
+ end Append;
- N := Name_Entries.Table (N).Hash_Link;
- end loop;
- end if;
- end;
- end if;
+ procedure Append (Buf : in out Bounded_String; S : String) is
+ begin
+ for J in S'Range loop
+ Append (Buf, S (J));
end loop;
+ end Append;
- Write_Eol;
-
- for J in F'Range loop
- if F (J) /= 0 then
- Write_Str ("Number of hash chains of length ");
-
- if J < 10 then
- Write_Char (' ');
- end if;
-
- Write_Int (J);
+ procedure Append (Buf : in out Bounded_String; Buf2 : Bounded_String) is
+ begin
+ Append (Buf, Buf2.Chars (1 .. Buf2.Length));
+ end Append;
- if J = F'Last then
- Write_Str (" or greater");
- end if;
+ procedure Append (Buf : in out Bounded_String; Id : Name_Id) is
+ pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
+ S : constant Int := Name_Entries.Table (Id).Name_Chars_Index;
- Write_Str (" = ");
- Write_Int (F (J));
- Write_Eol;
- end if;
+ begin
+ for J in 1 .. Natural (Name_Entries.Table (Id).Name_Len) loop
+ Append (Buf, Name_Chars.Table (S + Int (J)));
end loop;
+ end Append;
- -- Print out average number of probes, in the case where Name_Find is
- -- called for a string that is already in the table.
-
- Write_Eol;
- Write_Str ("Average number of probes for lookup = ");
- Probes := Probes / Nsyms;
- Write_Int (Probes / 200);
- Write_Char ('.');
- Probes := (Probes mod 200) / 2;
- Write_Char (Character'Val (Zero + Probes / 10));
- Write_Char (Character'Val (Zero + Probes mod 10));
- Write_Eol;
-
- Write_Str ("Max_Chain_Length = ");
- Write_Int (Max_Chain_Length);
- Write_Eol;
- Write_Str ("Name_Chars'Length = ");
- Write_Int (Name_Chars.Last - Name_Chars.First + 1);
- Write_Eol;
- Write_Str ("Name_Entries'Length = ");
- Write_Int (Int (Name_Entries.Last - Name_Entries.First + 1));
- Write_Eol;
- Write_Str ("Nsyms = ");
- Write_Int (Nsyms);
- Write_Eol;
- end Finalize;
-
- -----------------------------
- -- Get_Decoded_Name_String --
- -----------------------------
+ --------------------
+ -- Append_Decoded --
+ --------------------
- procedure Get_Decoded_Name_String (Id : Name_Id) is
+ procedure Append_Decoded (Buf : in out Bounded_String; Id : Name_Id) is
C : Character;
P : Natural;
+ Temp : Bounded_String;
begin
- Get_Name_String (Id);
+ Append (Temp, Id);
-- Skip scan if we already know there are no encodings
if Name_Entries.Table (Id).Name_Has_No_Encodings then
- return;
+ goto Done;
end if;
-- Quick loop to see if there is anything special to do
P := 1;
loop
- if P = Name_Len then
+ if P = Temp.Length then
Name_Entries.Table (Id).Name_Has_No_Encodings := True;
- return;
+ goto Done;
else
- C := Name_Buffer (P);
+ C := Temp.Chars (P);
exit when
C = 'U' or else
@@ -313,10 +198,10 @@ package body Namet is
Decode : declare
New_Len : Natural;
Old : Positive;
- New_Buf : String (1 .. Name_Buffer'Last);
+ New_Buf : String (1 .. Temp.Chars'Last);
procedure Copy_One_Character;
- -- Copy a character from Name_Buffer to New_Buf. Includes case
+ -- Copy a character from Temp.Chars to New_Buf. Includes case
-- of copying a Uhh,Whhhh,WWhhhhhhhh sequence and decoding it.
function Hex (N : Natural) return Word;
@@ -333,14 +218,14 @@ package body Namet is
C : Character;
begin
- C := Name_Buffer (Old);
+ C := Temp.Chars (Old);
-- U (upper half insertion case)
if C = 'U'
- and then Old < Name_Len
- and then Name_Buffer (Old + 1) not in 'A' .. 'Z'
- and then Name_Buffer (Old + 1) /= '_'
+ and then Old < Temp.Length
+ and then Temp.Chars (Old + 1) not in 'A' .. 'Z'
+ and then Temp.Chars (Old + 1) /= '_'
then
Old := Old + 1;
@@ -360,8 +245,8 @@ package body Namet is
-- WW (wide wide character insertion)
elsif C = 'W'
- and then Old < Name_Len
- and then Name_Buffer (Old + 1) = 'W'
+ and then Old < Temp.Length
+ and then Temp.Chars (Old + 1) = 'W'
then
Old := Old + 2;
Widechar.Set_Wide (Char_Code (Hex (8)), New_Buf, New_Len);
@@ -369,9 +254,9 @@ package body Namet is
-- W (wide character insertion)
elsif C = 'W'
- and then Old < Name_Len
- and then Name_Buffer (Old + 1) not in 'A' .. 'Z'
- and then Name_Buffer (Old + 1) /= '_'
+ and then Old < Temp.Length
+ and then Temp.Chars (Old + 1) not in 'A' .. 'Z'
+ and then Temp.Chars (Old + 1) /= '_'
then
Old := Old + 1;
Widechar.Set_Wide (Char_Code (Hex (4)), New_Buf, New_Len);
@@ -394,7 +279,7 @@ package body Namet is
begin
for J in 1 .. N loop
- C := Name_Buffer (Old);
+ C := Temp.Chars (Old);
Old := Old + 1;
pragma Assert (C in '0' .. '9' or else C in 'a' .. 'f');
@@ -427,12 +312,12 @@ package body Namet is
-- Loop through characters of name
- while Old <= Name_Len loop
+ while Old <= Temp.Length loop
-- Case of character literal, put apostrophes around character
- if Name_Buffer (Old) = 'Q'
- and then Old < Name_Len
+ if Temp.Chars (Old) = 'Q'
+ and then Old < Temp.Length
then
Old := Old + 1;
Insert_Character (''');
@@ -441,10 +326,10 @@ package body Namet is
-- Case of operator name
- elsif Name_Buffer (Old) = 'O'
- and then Old < Name_Len
- and then Name_Buffer (Old + 1) not in 'A' .. 'Z'
- and then Name_Buffer (Old + 1) /= '_'
+ elsif Temp.Chars (Old) = 'O'
+ and then Old < Temp.Length
+ and then Temp.Chars (Old + 1) not in 'A' .. 'Z'
+ and then Temp.Chars (Old + 1) /= '_'
then
Old := Old + 1;
@@ -485,8 +370,8 @@ package body Namet is
J := Map'First;
loop
- exit when Name_Buffer (Old) = Map (J)
- and then Name_Buffer (Old + 1) = Map (J + 1);
+ exit when Temp.Chars (Old) = Map (J)
+ and then Temp.Chars (Old + 1) = Map (J + 1);
J := J + 4;
end loop;
@@ -503,8 +388,8 @@ package body Namet is
-- Skip past original operator name in input
- while Old <= Name_Len
- and then Name_Buffer (Old) in 'a' .. 'z'
+ while Old <= Temp.Length
+ and then Temp.Chars (Old) in 'a' .. 'z'
loop
Old := Old + 1;
end loop;
@@ -515,8 +400,8 @@ package body Namet is
else
-- Copy original operator name from input to output
- while Old <= Name_Len
- and then Name_Buffer (Old) in 'a' .. 'z'
+ while Old <= Temp.Length
+ and then Temp.Chars (Old) in 'a' .. 'z'
loop
Copy_One_Character;
end loop;
@@ -534,94 +419,358 @@ package body Namet is
-- Copy new buffer as result
- Name_Len := New_Len;
- Name_Buffer (1 .. New_Len) := New_Buf (1 .. New_Len);
+ Temp.Length := New_Len;
+ Temp.Chars (1 .. New_Len) := New_Buf (1 .. New_Len);
end Decode;
- end Get_Decoded_Name_String;
- -------------------------------------------
- -- Get_Decoded_Name_String_With_Brackets --
- -------------------------------------------
+ <<Done>>
+ Append (Buf, Temp);
+ end Append_Decoded;
- procedure Get_Decoded_Name_String_With_Brackets (Id : Name_Id) is
+ ----------------------------------
+ -- Append_Decoded_With_Brackets --
+ ----------------------------------
+
+ procedure Append_Decoded_With_Brackets
+ (Buf : in out Bounded_String;
+ Id : Name_Id)
+ is
P : Natural;
begin
-- Case of operator name, normal decoding is fine
- if Name_Buffer (1) = 'O' then
- Get_Decoded_Name_String (Id);
+ if Buf.Chars (1) = 'O' then
+ Append_Decoded (Buf, Id);
-- For character literals, normal decoding is fine
- elsif Name_Buffer (1) = 'Q' then
- Get_Decoded_Name_String (Id);
+ elsif Buf.Chars (1) = 'Q' then
+ Append_Decoded (Buf, Id);
-- Only remaining issue is U/W/WW sequences
else
- Get_Name_String (Id);
+ declare
+ Temp : Bounded_String;
+ begin
+ Append (Temp, Id);
- P := 1;
- while P < Name_Len loop
- if Name_Buffer (P + 1) in 'A' .. 'Z' then
- P := P + 1;
+ P := 1;
+ while P < Temp.Length loop
+ if Temp.Chars (P + 1) in 'A' .. 'Z' then
+ P := P + 1;
- -- Uhh encoding
+ -- Uhh encoding
- elsif Name_Buffer (P) = 'U' then
- for J in reverse P + 3 .. P + Name_Len loop
- Name_Buffer (J + 3) := Name_Buffer (J);
- end loop;
+ elsif Temp.Chars (P) = 'U' then
+ for J in reverse P + 3 .. P + Temp.Length loop
+ Temp.Chars (J + 3) := Temp.Chars (J);
+ end loop;
- Name_Len := Name_Len + 3;
- Name_Buffer (P + 3) := Name_Buffer (P + 2);
- Name_Buffer (P + 2) := Name_Buffer (P + 1);
- Name_Buffer (P) := '[';
- Name_Buffer (P + 1) := '"';
- Name_Buffer (P + 4) := '"';
- Name_Buffer (P + 5) := ']';
- P := P + 6;
-
- -- WWhhhhhhhh encoding
-
- elsif Name_Buffer (P) = 'W'
- and then P + 9 <= Name_Len
- and then Name_Buffer (P + 1) = 'W'
- and then Name_Buffer (P + 2) not in 'A' .. 'Z'
- and then Name_Buffer (P + 2) /= '_'
- then
- Name_Buffer (P + 12 .. Name_Len + 2) :=
- Name_Buffer (P + 10 .. Name_Len);
- Name_Buffer (P) := '[';
- Name_Buffer (P + 1) := '"';
- Name_Buffer (P + 10) := '"';
- Name_Buffer (P + 11) := ']';
- Name_Len := Name_Len + 2;
- P := P + 12;
-
- -- Whhhh encoding
-
- elsif Name_Buffer (P) = 'W'
- and then P < Name_Len
- and then Name_Buffer (P + 1) not in 'A' .. 'Z'
- and then Name_Buffer (P + 1) /= '_'
- then
- Name_Buffer (P + 8 .. P + Name_Len + 3) :=
- Name_Buffer (P + 5 .. Name_Len);
- Name_Buffer (P + 2 .. P + 5) := Name_Buffer (P + 1 .. P + 4);
- Name_Buffer (P) := '[';
- Name_Buffer (P + 1) := '"';
- Name_Buffer (P + 6) := '"';
- Name_Buffer (P + 7) := ']';
- Name_Len := Name_Len + 3;
- P := P + 8;
+ Temp.Length := Temp.Length + 3;
+ Temp.Chars (P + 3) := Temp.Chars (P + 2);
+ Temp.Chars (P + 2) := Temp.Chars (P + 1);
+ Temp.Chars (P) := '[';
+ Temp.Chars (P + 1) := '"';
+ Temp.Chars (P + 4) := '"';
+ Temp.Chars (P + 5) := ']';
+ P := P + 6;
+
+ -- WWhhhhhhhh encoding
+
+ elsif Temp.Chars (P) = 'W'
+ and then P + 9 <= Temp.Length
+ and then Temp.Chars (P + 1) = 'W'
+ and then Temp.Chars (P + 2) not in 'A' .. 'Z'
+ and then Temp.Chars (P + 2) /= '_'
+ then
+ Temp.Chars (P + 12 .. Temp.Length + 2) :=
+ Temp.Chars (P + 10 .. Temp.Length);
+ Temp.Chars (P) := '[';
+ Temp.Chars (P + 1) := '"';
+ Temp.Chars (P + 10) := '"';
+ Temp.Chars (P + 11) := ']';
+ Temp.Length := Temp.Length + 2;
+ P := P + 12;
+
+ -- Whhhh encoding
+
+ elsif Temp.Chars (P) = 'W'
+ and then P < Temp.Length
+ and then Temp.Chars (P + 1) not in 'A' .. 'Z'
+ and then Temp.Chars (P + 1) /= '_'
+ then
+ Temp.Chars (P + 8 .. P + Temp.Length + 3) :=
+ Temp.Chars (P + 5 .. Temp.Length);
+ Temp.Chars (P + 2 .. P + 5) := Temp.Chars (P + 1 .. P + 4);
+ Temp.Chars (P) := '[';
+ Temp.Chars (P + 1) := '"';
+ Temp.Chars (P + 6) := '"';
+ Temp.Chars (P + 7) := ']';
+ Temp.Length := Temp.Length + 3;
+ P := P + 8;
+ else
+ P := P + 1;
+ end if;
+ end loop;
+
+ Append (Buf, Temp);
+ end;
+ end if;
+ end Append_Decoded_With_Brackets;
+
+ --------------------
+ -- Append_Encoded --
+ --------------------
+
+ procedure Append_Encoded (Buf : in out Bounded_String; C : Char_Code) is
+ procedure Set_Hex_Chars (C : Char_Code);
+ -- Stores given value, which is in the range 0 .. 255, as two hex
+ -- digits (using lower case a-f) in Buf.Chars, incrementing Buf.Length.
+
+ -------------------
+ -- Set_Hex_Chars --
+ -------------------
+
+ procedure Set_Hex_Chars (C : Char_Code) is
+ Hexd : constant String := "0123456789abcdef";
+ N : constant Natural := Natural (C);
+ begin
+ Buf.Chars (Buf.Length + 1) := Hexd (N / 16 + 1);
+ Buf.Chars (Buf.Length + 2) := Hexd (N mod 16 + 1);
+ Buf.Length := Buf.Length + 2;
+ end Set_Hex_Chars;
+
+ -- Start of processing for Append_Encoded
+
+ begin
+ Buf.Length := Buf.Length + 1;
+
+ if In_Character_Range (C) then
+ declare
+ CC : constant Character := Get_Character (C);
+ begin
+ if CC in 'a' .. 'z' or else CC in '0' .. '9' then
+ Buf.Chars (Buf.Length) := CC;
else
- P := P + 1;
+ Buf.Chars (Buf.Length) := 'U';
+ Set_Hex_Chars (C);
end if;
- end loop;
+ end;
+
+ elsif In_Wide_Character_Range (C) then
+ Buf.Chars (Buf.Length) := 'W';
+ Set_Hex_Chars (C / 256);
+ Set_Hex_Chars (C mod 256);
+
+ else
+ Buf.Chars (Buf.Length) := 'W';
+ Buf.Length := Buf.Length + 1;
+ Buf.Chars (Buf.Length) := 'W';
+ Set_Hex_Chars (C / 2 ** 24);
+ Set_Hex_Chars ((C / 2 ** 16) mod 256);
+ Set_Hex_Chars ((C / 256) mod 256);
+ Set_Hex_Chars (C mod 256);
+ end if;
+ end Append_Encoded;
+
+ ------------------------
+ -- Append_Unqualified --
+ ------------------------
+
+ procedure Append_Unqualified (Buf : in out Bounded_String; Id : Name_Id) is
+ Temp : Bounded_String;
+ begin
+ Append (Temp, Id);
+ Strip_Qualification_And_Suffixes (Temp);
+ Append (Buf, Temp);
+ end Append_Unqualified;
+
+ --------------------------------
+ -- Append_Unqualified_Decoded --
+ --------------------------------
+
+ procedure Append_Unqualified_Decoded
+ (Buf : in out Bounded_String;
+ Id : Name_Id)
+ is
+ Temp : Bounded_String;
+ begin
+ Append_Decoded (Temp, Id);
+ Strip_Qualification_And_Suffixes (Temp);
+ Append (Buf, Temp);
+ end Append_Unqualified_Decoded;
+
+ --------------
+ -- Finalize --
+ --------------
+
+ procedure Finalize is
+ F : array (Int range 0 .. 50) of Int;
+ -- N'th entry is the number of chains of length N, except last entry,
+ -- which is the number of chains of length F'Last or more.
+
+ Max_Chain_Length : Nat := 0;
+ -- Maximum length of all chains
+
+ Probes : Nat := 0;
+ -- Used to compute average number of probes
+
+ Nsyms : Nat := 0;
+ -- Number of symbols in table
+
+ Verbosity : constant Int range 1 .. 3 := 1;
+ pragma Warnings (Off, Verbosity);
+ -- This constant indicates the level of verbosity in the output from
+ -- this procedure. Currently this can only be changed by editing the
+ -- declaration above and recompiling. That's good enough in practice,
+ -- since we very rarely need to use this debug option. Settings are:
+ --
+ -- 1 => print basic summary information
+ -- 2 => in addition print number of entries per hash chain
+ -- 3 => in addition print content of entries
+
+ Zero : constant Int := Character'Pos ('0');
+
+ begin
+ if not Debug_Flag_H then
+ return;
end if;
+
+ for J in F'Range loop
+ F (J) := 0;
+ end loop;
+
+ for J in Hash_Index_Type loop
+ if Hash_Table (J) = No_Name then
+ F (0) := F (0) + 1;
+
+ else
+ declare
+ C : Nat;
+ N : Name_Id;
+ S : Int;
+
+ begin
+ C := 0;
+ N := Hash_Table (J);
+
+ while N /= No_Name loop
+ N := Name_Entries.Table (N).Hash_Link;
+ C := C + 1;
+ end loop;
+
+ Nsyms := Nsyms + 1;
+ Probes := Probes + (1 + C) * 100;
+
+ if C > Max_Chain_Length then
+ Max_Chain_Length := C;
+ end if;
+
+ if Verbosity >= 2 then
+ Write_Str ("Hash_Table (");
+ Write_Int (J);
+ Write_Str (") has ");
+ Write_Int (C);
+ Write_Str (" entries");
+ Write_Eol;
+ end if;
+
+ if C < F'Last then
+ F (C) := F (C) + 1;
+ else
+ F (F'Last) := F (F'Last) + 1;
+ end if;
+
+ if Verbosity >= 3 then
+ N := Hash_Table (J);
+ while N /= No_Name loop
+ S := Name_Entries.Table (N).Name_Chars_Index;
+
+ Write_Str (" ");
+
+ for J in 1 .. Name_Entries.Table (N).Name_Len loop
+ Write_Char (Name_Chars.Table (S + Int (J)));
+ end loop;
+
+ Write_Eol;
+
+ N := Name_Entries.Table (N).Hash_Link;
+ end loop;
+ end if;
+ end;
+ end if;
+ end loop;
+
+ Write_Eol;
+
+ for J in F'Range loop
+ if F (J) /= 0 then
+ Write_Str ("Number of hash chains of length ");
+
+ if J < 10 then
+ Write_Char (' ');
+ end if;
+
+ Write_Int (J);
+
+ if J = F'Last then
+ Write_Str (" or greater");
+ end if;
+
+ Write_Str (" = ");
+ Write_Int (F (J));
+ Write_Eol;
+ end if;
+ end loop;
+
+ -- Print out average number of probes, in the case where Name_Find is
+ -- called for a string that is already in the table.
+
+ Write_Eol;
+ Write_Str ("Average number of probes for lookup = ");
+ Probes := Probes / Nsyms;
+ Write_Int (Probes / 200);
+ Write_Char ('.');
+ Probes := (Probes mod 200) / 2;
+ Write_Char (Character'Val (Zero + Probes / 10));
+ Write_Char (Character'Val (Zero + Probes mod 10));
+ Write_Eol;
+
+ Write_Str ("Max_Chain_Length = ");
+ Write_Int (Max_Chain_Length);
+ Write_Eol;
+ Write_Str ("Name_Chars'Length = ");
+ Write_Int (Name_Chars.Last - Name_Chars.First + 1);
+ Write_Eol;
+ Write_Str ("Name_Entries'Length = ");
+ Write_Int (Int (Name_Entries.Last - Name_Entries.First + 1));
+ Write_Eol;
+ Write_Str ("Nsyms = ");
+ Write_Int (Nsyms);
+ Write_Eol;
+ end Finalize;
+
+ -----------------------------
+ -- Get_Decoded_Name_String --
+ -----------------------------
+
+ procedure Get_Decoded_Name_String (Id : Name_Id) is
+ begin
+ Global_Name_Buffer.Length := 0;
+ Append_Decoded (Global_Name_Buffer, Id);
+ end Get_Decoded_Name_String;
+
+ -------------------------------------------
+ -- Get_Decoded_Name_String_With_Brackets --
+ -------------------------------------------
+
+ procedure Get_Decoded_Name_String_With_Brackets (Id : Name_Id) is
+ begin
+ Global_Name_Buffer.Length := 0;
+ Append_Decoded_With_Brackets (Global_Name_Buffer, Id);
end Get_Decoded_Name_String_With_Brackets;
------------------------
@@ -650,45 +799,17 @@ package body Namet is
-- Get_Name_String --
---------------------
- -- Procedure version leaving result in Name_Buffer, length in Name_Len
-
procedure Get_Name_String (Id : Name_Id) is
- S : Int;
-
begin
- pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
-
- S := Name_Entries.Table (Id).Name_Chars_Index;
- Name_Len := Natural (Name_Entries.Table (Id).Name_Len);
-
- for J in 1 .. Name_Len loop
- Name_Buffer (J) := Name_Chars.Table (S + Int (J));
- end loop;
+ Global_Name_Buffer.Length := 0;
+ Append (Global_Name_Buffer, Id);
end Get_Name_String;
- ---------------------
- -- Get_Name_String --
- ---------------------
-
- -- Function version returning a string
-
function Get_Name_String (Id : Name_Id) return String is
- S : Int;
-
+ Buf : Bounded_String;
begin
- pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
- S := Name_Entries.Table (Id).Name_Chars_Index;
-
- declare
- R : String (1 .. Natural (Name_Entries.Table (Id).Name_Len));
-
- begin
- for J in R'Range loop
- R (J) := Name_Chars.Table (S + Int (J));
- end loop;
-
- return R;
- end;
+ Append (Buf, Id);
+ return +Buf;
end Get_Name_String;
--------------------------------
@@ -696,17 +817,8 @@ package body Namet is
--------------------------------
procedure Get_Name_String_And_Append (Id : Name_Id) is
- S : Int;
-
begin
- pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
-
- S := Name_Entries.Table (Id).Name_Chars_Index;
-
- for J in 1 .. Natural (Name_Entries.Table (Id).Name_Len) loop
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := Name_Chars.Table (S + Int (J));
- end loop;
+ Append (Global_Name_Buffer, Id);
end Get_Name_String_And_Append;
-----------------------------
@@ -765,8 +877,8 @@ package body Namet is
procedure Get_Unqualified_Decoded_Name_String (Id : Name_Id) is
begin
- Get_Decoded_Name_String (Id);
- Strip_Qualification_And_Suffixes;
+ Global_Name_Buffer.Length := 0;
+ Append_Unqualified_Decoded (Global_Name_Buffer, Id);
end Get_Unqualified_Decoded_Name_String;
---------------------------------
@@ -775,15 +887,15 @@ package body Namet is
procedure Get_Unqualified_Name_String (Id : Name_Id) is
begin
- Get_Name_String (Id);
- Strip_Qualification_And_Suffixes;
+ Global_Name_Buffer.Length := 0;
+ Append_Unqualified (Global_Name_Buffer, Id);
end Get_Unqualified_Name_String;
----------
-- Hash --
----------
- function Hash return Hash_Index_Type is
+ function Hash (Buf : Bounded_String) return Hash_Index_Type is
-- This hash function looks at every character, in order to make it
-- likely that similar strings get different hash values. The rotate by
@@ -800,8 +912,8 @@ package body Namet is
Result : Unsigned_16 := 0;
begin
- for J in 1 .. Name_Len loop
- Result := Rotate_Left (Result, 7) xor Character'Pos (Name_Buffer (J));
+ for J in 1 .. Buf.Length loop
+ Result := Rotate_Left (Result, 7) xor Character'Pos (Buf.Chars (J));
end loop;
return Hash_Index_Type (Result);
@@ -816,55 +928,51 @@ package body Namet is
null;
end Initialize;
+ ----------------
+ -- Insert_Str --
+ ----------------
+
+ procedure Insert_Str
+ (Buf : in out Bounded_String;
+ S : String;
+ Index : Positive)
+ is
+ SL : constant Natural := S'Length;
+
+ begin
+ Buf.Chars (Index + SL .. Buf.Length + SL) :=
+ Buf.Chars (Index .. Buf.Length);
+ Buf.Chars (Index .. Index + SL - 1) := S;
+ Buf.Length := Buf.Length + SL;
+ end Insert_Str;
+
-------------------------------
-- Insert_Str_In_Name_Buffer --
-------------------------------
procedure Insert_Str_In_Name_Buffer (S : String; Index : Positive) is
- SL : constant Natural := S'Length;
begin
- Name_Buffer (Index + SL .. Name_Len + SL) :=
- Name_Buffer (Index .. Name_Len);
- Name_Buffer (Index .. Index + SL - 1) := S;
- Name_Len := Name_Len + SL;
+ Insert_Str (Global_Name_Buffer, S, Index);
end Insert_Str_In_Name_Buffer;
----------------------
-- Is_Internal_Name --
----------------------
- -- Version taking an argument
-
- function Is_Internal_Name (Id : Name_Id) return Boolean is
- begin
- if Id in Error_Name_Or_No_Name then
- return False;
- else
- Get_Name_String (Id);
- return Is_Internal_Name;
- end if;
- end Is_Internal_Name;
-
- ----------------------
- -- Is_Internal_Name --
- ----------------------
-
- -- Version taking its input from Name_Buffer
-
- function Is_Internal_Name return Boolean is
+ function Is_Internal_Name (Buf : Bounded_String) return Boolean is
J : Natural;
begin
- -- AAny name starting with underscore is internal
+ -- Any name starting or ending with underscore is internal
- if Name_Buffer (1) = '_'
- or else Name_Buffer (Name_Len) = '_'
+ if Buf.Chars (1) = '_'
+ or else Buf.Chars (Buf.Length) = '_'
then
return True;
-- Allow quoted character
- elsif Name_Buffer (1) = ''' then
+ elsif Buf.Chars (1) = ''' then
return False;
-- All other cases, scan name
@@ -873,30 +981,30 @@ package body Namet is
-- Test backwards, because we only want to test the last entity
-- name if the name we have is qualified with other entities.
- J := Name_Len;
+ J := Buf.Length;
while J /= 0 loop
-- Skip stuff between brackets (A-F OK there)
- if Name_Buffer (J) = ']' then
+ if Buf.Chars (J) = ']' then
loop
J := J - 1;
- exit when J = 1 or else Name_Buffer (J) = '[';
+ exit when J = 1 or else Buf.Chars (J) = '[';
end loop;
-- Test for internal letter
- elsif Is_OK_Internal_Letter (Name_Buffer (J)) then
+ elsif Is_OK_Internal_Letter (Buf.Chars (J)) then
return True;
-- Quit if we come to terminating double underscore (note that
-- if the current character is an underscore, we know that
-- there is a previous character present, since we already
- -- filtered out the case of Name_Buffer (1) = '_' above.
+ -- filtered out the case of Buf.Chars (1) = '_' above.
- elsif Name_Buffer (J) = '_'
- and then Name_Buffer (J - 1) = '_'
- and then Name_Buffer (J - 2) /= '_'
+ elsif Buf.Chars (J) = '_'
+ and then Buf.Chars (J - 1) = '_'
+ and then Buf.Chars (J - 2) /= '_'
then
return False;
end if;
@@ -908,6 +1016,22 @@ package body Namet is
return False;
end Is_Internal_Name;
+ function Is_Internal_Name (Id : Name_Id) return Boolean is
+ Buf : Bounded_String;
+ begin
+ if Id in Error_Name_Or_No_Name then
+ return False;
+ else
+ Append (Buf, Id);
+ return Is_Internal_Name (Buf);
+ end if;
+ end Is_Internal_Name;
+
+ function Is_Internal_Name return Boolean is
+ begin
+ return Is_Internal_Name (Global_Name_Buffer);
+ end Is_Internal_Name;
+
---------------------------
-- Is_OK_Internal_Letter --
---------------------------
@@ -979,11 +1103,13 @@ package body Namet is
-- Name_Enter --
----------------
- function Name_Enter return Name_Id is
+ function Name_Enter
+ (Buf : Bounded_String := Global_Name_Buffer) return Name_Id
+ is
begin
Name_Entries.Append
((Name_Chars_Index => Name_Chars.Last,
- Name_Len => Short (Name_Len),
+ Name_Len => Short (Buf.Length),
Byte_Info => 0,
Int_Info => 0,
Boolean1_Info => False,
@@ -994,8 +1120,8 @@ package body Namet is
-- Set corresponding string entry in the Name_Chars table
- for J in 1 .. Name_Len loop
- Name_Chars.Append (Name_Buffer (J));
+ for J in 1 .. Buf.Length loop
+ Name_Chars.Append (Buf.Chars (J));
end loop;
Name_Chars.Append (ASCII.NUL);
@@ -1025,7 +1151,9 @@ package body Namet is
-- Name_Find --
---------------
- function Name_Find return Name_Id is
+ function Name_Find
+ (Buf : Bounded_String := Global_Name_Buffer) return Name_Id
+ is
New_Id : Name_Id;
-- Id of entry in hash search, and value to be returned
@@ -1038,13 +1166,13 @@ package body Namet is
begin
-- Quick handling for one character names
- if Name_Len = 1 then
- return Name_Id (First_Name_Id + Character'Pos (Name_Buffer (1)));
+ if Buf.Length = 1 then
+ return Name_Id (First_Name_Id + Character'Pos (Buf.Chars (1)));
-- Otherwise search hash table for existing matching entry
else
- Hash_Index := Namet.Hash;
+ Hash_Index := Namet.Hash (Buf);
New_Id := Hash_Table (Hash_Index);
if New_Id = No_Name then
@@ -1052,7 +1180,7 @@ package body Namet is
else
Search : loop
- if Name_Len /=
+ if Buf.Length /=
Integer (Name_Entries.Table (New_Id).Name_Len)
then
goto No_Match;
@@ -1060,8 +1188,8 @@ package body Namet is
S := Name_Entries.Table (New_Id).Name_Chars_Index;
- for J in 1 .. Name_Len loop
- if Name_Chars.Table (S + Int (J)) /= Name_Buffer (J) then
+ for J in 1 .. Buf.Length loop
+ if Name_Chars.Table (S + Int (J)) /= Buf.Chars (J) then
goto No_Match;
end if;
end loop;
@@ -1087,7 +1215,7 @@ package body Namet is
Name_Entries.Append
((Name_Chars_Index => Name_Chars.Last,
- Name_Len => Short (Name_Len),
+ Name_Len => Short (Buf.Length),
Hash_Link => No_Name,
Name_Has_No_Encodings => False,
Int_Info => 0,
@@ -1098,8 +1226,8 @@ package body Namet is
-- Set corresponding string entry in the Name_Chars table
- for J in 1 .. Name_Len loop
- Name_Chars.Append (Name_Buffer (J));
+ for J in 1 .. Buf.Length loop
+ Name_Chars.Append (Buf.Chars (J));
end loop;
Name_Chars.Append (ASCII.NUL);
@@ -1108,16 +1236,12 @@ package body Namet is
end if;
end Name_Find;
- -------------------
- -- Name_Find_Str --
- -------------------
-
- function Name_Find_Str (S : String) return Name_Id is
+ function Name_Find (S : String) return Name_Id is
+ Buf : Bounded_String;
begin
- Name_Len := S'Length;
- Name_Buffer (1 .. Name_Len) := S;
- return Name_Find;
- end Name_Find_Str;
+ Append (Buf, S);
+ return Name_Find (Buf);
+ end Name_Find;
-------------
-- Nam_In --
@@ -1313,35 +1437,43 @@ package body Namet is
T = V11;
end Nam_In;
+ function Nam_In
+ (T : Name_Id;
+ V1 : Name_Id;
+ V2 : Name_Id;
+ V3 : Name_Id;
+ V4 : Name_Id;
+ V5 : Name_Id;
+ V6 : Name_Id;
+ V7 : Name_Id;
+ V8 : Name_Id;
+ V9 : Name_Id;
+ V10 : Name_Id;
+ V11 : Name_Id;
+ V12 : Name_Id) return Boolean
+ is
+ begin
+ return T = V1 or else
+ T = V2 or else
+ T = V3 or else
+ T = V4 or else
+ T = V5 or else
+ T = V6 or else
+ T = V7 or else
+ T = V8 or else
+ T = V9 or else
+ T = V10 or else
+ T = V11 or else
+ T = V12;
+ end Nam_In;
+
-----------------
-- Name_Equals --
-----------------
function Name_Equals (N1 : Name_Id; N2 : Name_Id) return Boolean is
begin
- if N1 = N2 then
- return True;
- end if;
-
- declare
- L1 : constant Int := Int (Name_Entries.Table (N1).Name_Len);
- L2 : constant Int := Int (Name_Entries.Table (N2).Name_Len);
-
- begin
- if L1 /= L2 then
- return False;
- end if;
-
- declare
- use Name_Chars;
- I1 : constant Int := Name_Entries.Table (N1).Name_Chars_Index;
- I2 : constant Int := Name_Entries.Table (N2).Name_Chars_Index;
-
- begin
- return (Name_Chars.Table (1 + I1 .. I1 + L1) =
- Name_Chars.Table (1 + I2 .. I2 + L2));
- end;
- end;
+ return N1 = N2 or else Get_Name_String (N1) = Get_Name_String (N2);
end Name_Equals;
------------------
@@ -1394,11 +1526,19 @@ package body Namet is
-- Set_Character_Literal_Name --
--------------------------------
+ procedure Set_Character_Literal_Name
+ (Buf : in out Bounded_String;
+ C : Char_Code)
+ is
+ begin
+ Buf.Length := 0;
+ Append (Buf, 'Q');
+ Append_Encoded (Buf, C);
+ end Set_Character_Literal_Name;
+
procedure Set_Character_Literal_Name (C : Char_Code) is
begin
- Name_Buffer (1) := 'Q';
- Name_Len := 1;
- Store_Encoded_Character (C);
+ Set_Character_Literal_Name (Global_Name_Buffer, C);
end Set_Character_Literal_Name;
-----------------------------
@@ -1456,89 +1596,43 @@ package body Namet is
-----------------------------
procedure Store_Encoded_Character (C : Char_Code) is
- procedure Set_Hex_Chars (C : Char_Code);
- -- Stores given value, which is in the range 0 .. 255, as two hex
- -- digits (using lower case a-f) in Name_Buffer, incrementing Name_Len.
-
- -------------------
- -- Set_Hex_Chars --
- -------------------
-
- procedure Set_Hex_Chars (C : Char_Code) is
- Hexd : constant String := "0123456789abcdef";
- N : constant Natural := Natural (C);
- begin
- Name_Buffer (Name_Len + 1) := Hexd (N / 16 + 1);
- Name_Buffer (Name_Len + 2) := Hexd (N mod 16 + 1);
- Name_Len := Name_Len + 2;
- end Set_Hex_Chars;
-
- -- Start of processing for Store_Encoded_Character
-
begin
- Name_Len := Name_Len + 1;
-
- if In_Character_Range (C) then
- declare
- CC : constant Character := Get_Character (C);
- begin
- if CC in 'a' .. 'z' or else CC in '0' .. '9' then
- Name_Buffer (Name_Len) := CC;
- else
- Name_Buffer (Name_Len) := 'U';
- Set_Hex_Chars (C);
- end if;
- end;
-
- elsif In_Wide_Character_Range (C) then
- Name_Buffer (Name_Len) := 'W';
- Set_Hex_Chars (C / 256);
- Set_Hex_Chars (C mod 256);
-
- else
- Name_Buffer (Name_Len) := 'W';
- Name_Len := Name_Len + 1;
- Name_Buffer (Name_Len) := 'W';
- Set_Hex_Chars (C / 2 ** 24);
- Set_Hex_Chars ((C / 2 ** 16) mod 256);
- Set_Hex_Chars ((C / 256) mod 256);
- Set_Hex_Chars (C mod 256);
- end if;
+ Append_Encoded (Global_Name_Buffer, C);
end Store_Encoded_Character;
--------------------------------------
-- Strip_Qualification_And_Suffixes --
--------------------------------------
- procedure Strip_Qualification_And_Suffixes is
+ procedure Strip_Qualification_And_Suffixes (Buf : in out Bounded_String) is
J : Integer;
begin
-- Strip package body qualification string off end
- for J in reverse 2 .. Name_Len loop
- if Name_Buffer (J) = 'X' then
- Name_Len := J - 1;
+ for J in reverse 2 .. Buf.Length loop
+ if Buf.Chars (J) = 'X' then
+ Buf.Length := J - 1;
exit;
end if;
- exit when Name_Buffer (J) /= 'b'
- and then Name_Buffer (J) /= 'n'
- and then Name_Buffer (J) /= 'p';
+ exit when Buf.Chars (J) /= 'b'
+ and then Buf.Chars (J) /= 'n'
+ and then Buf.Chars (J) /= 'p';
end loop;
-- Find rightmost __ or $ separator if one exists. First we position
-- to start the search. If we have a character constant, position
-- just before it, otherwise position to last character but one
- if Name_Buffer (Name_Len) = ''' then
- J := Name_Len - 2;
- while J > 0 and then Name_Buffer (J) /= ''' loop
+ if Buf.Chars (Buf.Length) = ''' then
+ J := Buf.Length - 2;
+ while J > 0 and then Buf.Chars (J) /= ''' loop
J := J - 1;
end loop;
else
- J := Name_Len - 1;
+ J := Buf.Length - 1;
end if;
-- Loop to search for rightmost __ or $ (homonym) separator
@@ -1547,28 +1641,28 @@ package body Namet is
-- If $ separator, homonym separator, so strip it and keep looking
- if Name_Buffer (J) = '$' then
- Name_Len := J - 1;
- J := Name_Len - 1;
+ if Buf.Chars (J) = '$' then
+ Buf.Length := J - 1;
+ J := Buf.Length - 1;
-- Else check for __ found
- elsif Name_Buffer (J) = '_' and then Name_Buffer (J + 1) = '_' then
+ elsif Buf.Chars (J) = '_' and then Buf.Chars (J + 1) = '_' then
-- Found __ so see if digit follows, and if so, this is a
-- homonym separator, so strip it and keep looking.
- if Name_Buffer (J + 2) in '0' .. '9' then
- Name_Len := J - 1;
- J := Name_Len - 1;
+ if Buf.Chars (J + 2) in '0' .. '9' then
+ Buf.Length := J - 1;
+ J := Buf.Length - 1;
-- If not a homonym separator, then we simply strip the
-- separator and everything that precedes it, and we are done
else
- Name_Buffer (1 .. Name_Len - J - 1) :=
- Name_Buffer (J + 2 .. Name_Len);
- Name_Len := Name_Len - J - 1;
+ Buf.Chars (1 .. Buf.Length - J - 1) :=
+ Buf.Chars (J + 2 .. Buf.Length);
+ Buf.Length := Buf.Length - J - 1;
exit;
end if;
@@ -1579,6 +1673,15 @@ package body Namet is
end Strip_Qualification_And_Suffixes;
---------------
+ -- To_String --
+ ---------------
+
+ function To_String (Buf : Bounded_String) return String is
+ begin
+ return Buf.Chars (1 .. Buf.Length);
+ end To_String;
+
+ ---------------
-- Tree_Read --
---------------
@@ -1625,10 +1728,8 @@ package body Namet is
--------
procedure wn (Id : Name_Id) is
- S : Int;
-
begin
- if not Id'Valid then
+ if Id not in Name_Entries.First .. Name_Entries.Last then
Write_Str ("<invalid name_id>");
elsif Id = No_Name then
@@ -1638,12 +1739,12 @@ package body Namet is
Write_Str ("<Error_Name>");
else
- S := Name_Entries.Table (Id).Name_Chars_Index;
- Name_Len := Natural (Name_Entries.Table (Id).Name_Len);
-
- for J in 1 .. Name_Len loop
- Write_Char (Name_Chars.Table (S + Int (J)));
- end loop;
+ declare
+ Buf : Bounded_String;
+ begin
+ Append (Buf, Id);
+ Write_Str (Buf.Chars (1 .. Buf.Length));
+ end;
end if;
Write_Eol;
@@ -1654,10 +1755,11 @@ package body Namet is
----------------
procedure Write_Name (Id : Name_Id) is
+ Buf : Bounded_String;
begin
if Id >= First_Name_Id then
- Get_Name_String (Id);
- Write_Str (Name_Buffer (1 .. Name_Len));
+ Append (Buf, Id);
+ Write_Str (Buf.Chars (1 .. Buf.Length));
end if;
end Write_Name;
@@ -1666,10 +1768,11 @@ package body Namet is
------------------------
procedure Write_Name_Decoded (Id : Name_Id) is
+ Buf : Bounded_String;
begin
if Id >= First_Name_Id then
- Get_Decoded_Name_String (Id);
- Write_Str (Name_Buffer (1 .. Name_Len));
+ Append_Decoded (Buf, Id);
+ Write_Str (Buf.Chars (1 .. Buf.Length));
end if;
end Write_Name_Decoded;
diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads
index fa30a8ad78..8c1f124991 100644
--- a/gcc/ada/namet.ads
+++ b/gcc/ada/namet.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -31,7 +31,6 @@
with Alloc;
with Table;
-with Hostparm; use Hostparm;
with System; use System;
with Types; use Types;
@@ -51,7 +50,7 @@ package Namet is
-- Upper half (16#80# bit set) and wide characters are
-- stored in an encoded form (Uhh for upper half char,
-- Whhhh for wide characters, WWhhhhhhhh as provided by
--- the routine Store_Encoded_Character, where hh are hex
+-- the routine Append_Encoded, where hh are hex
-- digits for the character code using lower case a-f).
-- Normally the use of U or W in other internal names is
-- avoided, but these letters may be used in internal
@@ -149,21 +148,30 @@ package Namet is
-- and the Boolean field is initialized to False, when a new Name table entry
-- is created.
- Name_Buffer : String (1 .. 4 * Max_Line_Length);
- -- This buffer is used to set the name to be stored in the table for the
- -- Name_Find call, and to retrieve the name for the Get_Name_String call.
- -- The limit here is intended to be an infinite value that ensures that we
- -- never overflow the buffer (names this long are too absurd to worry).
-
- Name_Len : Natural := 0;
- -- Length of name stored in Name_Buffer. Used as an input parameter for
- -- Name_Find, and as an output value by Get_Name_String, or Write_Name.
- -- Note: in normal usage, all users of Name_Buffer/Name_Len are expected
- -- to initialize Name_Len appropriately. The reason we preinitialize to
- -- zero here is that some circuitry (e.g. Osint.Write_Program_Name) does
- -- a save/restore on Name_Len and Name_Buffer (1 .. Name_Len), and we do
- -- not want some arbitrary junk value to result in saving an arbitrarily
- -- long slice which would waste time and blow the stack.
+ type Bounded_String (Max_Length : Natural := 2**12) is limited
+ -- It's unlikely to have names longer than this. But we don't want to make
+ -- it too big, because we declare these on the stack in recursive routines.
+ record
+ Length : Natural := 0;
+ Chars : String (1 .. Max_Length);
+ end record;
+
+ -- To create a Name_Id, you can declare a Bounded_String as a local
+ -- variable, and Append things onto it, and finally call Name_Find.
+ -- You can also use a String, as in:
+ -- X := Name_Find (Some_String & "_some_suffix");
+
+ -- For historical reasons, we also have the Global_Name_Buffer below,
+ -- which is used by most of the code via the renamings. New code ought
+ -- to avoid the global.
+
+ Global_Name_Buffer : Bounded_String;
+ Name_Buffer : String renames Global_Name_Buffer.Chars;
+ Name_Len : Natural renames Global_Name_Buffer.Length;
+
+ -- Note that there is some circuitry (e.g. Osint.Write_Program_Name) that
+ -- does a save/restore on Name_Len and Name_Buffer (1 .. Name_Len). This
+ -- works in part because Name_Len is default-initialized to 0.
-----------------------------
-- Types for Namet Package --
@@ -302,6 +310,21 @@ package Namet is
V10 : Name_Id;
V11 : Name_Id) return Boolean;
+ function Nam_In
+ (T : Name_Id;
+ V1 : Name_Id;
+ V2 : Name_Id;
+ V3 : Name_Id;
+ V4 : Name_Id;
+ V5 : Name_Id;
+ V6 : Name_Id;
+ V7 : Name_Id;
+ V8 : Name_Id;
+ V9 : Name_Id;
+ V10 : Name_Id;
+ V11 : Name_Id;
+ V12 : Name_Id) return Boolean;
+
pragma Inline (Nam_In);
-- Inline all above functions
@@ -309,41 +332,114 @@ package Namet is
-- Subprograms --
-----------------
- procedure Add_Char_To_Name_Buffer (C : Character);
- pragma Inline (Add_Char_To_Name_Buffer);
- -- Add given character to the end of the string currently stored in the
- -- Name_Buffer, incrementing Name_Len.
+ function To_String (Buf : Bounded_String) return String;
+ pragma Inline (To_String);
+ function "+" (Buf : Bounded_String) return String renames To_String;
+
+ function Name_Find
+ (Buf : Bounded_String := Global_Name_Buffer) return Name_Id;
+ function Name_Find (S : String) return Name_Id;
+ -- Name_Find searches the names table to see if the string has already been
+ -- stored. If so, the Id of the existing entry is returned. Otherwise a new
+ -- entry is created with its Name_Table_Int fields set to zero/false. Note
+ -- that it is permissible for Buf.Length to be zero to lookup the empty
+ -- name string.
+
+ function Name_Enter
+ (Buf : Bounded_String := Global_Name_Buffer) return Name_Id;
+ -- Name_Enter is similar to Name_Find. The difference is that it does not
+ -- search the table for an existing match, and also subsequent Name_Find
+ -- calls using the same name will not locate the entry created by this
+ -- call. Thus multiple calls to Name_Enter with the same name will create
+ -- multiple entries in the name table with different Name_Id values. This
+ -- is useful in the case of created names, which are never expected to be
+ -- looked up. Note: Name_Enter should never be used for one character
+ -- names, since these are efficiently located without hashing by Name_Find
+ -- in any case.
- procedure Add_Nat_To_Name_Buffer (V : Nat);
- -- Add decimal representation of given value to the end of the string
- -- currently stored in Name_Buffer, incrementing Name_Len as required.
+ function Name_Equals (N1 : Name_Id; N2 : Name_Id) return Boolean;
+ -- Return whether N1 and N2 denote the same character sequence
- procedure Add_Str_To_Name_Buffer (S : String);
- -- Add characters of string S to the end of the string currently stored in
- -- the Name_Buffer, incrementing Name_Len by the length of the string.
+ function Get_Name_String (Id : Name_Id) return String;
+ -- Returns the characters of Id as a String. The lower bound is 1.
+
+ -- The following Append procedures ignore any characters that don't fit in
+ -- Buf.
+
+ procedure Append (Buf : in out Bounded_String; C : Character);
+ -- Append C onto Buf
+ pragma Inline (Append);
+
+ procedure Append (Buf : in out Bounded_String; V : Nat);
+ -- Append decimal representation of V onto Buf
+
+ procedure Append (Buf : in out Bounded_String; S : String);
+ -- Append S onto Buf
+
+ procedure Append (Buf : in out Bounded_String; Buf2 : Bounded_String);
+ -- Append Buf2 onto Buf
+
+ procedure Append (Buf : in out Bounded_String; Id : Name_Id);
+ -- Append the characters of Id onto Buf. It is an error to call this with
+ -- one of the special name Id values (No_Name or Error_Name).
+
+ procedure Append_Decoded (Buf : in out Bounded_String; Id : Name_Id);
+ -- Same as Append, except that the result is decoded, so that upper half
+ -- characters and wide characters appear as originally found in the source
+ -- program text, operators have their source forms (special characters and
+ -- enclosed in quotes), and character literals appear surrounded by
+ -- apostrophes.
+
+ procedure Append_Decoded_With_Brackets
+ (Buf : in out Bounded_String;
+ Id : Name_Id);
+ -- Same as Append_Decoded, except that the brackets notation (Uhh
+ -- replaced by ["hh"], Whhhh replaced by ["hhhh"], WWhhhhhhhh replaced by
+ -- ["hhhhhhhh"]) is used for all non-lower half characters, regardless of
+ -- how Opt.Wide_Character_Encoding_Method is set, and also in that
+ -- characters in the range 16#80# .. 16#FF# are converted to brackets
+ -- notation in all cases. This routine can be used when there is a
+ -- requirement for a canonical representation not affected by the
+ -- character set options (e.g. in the binder generation of symbols).
+
+ procedure Append_Unqualified (Buf : in out Bounded_String; Id : Name_Id);
+ -- Same as Append, except that qualification (as defined in unit
+ -- Exp_Dbug) is removed (including both preceding __ delimited names, and
+ -- also the suffixes used to indicate package body entities and to
+ -- distinguish between overloaded entities). Note that names are not
+ -- qualified until just before the call to gigi, so this routine is only
+ -- needed by processing that occurs after gigi has been called. This
+ -- includes all ASIS processing, since ASIS works on the tree written
+ -- after gigi has been called.
- procedure Finalize;
- -- Called at the end of a use of the Namet package (before a subsequent
- -- call to Initialize). Currently this routine is only used to generate
- -- debugging output.
+ procedure Append_Unqualified_Decoded
+ (Buf : in out Bounded_String;
+ Id : Name_Id);
+ -- Same as Append_Unqualified, but decoded as for Append_Decoded
+
+ procedure Append_Encoded (Buf : in out Bounded_String; C : Char_Code);
+ -- Appends given character code at the end of Buf. Lower case letters and
+ -- digits are stored unchanged. Other 8-bit characters are stored using the
+ -- Uhh encoding (hh = hex code), other 16-bit wide character values are
+ -- stored using the Whhhh (hhhh = hex code) encoding, and other 32-bit wide
+ -- wide character values are stored using the WWhhhhhhhh (hhhhhhhh = hex
+ -- code). Note that this procedure does not fold upper case letters (they
+ -- are stored using the Uhh encoding).
+
+ procedure Set_Character_Literal_Name
+ (Buf : in out Bounded_String;
+ C : Char_Code);
+ -- This procedure sets the proper encoded name for the character literal
+ -- for the given character code.
- procedure Get_Decoded_Name_String (Id : Name_Id);
- -- Same calling sequence an interface as Get_Name_String, except that the
- -- result is decoded, so that upper half characters and wide characters
- -- appear as originally found in the source program text, operators have
- -- their source forms (special characters and enclosed in quotes), and
- -- character literals appear surrounded by apostrophes.
+ procedure Insert_Str
+ (Buf : in out Bounded_String;
+ S : String;
+ Index : Positive);
+ -- Inserts S in Buf, starting at Index. Any existing characters at or past
+ -- this location get moved beyond the inserted string.
- procedure Get_Decoded_Name_String_With_Brackets (Id : Name_Id);
- -- This routine is similar to Decoded_Name, except that the brackets
- -- notation (Uhh replaced by ["hh"], Whhhh replaced by ["hhhh"],
- -- WWhhhhhhhh replaced by ["hhhhhhhh"]) is used for all non-lower half
- -- characters, regardless of how Opt.Wide_Character_Encoding_Method is
- -- set, and also in that characters in the range 16#80# .. 16#FF# are
- -- converted to brackets notation in all cases. This routine can be used
- -- when there is a requirement for a canonical representation not affected
- -- by the character set options (e.g. in the binder generation of
- -- symbols).
+ function Is_Internal_Name (Buf : Bounded_String) return Boolean;
procedure Get_Last_Two_Chars
(N : Name_Id;
@@ -353,21 +449,6 @@ package Namet is
-- C2 is last character. If name is less than two characters long then both
-- C1 and C2 are set to ASCII.NUL on return.
- procedure Get_Name_String (Id : Name_Id);
- -- Get_Name_String is used to retrieve the string associated with an entry
- -- in the names table. The resulting string is stored in Name_Buffer and
- -- Name_Len is set. It is an error to call Get_Name_String with one of the
- -- special name Id values (No_Name or Error_Name).
-
- function Get_Name_String (Id : Name_Id) return String;
- -- This functional form returns the result as a string without affecting
- -- the contents of either Name_Buffer or Name_Len. The lower bound is 1.
-
- procedure Get_Name_String_And_Append (Id : Name_Id);
- -- Like Get_Name_String but the resulting characters are appended to the
- -- current contents of the entry stored in Name_Buffer, and Name_Len is
- -- incremented to include the added characters.
-
function Get_Name_Table_Boolean1 (Id : Name_Id) return Boolean;
function Get_Name_Table_Boolean2 (Id : Name_Id) return Boolean;
function Get_Name_Table_Boolean3 (Id : Name_Id) return Boolean;
@@ -381,48 +462,23 @@ package Namet is
pragma Inline (Get_Name_Table_Int);
-- Fetches the Int value associated with the given name
- procedure Get_Unqualified_Decoded_Name_String (Id : Name_Id);
- -- Similar to the above except that qualification (as defined in unit
- -- Exp_Dbug) is removed (including both preceding __ delimited names, and
- -- also the suffix used to indicate package body entities). Note that
- -- names are not qualified until just before the call to gigi, so this
- -- routine is only needed by processing that occurs after gigi has been
- -- called. This includes all ASIS processing, since ASIS works on the tree
- -- written after gigi has been called.
-
- procedure Get_Unqualified_Name_String (Id : Name_Id);
- -- Similar to the above except that qualification (as defined in unit
- -- Exp_Dbug) is removed (including both preceding __ delimited names, and
- -- also the suffixes used to indicate package body entities and to
- -- distinguish between overloaded entities). Note that names are not
- -- qualified until just before the call to gigi, so this routine is only
- -- needed by processing that occurs after gigi has been called. This
- -- includes all ASIS processing, since ASIS works on the tree written
- -- after gigi has been called.
-
- procedure Initialize;
- -- This is a dummy procedure. It is retained for easy compatibility with
- -- clients who used to call Initialize when this call was required. Now
- -- initialization is performed automatically during package elaboration.
- -- Note that this change fixes problems which existed prior to the change
- -- of Initialize being called more than once. See also Reinitialize which
- -- allows reinitialization of the tables.
+ procedure Set_Name_Table_Boolean1 (Id : Name_Id; Val : Boolean);
+ procedure Set_Name_Table_Boolean2 (Id : Name_Id; Val : Boolean);
+ procedure Set_Name_Table_Boolean3 (Id : Name_Id; Val : Boolean);
+ -- Sets the Boolean value associated with the given name
- procedure Insert_Str_In_Name_Buffer (S : String; Index : Positive);
- -- Inserts given string in name buffer, starting at Index. Any existing
- -- characters at or past this location get moved beyond the inserted string
- -- and Name_Len is incremented by the length of the string.
+ procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte);
+ pragma Inline (Set_Name_Table_Byte);
+ -- Sets the Byte value associated with the given name
- function Is_Internal_Name return Boolean;
- -- Like the form with an Id argument, except that the name to be tested is
- -- passed in Name_Buffer and Name_Len (which are not affected by the call).
- -- Name_Buffer (it loads these as for Get_Name_String).
+ procedure Set_Name_Table_Int (Id : Name_Id; Val : Int);
+ pragma Inline (Set_Name_Table_Int);
+ -- Sets the Int value associated with the given name
function Is_Internal_Name (Id : Name_Id) return Boolean;
-- Returns True if the name is an internal name (i.e. contains a character
-- for which Is_OK_Internal_Letter is true, or if the name starts or ends
- -- with an underscore. This call destroys the value of Name_Len and
- -- Name_Buffer (it loads these as for Get_Name_String).
+ -- with an underscore.
--
-- Note: if the name is qualified (has a double underscore), then only the
-- final entity name is considered, not the qualifying names. Consider for
@@ -454,52 +510,15 @@ package Namet is
function Length_Of_Name (Id : Name_Id) return Nat;
pragma Inline (Length_Of_Name);
-- Returns length of given name in characters. This is the length of the
- -- encoded name, as stored in the names table, the result is equivalent to
- -- calling Get_Name_String and reading Name_Len, except that a call to
- -- Length_Of_Name does not affect the contents of Name_Len and Name_Buffer.
-
- procedure Lock;
- -- Lock name tables before calling back end. We reserve some extra space
- -- before locking to avoid unnecessary inefficiencies when we unlock.
-
- function Name_Chars_Address return System.Address;
- -- Return starting address of name characters table (used in Back_End call
- -- to Gigi).
-
- function Name_Enter return Name_Id;
- -- Name_Enter has the same calling interface as Name_Find. The difference
- -- is that it does not search the table for an existing match, and also
- -- subsequent Name_Find calls using the same name will not locate the
- -- entry created by this call. Thus multiple calls to Name_Enter with the
- -- same name will create multiple entries in the name table with different
- -- Name_Id values. This is useful in the case of created names, which are
- -- never expected to be looked up. Note: Name_Enter should never be used
- -- for one character names, since these are efficiently located without
- -- hashing by Name_Find in any case.
-
- function Name_Entries_Address return System.Address;
- -- Return starting address of Names table (used in Back_End call to Gigi)
-
- function Name_Entries_Count return Nat;
- -- Return current number of entries in the names table
+ -- encoded name, as stored in the names table.
- function Name_Equals (N1 : Name_Id; N2 : Name_Id) return Boolean;
- -- Return whether N1 and N2 denote the same character sequence
-
- function Name_Find return Name_Id;
- -- Name_Find is called with a string stored in Name_Buffer whose length is
- -- in Name_Len (i.e. the characters of the name are in subscript positions
- -- 1 to Name_Len in Name_Buffer). It searches the names table to see if the
- -- string has already been stored. If so the Id of the existing entry is
- -- returned. Otherwise a new entry is created with its Name_Table_Int
- -- fields set to zero/false. The contents of Name_Buffer and Name_Len are
- -- not modified by this call. Note that it is permissible for Name_Len to
- -- be set to zero to lookup the null name string.
-
- function Name_Find_Str (S : String) return Name_Id;
- -- Similar to Name_Find, except that the string is provided as an argument.
- -- This call destroys the contents of Name_Buffer and Name_Len (by storing
- -- the given string there.
+ procedure Initialize;
+ -- This is a dummy procedure. It is retained for easy compatibility with
+ -- clients who used to call Initialize when this call was required. Now
+ -- initialization is performed automatically during package elaboration.
+ -- Note that this change fixes problems which existed prior to the change
+ -- of Initialize being called more than once. See also Reinitialize which
+ -- allows reinitialization of the tables.
procedure Reinitialize;
-- Clears the name tables and removes all existing entries from the table.
@@ -511,34 +530,18 @@ package Namet is
-- compilation to another, but we can't keep the entity info, since this
-- refers to tree nodes, which are destroyed between each main source file.
- procedure Set_Character_Literal_Name (C : Char_Code);
- -- This procedure sets the proper encoded name for the character literal
- -- for the given character code. On return Name_Buffer and Name_Len are
- -- set to reflect the stored name.
-
- procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte);
- pragma Inline (Set_Name_Table_Byte);
- -- Sets the Byte value associated with the given name
-
- procedure Set_Name_Table_Int (Id : Name_Id; Val : Int);
- pragma Inline (Set_Name_Table_Int);
- -- Sets the Int value associated with the given name
+ procedure Finalize;
+ -- Called at the end of a use of the Namet package (before a subsequent
+ -- call to Initialize). Currently this routine is only used to generate
+ -- debugging output.
- procedure Set_Name_Table_Boolean1 (Id : Name_Id; Val : Boolean);
- procedure Set_Name_Table_Boolean2 (Id : Name_Id; Val : Boolean);
- procedure Set_Name_Table_Boolean3 (Id : Name_Id; Val : Boolean);
- -- Sets the Boolean value associated with the given name
+ procedure Lock;
+ -- Lock name tables before calling back end. We reserve some extra space
+ -- before locking to avoid unnecessary inefficiencies when we unlock.
- procedure Store_Encoded_Character (C : Char_Code);
- -- Stores given character code at the end of Name_Buffer, updating the
- -- value in Name_Len appropriately. Lower case letters and digits are
- -- stored unchanged. Other 8-bit characters are stored using the Uhh
- -- encoding (hh = hex code), other 16-bit wide character values are stored
- -- using the Whhhh (hhhh = hex code) encoding, and other 32-bit wide wide
- -- character values are stored using the WWhhhhhhhh (hhhhhhhh = hex code).
- -- Note that this procedure does not fold upper case letters (they are
- -- stored using the Uhh encoding). If folding is required, it must be done
- -- by the caller prior to the call.
+ procedure Unlock;
+ -- Unlocks the name table to allow use of the extra space reserved by the
+ -- call to Lock. See gnat1drv for details of the need for this.
procedure Tree_Read;
-- Initializes internal tables from current tree file using the relevant
@@ -549,22 +552,65 @@ package Namet is
-- Writes out internal tables to current tree file using the relevant
-- Table.Tree_Write routines.
- procedure Unlock;
- -- Unlocks the name table to allow use of the extra space reserved by the
- -- call to Lock. See gnat1drv for details of the need for this.
-
procedure Write_Name (Id : Name_Id);
-- Write_Name writes the characters of the specified name using the
- -- standard output procedures in package Output. No end of line is
- -- written, just the characters of the name. On return Name_Buffer and
- -- Name_Len are set as for a call to Get_Name_String. The name is written
+ -- standard output procedures in package Output. The name is written
-- in encoded form (i.e. including Uhh, Whhh, Qx, _op as they appear in
-- the name table). If Id is Error_Name, or No_Name, no text is output.
procedure Write_Name_Decoded (Id : Name_Id);
-- Like Write_Name, except that the name written is the decoded name, as
- -- described for Get_Decoded_Name_String, and the resulting value stored
- -- in Name_Len and Name_Buffer is the decoded name.
+ -- described for Append_Decoded.
+
+ function Name_Chars_Address return System.Address;
+ -- Return starting address of name characters table (used in Back_End call
+ -- to Gigi).
+
+ function Name_Entries_Address return System.Address;
+ -- Return starting address of Names table (used in Back_End call to Gigi)
+
+ function Name_Entries_Count return Nat;
+ -- Return current number of entries in the names table
+
+ --------------------------
+ -- Obsolete Subprograms --
+ --------------------------
+
+ -- The following routines operate on Global_Name_Buffer. New code should
+ -- use the routines above, and declare Bounded_Strings as local
+ -- variables. Existing code can be improved incrementally by removing calls
+ -- to the following. ???If we eliminate all of these, we can remove
+ -- Global_Name_Buffer. But be sure to look at namet.h first.
+
+ -- To see what these do, look at the bodies. They are all trivially defined
+ -- in terms of routines above.
+
+ procedure Add_Char_To_Name_Buffer (C : Character);
+ pragma Inline (Add_Char_To_Name_Buffer);
+
+ procedure Add_Nat_To_Name_Buffer (V : Nat);
+
+ procedure Add_Str_To_Name_Buffer (S : String);
+
+ procedure Get_Decoded_Name_String (Id : Name_Id);
+
+ procedure Get_Decoded_Name_String_With_Brackets (Id : Name_Id);
+
+ procedure Get_Name_String (Id : Name_Id);
+
+ procedure Get_Name_String_And_Append (Id : Name_Id);
+
+ procedure Get_Unqualified_Decoded_Name_String (Id : Name_Id);
+
+ procedure Get_Unqualified_Name_String (Id : Name_Id);
+
+ procedure Insert_Str_In_Name_Buffer (S : String; Index : Positive);
+
+ function Is_Internal_Name return Boolean;
+
+ procedure Set_Character_Literal_Name (C : Char_Code);
+
+ procedure Store_Encoded_Character (C : Char_Code);
------------------------------
-- File and Unit Name Types --
@@ -629,6 +675,8 @@ package Namet is
-- <No_Name>, <invalid name>). Unlike Write_Name, this call does not affect
-- the contents of Name_Buffer or Name_Len.
+private
+
---------------------------
-- Table Data Structures --
---------------------------
@@ -637,8 +685,6 @@ package Namet is
-- names. The definitions are in the private part of the package spec,
-- rather than the body, since they are referenced directly by gigi.
-private
-
-- This table stores the actual string names. Although logically there is
-- no need for a terminating character (since the length is stored in the
-- name entry table), we still store a NUL character at the end of every
@@ -673,8 +719,8 @@ private
Name_Has_No_Encodings : Boolean;
-- This flag is set True if the name entry is known not to contain any
-- special character encodings. This is used to speed up repeated calls
- -- to Get_Decoded_Name_String. A value of False means that it is not
- -- known whether the name contains any such encodings.
+ -- to Append_Decoded. A value of False means that it is not known
+ -- whether the name contains any such encodings.
Hash_Link : Name_Id;
-- Link to next entry in names table for same hash code
diff --git a/gcc/ada/namet.h b/gcc/ada/namet.h
index 82af02d58f..a016f93b93 100644
--- a/gcc/ada/namet.h
+++ b/gcc/ada/namet.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2015, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2016, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -25,7 +25,7 @@
/* This is the C file that corresponds to the Ada package specification
Namet. It was created manually from files namet.ads and namet.adb.
- Some subprograms from Sinput are also made acessable here. */
+ Subprograms from Exp_Dbug and Sinput are also made accessible here. */
#ifdef __cplusplus
extern "C" {
@@ -52,16 +52,27 @@ extern struct Name_Entry *Names_Ptr;
#define Name_Chars_Ptr namet__name_chars__table
extern char *Name_Chars_Ptr;
-#define Name_Buffer namet__name_buffer
-extern char Name_Buffer[];
+/* This is Hostparm.Max_Line_Length. */
+#define Max_Line_Length (32767 - 1)
-extern Int namet__name_len;
-#define Name_Len namet__name_len
+/* The global name buffer. */
+struct Bounded_String
+{
+ Nat Max_Length;
+ Nat Length;
+ char Chars[4 * Max_Line_Length]; /* Exact value for overflow detection. */
+};
+
+#define Global_Name_Buffer namet__global_name_buffer
+extern struct Bounded_String Global_Name_Buffer;
+
+#define Name_Buffer Global_Name_Buffer.Chars
+#define Name_Len Global_Name_Buffer.Length
-/* Get_Name_String returns a null terminated C string for the specified name.
+/* Get_Name_String returns a NUL terminated C string for the specified name.
We could use the official Ada routine for this purpose, but since the
strings we want are sitting in the name strings table in exactly the form
- we need them (null terminated), we just point to the name directly. */
+ we need them (NUL terminated), we just point to the name directly. */
static char *Get_Name_String (Name_Id);
@@ -71,32 +82,9 @@ Get_Name_String (Name_Id Id)
return Name_Chars_Ptr + Names_Ptr[Id - First_Name_Id].Name_Chars_Index + 1;
}
-/* Get_Decoded_Name_String returns a null terminated C string in the same
- manner as Get_Name_String, except that it is decoded (i.e. upper half or
- wide characters are put back in their external form, and character literals
- are also returned in their external form (with surrounding apostrophes) */
-
-extern void namet__get_decoded_name_string (Name_Id);
-
-static char *Get_Decoded_Name_String (Name_Id);
-
-INLINE char *
-Get_Decoded_Name_String (Name_Id Id)
-{
- namet__get_decoded_name_string (Id);
- Name_Buffer[Name_Len] = 0;
- return Name_Buffer;
-}
-
#define Name_Equals namet__name_equals
extern Boolean Name_Equals (Name_Id, Name_Id);
-/* Like Get_Decoded_Name_String, but the result has all qualification and
- package body entity suffixes stripped, and also all letters are upper
- cased. This is used for building the enumeration literal table. */
-
-extern void casing__set_all_upper_case (void);
-
/* The following routines and variables are not part of Namet, but we
include the header here since it seems the best place for it. */
diff --git a/gcc/ada/nlists.adb b/gcc/ada/nlists.adb
index dcb5dd41cb..db6a5c88ea 100644
--- a/gcc/ada/nlists.adb
+++ b/gcc/ada/nlists.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -40,6 +40,10 @@ with Sinfo; use Sinfo;
with Table;
package body Nlists is
+ Locked : Boolean := False;
+ -- Compiling with assertions enabled, list contents modifications are
+ -- permitted only when this switch is set to False; compiling without
+ -- assertions this lock has no effect.
use Atree_Private_Part;
-- Get access to Nodes table
@@ -90,6 +94,7 @@ package body Nlists is
Table_Low_Bound => First_Node_Id,
Table_Initial => Alloc.Orig_Nodes_Initial,
Table_Increment => Alloc.Orig_Nodes_Increment,
+ Release_Threshold => Alloc.Orig_Nodes_Release_Threshold,
Table_Name => "Next_Node");
package Prev_Node is new Table.Table (
@@ -202,7 +207,6 @@ package body Nlists is
-----------------
procedure Append_List (List : List_Id; To : List_Id) is
-
procedure Append_List_Debug;
pragma Inline (Append_List_Debug);
-- Output debug information if Debug_Flag_N set
@@ -268,6 +272,28 @@ package body Nlists is
Append_List (List, To);
end Append_List_To;
+ ----------------
+ -- Append_New --
+ ----------------
+
+ procedure Append_New (Node : Node_Or_Entity_Id; To : in out List_Id) is
+ begin
+ if No (To) then
+ To := New_List;
+ end if;
+
+ Append (Node, To);
+ end Append_New;
+
+ -------------------
+ -- Append_New_To --
+ -------------------
+
+ procedure Append_New_To (To : in out List_Id; Node : Node_Or_Entity_Id) is
+ begin
+ Append_New (Node, To);
+ end Append_New_To;
+
---------------
-- Append_To --
---------------
@@ -705,6 +731,16 @@ package body Nlists is
Next_Node.Release;
end Lock;
+ ----------------
+ -- Lock_Lists --
+ ----------------
+
+ procedure Lock_Lists is
+ begin
+ pragma Assert (not Locked);
+ Locked := True;
+ end Lock_Lists;
+
-------------------
-- New_Copy_List --
-------------------
@@ -1136,6 +1172,28 @@ package body Nlists is
Prepend_List (List, To);
end Prepend_List_To;
+ -----------------
+ -- Prepend_New --
+ -----------------
+
+ procedure Prepend_New (Node : Node_Or_Entity_Id; To : in out List_Id) is
+ begin
+ if No (To) then
+ To := New_List;
+ end if;
+
+ Prepend (Node, To);
+ end Prepend_New;
+
+ --------------------
+ -- Prepend_New_To --
+ --------------------
+
+ procedure Prepend_New_To (To : in out List_Id; Node : Node_Or_Entity_Id) is
+ begin
+ Prepend_New (Node, To);
+ end Prepend_New_To;
+
----------------
-- Prepend_To --
----------------
@@ -1359,6 +1417,7 @@ package body Nlists is
procedure Set_First (List : List_Id; To : Node_Or_Entity_Id) is
begin
+ pragma Assert (not Locked);
Lists.Table (List).First := To;
end Set_First;
@@ -1368,6 +1427,7 @@ package body Nlists is
procedure Set_Last (List : List_Id; To : Node_Or_Entity_Id) is
begin
+ pragma Assert (not Locked);
Lists.Table (List).Last := To;
end Set_Last;
@@ -1377,6 +1437,7 @@ package body Nlists is
procedure Set_List_Link (Node : Node_Or_Entity_Id; To : List_Id) is
begin
+ pragma Assert (not Locked);
Nodes.Table (Node).Link := Union_Id (To);
end Set_List_Link;
@@ -1386,6 +1447,7 @@ package body Nlists is
procedure Set_Next (Node : Node_Or_Entity_Id; To : Node_Or_Entity_Id) is
begin
+ pragma Assert (not Locked);
Next_Node.Table (Node) := To;
end Set_Next;
@@ -1395,6 +1457,7 @@ package body Nlists is
procedure Set_Parent (List : List_Id; Node : Node_Or_Entity_Id) is
begin
+ pragma Assert (not Locked);
pragma Assert (List <= Lists.Last);
Lists.Table (List).Parent := Node;
end Set_Parent;
@@ -1405,6 +1468,7 @@ package body Nlists is
procedure Set_Prev (Node : Node_Or_Entity_Id; To : Node_Or_Entity_Id) is
begin
+ pragma Assert (not Locked);
Prev_Node.Table (Node) := To;
end Set_Prev;
@@ -1414,6 +1478,7 @@ package body Nlists is
procedure Tree_Read is
begin
+ pragma Assert (not Locked);
Lists.Tree_Read;
Next_Node.Tree_Read;
Prev_Node.Tree_Read;
@@ -1441,4 +1506,14 @@ package body Nlists is
Next_Node.Locked := False;
end Unlock;
+ ------------------
+ -- Unlock_Lists --
+ ------------------
+
+ procedure Unlock_Lists is
+ begin
+ pragma Assert (Locked);
+ Locked := False;
+ end Unlock_Lists;
+
end Nlists;
diff --git a/gcc/ada/nlists.ads b/gcc/ada/nlists.ads
index 5950b4a71a..de3e28f626 100644
--- a/gcc/ada/nlists.ads
+++ b/gcc/ada/nlists.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -229,6 +229,16 @@ package Nlists is
-- An attempt to append an error node is ignored without complaint and the
-- list is unchanged.
+ procedure Append_New (Node : Node_Or_Entity_Id; To : in out List_Id);
+ pragma Inline (Append_New);
+ -- Appends Node at the end of node list To. If To is non-existent list, a
+ -- list is created. Node must be a non-empty node that is not already a
+ -- member of a node list, and To must be a node list.
+
+ procedure Append_New_To (To : in out List_Id; Node : Node_Or_Entity_Id);
+ pragma Inline (Append_New_To);
+ -- Like Append_New, but the arguments are in reverse order
+
procedure Append_To (To : List_Id; Node : Node_Or_Entity_Id);
pragma Inline (Append_To);
-- Like Append, but arguments are the other way round
@@ -279,12 +289,6 @@ package Nlists is
-- node list. An attempt to prepend an error node is ignored without
-- complaint and the list is unchanged.
- procedure Prepend_To
- (To : List_Id;
- Node : Node_Or_Entity_Id);
- pragma Inline (Prepend_To);
- -- Like Prepend, but arguments are the other way round
-
procedure Prepend_List
(List : List_Id;
To : List_Id);
@@ -297,6 +301,22 @@ package Nlists is
pragma Inline (Prepend_List_To);
-- Like Prepend_List, but arguments are the other way round
+ procedure Prepend_New (Node : Node_Or_Entity_Id; To : in out List_Id);
+ pragma Inline (Prepend_New);
+ -- Prepends Node at the end of node list To. If To is non-existent list, a
+ -- list is created. Node must be a non-empty node that is not already a
+ -- member of a node list, and To must be a node list.
+
+ procedure Prepend_New_To (To : in out List_Id; Node : Node_Or_Entity_Id);
+ pragma Inline (Prepend_New_To);
+ -- Like Prepend_New, but the arguments are in reverse order
+
+ procedure Prepend_To
+ (To : List_Id;
+ Node : Node_Or_Entity_Id);
+ pragma Inline (Prepend_To);
+ -- Like Prepend, but arguments are the other way round
+
procedure Remove (Node : Node_Or_Entity_Id);
-- Removes Node, which must be a node that is a member of a node list,
-- from this node list. The contents of Node are not otherwise affected.
@@ -320,9 +340,18 @@ package Nlists is
procedure Lock;
-- Called to lock tables before back end is called
+ procedure Lock_Lists;
+ -- Called to lock list contents when assertions are enabled. Without
+ -- assertions calling this subprogram has no effect. The initial state
+ -- of the lock is unlocked.
+
procedure Unlock;
-- Unlock tables, in cases where the back end needs to modify them
+ procedure Unlock_Lists;
+ -- Called to unlock list contents when assertions are enabled; if
+ -- assertions are not enabled calling this subprogram has no effect.
+
procedure Tree_Read;
-- Initializes internal tables from current tree file using the relevant
-- Table.Tree_Read routines. Note that Initialize should not be called if
diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads
index 1766950f75..9ef851d841 100644
--- a/gcc/ada/opt.ads
+++ b/gcc/ada/opt.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -101,6 +101,11 @@ package Opt is
-- GPRBUILD
-- Set to True by gprbuild when the version of GNAT is 5.03 or before.
+ Checksum_Accumulate_Limited_Checksum : Boolean := False;
+ -- Used to control the computation of the limited view of a package.
+ -- (Not currently used, possible optimization for ALI files of units
+ -- in limited with_clauses).
+
----------------------------------------------
-- Settings of Modes for Current Processing --
----------------------------------------------
@@ -112,7 +117,12 @@ package Opt is
-- case of some binder variables, Gnatbind.Scan_Bind_Arg may modify
-- the default values.
- type Ada_Version_Type is (Ada_83, Ada_95, Ada_2005, Ada_2012);
+ Latest_Ada_Only : Boolean := False;
+ -- If True, the only value valid for Ada_Version is Ada_Version_Type'Last,
+ -- trying to specify other values will be ignored (in case of pragma
+ -- Ada_xxx) or generate an error (in case of -gnat83/95/xx switches).
+
+ type Ada_Version_Type is (Ada_83, Ada_95, Ada_2005, Ada_2012, Ada_2020);
pragma Ordered (Ada_Version_Type);
-- Versions of Ada for Ada_Version below. Note that these are ordered,
-- so that tests like Ada_Version >= Ada_95 are legitimate and useful.
@@ -203,6 +213,11 @@ package Opt is
-- Set to non-null when Bind_Alternate_Main_Name is True. This value
-- is modified as needed by Gnatbind.Scan_Bind_Arg.
+ ASIS_GNSA_Mode : Boolean := False;
+ -- GNAT
+ -- Enable GNSA back-end processing assuming ASIS_Mode is already set to
+ -- True. ASIS_GNSA mode suppresses the call to gigi.
+
ASIS_Mode : Boolean := False;
-- GNAT
-- Enable semantic checks and tree transformations that are important
@@ -692,6 +707,10 @@ package Opt is
-- GNATMAKE, GPRBUILD
-- Set to force recompilations even when the objects are up-to-date.
+ Force_Elab_Order_File : String_Ptr := null;
+ -- GNATBIND
+ -- File name specified for -f switch (the forced elaboration order file)
+
Front_End_Inlining : Boolean := False;
-- GNAT
-- Set True to activate inlining by front-end expansion (even on GCC
@@ -766,8 +785,7 @@ package Opt is
GNAT_Encodings : Int;
pragma Import (C, GNAT_Encodings, "gnat_encodings");
-- Constant controlling the balance between GNAT encodings and standard
- -- DWARF to emit in the debug information. See aamissing.c for definitions
- -- for the GNAAMP back end. It accepts the following values.
+ -- DWARF to emit in the debug information. It accepts the following values.
DWARF_GNAT_Encodings_All : constant Int := 0;
DWARF_GNAT_Encodings_GDB : constant Int := 1;
@@ -1061,6 +1079,12 @@ package Opt is
-- GNATMAKE
-- Set to True if minimal recompilation mode requested
+ Minimize_Expression_With_Actions : Boolean := False;
+ -- GNAT
+ -- If True, minimize the use of N_Expression_With_Actions node.
+ -- This can be used in particular on some back-ends where this node is
+ -- difficult to support.
+
Modify_Tree_For_C : Boolean := False;
-- GNAT
-- If this switch is set True (currently it is set only by -gnatd.V), then
@@ -1178,13 +1202,11 @@ package Opt is
Optimization_Level : Int;
pragma Import (C, Optimization_Level, "optimize");
-- Constant reflecting the optimization level (0,1,2,3 for -O0,-O1,-O2,-O3)
- -- See e.g. aamissing.c for definitions for the GNAAMP back end.
Optimize_Size : Int;
pragma Import (C, Optimize_Size, "optimize_size");
-- Constant reflecting setting of -Os (optimize for size). Set to nonzero
- -- in -Os mode and set to zero otherwise. See aamissing.c for definition
- -- of "optimize_size" for the GNAAMP backend.
+ -- in -Os mode and set to zero otherwise.
Output_File_Name_Present : Boolean := False;
-- GNATBIND, GNAT, GNATMAKE
@@ -1560,13 +1582,6 @@ package Opt is
-- If true, activates the circuitry for unnesting subprograms (see the spec
-- of Exp_Unst for full details). Currently set only by use of -gnatd.1.
- Universal_Addressing_On_AAMP : Boolean := False;
- -- GNAAMP
- -- Indicates if library-level objects should be accessed and updated using
- -- universal addressing instructions on the AAMP architecture. This flag is
- -- set to True when pragma Universal_Data is given as a configuration
- -- pragma.
-
Unreserve_All_Interrupts : Boolean := False;
-- GNAT, GNATBIND
-- Normally set False, set True if a valid Unreserve_All_Interrupts pragma
diff --git a/gcc/ada/osint-b.adb b/gcc/ada/osint-b.adb
index 554d804af9..322bc6cdba 100644
--- a/gcc/ada/osint-b.adb
+++ b/gcc/ada/osint-b.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -153,7 +153,7 @@ package body Osint.B is
-- More_Lib_Files --
--------------------
- function More_Lib_Files return Boolean renames More_Files;
+ function More_Lib_Files return Boolean renames More_Files;
------------------------
-- Next_Main_Lib_File --
diff --git a/gcc/ada/osint-c.adb b/gcc/ada/osint-c.adb
index a24a5a7389..62ccb7fca0 100644
--- a/gcc/ada/osint-c.adb
+++ b/gcc/ada/osint-c.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -292,6 +292,28 @@ package body Osint.C is
end if;
end Debug_File_Eol_Length;
+ -------------------
+ -- Delete_C_File --
+ -------------------
+
+ procedure Delete_C_File is
+ Dummy : Boolean;
+ begin
+ Set_File_Name ("c");
+ Delete_File (Name_Buffer (1 .. Name_Len), Dummy);
+ end Delete_C_File;
+
+ -------------------
+ -- Delete_H_File --
+ -------------------
+
+ procedure Delete_H_File is
+ Dummy : Boolean;
+ begin
+ Set_File_Name ("h");
+ Delete_File (Name_Buffer (1 .. Name_Len), Dummy);
+ end Delete_H_File;
+
---------------------------------
-- Get_Output_Object_File_Name --
---------------------------------
@@ -325,6 +347,14 @@ package body Osint.C is
is
begin
Set_File_Name (ALI_Suffix.all);
+
+ -- Remove trailing NUL that comes from Set_File_Name above. This is
+ -- needed for consistency with names that come from Scan_ALI and thus
+ -- preventing repeated scanning of the same file.
+
+ pragma Assert (Name_Len > 1 and then Name_Buffer (Name_Len) = ASCII.NUL);
+ Name_Len := Name_Len - 1;
+
Name := Name_Find;
Text := Read_Library_Info (Name, Fatal_Err => False);
end Read_Library_Info;
diff --git a/gcc/ada/osint-c.ads b/gcc/ada/osint-c.ads
index 6819ec037a..e7379175e9 100644
--- a/gcc/ada/osint-c.ads
+++ b/gcc/ada/osint-c.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -111,7 +111,8 @@ package Osint.C is
procedure Set_File_Name (Ext : String);
-- Sets a default file name from the main compiler source name. Ext is the
-- extension, e.g. "ali" for a library information file. The name is in
- -- Name_Buffer (with length in Name_Len) on return.
+ -- Name_Buffer (with length in Name_Len) on return, with
+ -- Name_Buffer (Name_Len) always set to ASCII.NUL.
--------------------------------
-- Library Information Output --
@@ -159,7 +160,7 @@ package Osint.C is
--------------------------
-- These routines are used by the compiler when the C translation option
- -- is activated to write *.c and *.h files to the current object directory.
+ -- is activated to write *.c or *.h files to the current object directory.
-- Each routine exists in a C and an H form for the two kinds of files.
-- Only one of these files can be written at a time. Note that the files
-- are written via the Output package routines, using Output_FD.
@@ -175,6 +176,11 @@ package Osint.C is
-- Closes the file created by Create_C_File or Create_H file, flushing any
-- buffers etc. from writes by Write_C_File and Write_H_File;
+ procedure Delete_C_File;
+ procedure Delete_H_File;
+ -- Deletes the .c or .h file corresponding to the source file which is
+ -- currently being compiled.
+
----------------------
-- List File Output --
----------------------
diff --git a/gcc/ada/osint-l.adb b/gcc/ada/osint-l.adb
index 9cc8f4c9b6..eb7e3c379c 100644
--- a/gcc/ada/osint-l.adb
+++ b/gcc/ada/osint-l.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2007, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,7 +29,7 @@ package body Osint.L is
-- More_Lib_Files --
--------------------
- function More_Lib_Files return Boolean renames More_Files;
+ function More_Lib_Files return Boolean renames More_Files;
------------------------
-- Next_Main_Lib_File --
diff --git a/gcc/ada/osint.adb b/gcc/ada/osint.adb
index dbb438c3c1..8c6c22b9d1 100644
--- a/gcc/ada/osint.adb
+++ b/gcc/ada/osint.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -157,7 +157,7 @@ package body Osint is
EOL : constant Character := ASCII.LF;
-- End of line character
- Number_File_Names : Int := 0;
+ Number_File_Names : Nat := 0;
-- Number of file names found on command line and placed in File_Names
Look_In_Primary_Directory_For_Current_Main : Boolean := False;
@@ -1977,7 +1977,6 @@ package body Osint is
Dir_Name := new String'(File_Name (File_Name'First .. Fptr - 1));
case Running_Program is
-
when Compiler =>
Src_Search_Directories.Table (Primary_Directory) := Dir_Name;
Look_In_Primary_Directory_For_Current_Main := True;
@@ -1989,7 +1988,9 @@ package body Osint is
Look_In_Primary_Directory_For_Current_Main := True;
end if;
- when Binder | Gnatls =>
+ when Binder
+ | Gnatls
+ =>
Dir_Name := Normalize_Directory_Name (Dir_Name.all);
Lib_Search_Directories.Table (Primary_Directory) := Dir_Name;
@@ -2094,7 +2095,7 @@ package body Osint is
-- Number_Of_Files --
---------------------
- function Number_Of_Files return Int is
+ function Number_Of_Files return Nat is
begin
return Number_File_Names;
end Number_Of_Files;
@@ -2203,31 +2204,6 @@ package body Osint is
Start_Of_Suffix : Positive;
begin
- -- GNAAMP tool names require special treatment
-
- if AAMP_On_Target then
-
- -- The name "gcc" is mapped to "gnaamp" (the compiler driver)
-
- if Nam = "gcc" then
- return new String'("gnaamp");
-
- -- Tool names starting with "gnat" are mapped by substituting the
- -- string "gnaamp" for "gnat" (for example, "gnatpp" => "gnaamppp").
-
- elsif Nam'Length >= 4
- and then Nam (Nam'First .. Nam'First + 3) = "gnat"
- then
- return new String'("gnaamp" & Nam (Nam'First + 4 .. Nam'Last));
-
- -- No other mapping rules, so we continue and handle any other forms
- -- of tool names the same as on other targets.
-
- else
- null;
- end if;
- end if;
-
-- Get the name of the current program being executed
Find_Program_Name;
@@ -2752,7 +2728,7 @@ package body Osint is
end if;
end if;
- if Path (Prefix'Range) = Prefix then
+ if Path'Last >= Prefix'Last and then Path (Prefix'Range) = Prefix then
if Std_Prefix.all /= "" then
S := new String
(1 .. Std_Prefix'Length + Path'Last - Prefix'Last);
diff --git a/gcc/ada/osint.ads b/gcc/ada/osint.ads
index 2e6f0904de..a96e83ea8e 100644
--- a/gcc/ada/osint.ads
+++ b/gcc/ada/osint.ads
@@ -120,7 +120,7 @@ package Osint is
-- lower case form, so that two environment variable names compare equal if
-- they refer to the same environment variable.
- function Number_Of_Files return Int;
+ function Number_Of_Files return Nat;
-- Gives the total number of filenames found on the command line
No_Index : constant := -1;
diff --git a/gcc/ada/par-ch10.adb b/gcc/ada/par-ch10.adb
index 551173066a..eca327b563 100644
--- a/gcc/ada/par-ch10.adb
+++ b/gcc/ada/par-ch10.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -155,7 +155,7 @@ package body Ch10 is
Item := P_Pragma;
if Item = Error
- or else Pragma_Name (Item) /= Name_Source_Reference
+ or else Pragma_Name_Unmapped (Item) /= Name_Source_Reference
then
Restore_Scan_State (Scan_State);
@@ -184,12 +184,14 @@ package body Ch10 is
Save_Scan_State (Scan_State);
Item := P_Pragma;
- if Item /= Error and then Pragma_Name (Item) = Name_No_Body then
+ if Item /= Error and then Pragma_Name_Unmapped (Item) = Name_No_Body
+ then
No_Body := True;
end if;
if Item = Error
- or else not Is_Configuration_Pragma_Name (Pragma_Name (Item))
+ or else
+ not Is_Configuration_Pragma_Name (Pragma_Name_Unmapped (Item))
then
Restore_Scan_State (Scan_State);
exit;
diff --git a/gcc/ada/par-ch11.adb b/gcc/ada/par-ch11.adb
index 61df3ee251..6c954b1edf 100644
--- a/gcc/ada/par-ch11.adb
+++ b/gcc/ada/par-ch11.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -34,8 +34,8 @@ package body Ch11 is
-- Local functions, used only in this chapter
- function P_Exception_Handler return Node_Id;
- function P_Exception_Choice return Node_Id;
+ function P_Exception_Handler return Node_Id;
+ function P_Exception_Choice return Node_Id;
---------------------------------
-- 11.1 Exception Declaration --
diff --git a/gcc/ada/par-ch12.adb b/gcc/ada/par-ch12.adb
index cd1f91a078..52f687ee03 100644
--- a/gcc/ada/par-ch12.adb
+++ b/gcc/ada/par-ch12.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -763,10 +763,10 @@ package body Ch12 is
-- Ada 2005 (AI-345): Task, Protected or Synchronized interface or
-- (AI-443): Synchronized formal derived type declaration.
- when Tok_Protected |
- Tok_Synchronized |
- Tok_Task =>
-
+ when Tok_Protected
+ | Tok_Synchronized
+ | Tok_Task
+ =>
declare
Saved_Token : constant Token_Type := Token;
@@ -812,7 +812,6 @@ package body Ch12 is
Error_Msg_BC ("expecting generic type definition here");
Resync_Past_Semicolon;
return Error;
-
end case;
end P_Formal_Type_Definition;
diff --git a/gcc/ada/par-ch2.adb b/gcc/ada/par-ch2.adb
index 99d1f2de8c..16e3be731c 100644
--- a/gcc/ada/par-ch2.adb
+++ b/gcc/ada/par-ch2.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -33,13 +33,16 @@ package body Ch2 is
-- Local functions, used only in this chapter
procedure Scan_Pragma_Argument_Association
- (Identifier_Seen : in out Boolean;
- Association : out Node_Id);
- -- Scans out a pragma argument association. Identifier_Seen is true on
- -- entry if a previous association had an identifier, and gets set True if
- -- the scanned association has an identifier (this is used to check the
+ (Identifier_Seen : in out Boolean;
+ Association : out Node_Id;
+ Reserved_Words_OK : Boolean := False);
+ -- Scans out a pragma argument association. Identifier_Seen is True on
+ -- entry if a previous association had an identifier, and gets set True
+ -- if the scanned association has an identifier (this is used to check the
-- rule that no associations without identifiers can follow an association
- -- which has an identifier). The result is returned in Association.
+ -- which has an identifier). The result is returned in Association. Flag
+ -- For_Pragma_Restrictions should be set when arguments are being parsed
+ -- for pragma Restrictions.
--
-- Note: We allow attribute forms Pre'Class, Post'Class, Invariant'Class,
-- Type_Invariant'Class in place of a pragma argument identifier. Rather
@@ -227,7 +230,7 @@ package body Ch2 is
Import_Check_Required : Boolean := False;
-- Set True if check of pragma IMPORT is required
- Arg_Count : Int := 0;
+ Arg_Count : Nat := 0;
-- Number of argument associations processed
Identifier_Seen : Boolean := False;
@@ -276,12 +279,10 @@ package body Ch2 is
-- Ada 2005 (AI-284): INTERFACE is a new reserved word but it is
-- allowed as a pragma name.
- if Ada_Version >= Ada_2005
- and then Token = Tok_Interface
- then
- Prag_Name := Name_Interface;
- Ident_Node := Make_Identifier (Token_Ptr, Name_Interface);
- Scan; -- past INTERFACE
+ if Is_Reserved_Keyword (Token) then
+ Prag_Name := Keyword_Name (Token);
+ Ident_Node := Make_Identifier (Token_Ptr, Prag_Name);
+ Scan; -- past the keyword
else
Ident_Node := P_Identifier;
end if;
@@ -317,7 +318,13 @@ package body Ch2 is
loop
Arg_Count := Arg_Count + 1;
- Scan_Pragma_Argument_Association (Identifier_Seen, Assoc_Node);
+
+ Scan_Pragma_Argument_Association
+ (Identifier_Seen => Identifier_Seen,
+ Association => Assoc_Node,
+ Reserved_Words_OK =>
+ Nam_In (Prag_Name, Name_Restriction_Warnings,
+ Name_Restrictions));
if Arg_Count = 2
and then (Interface_Check_Required or else Import_Check_Required)
@@ -429,16 +436,16 @@ package body Ch2 is
-- Error recovery: Cannot raise Error_Resync
procedure P_Pragmas_Opt (List : List_Id) is
- P : Node_Id;
+ P : Node_Id;
begin
while Token = Tok_Pragma loop
P := P_Pragma;
if Nkind (P) /= N_Error
- and then Nam_In (Pragma_Name (P), Name_Assert, Name_Debug)
+ and then Nam_In (Pragma_Name_Unmapped (P), Name_Assert, Name_Debug)
then
- Error_Msg_Name_1 := Pragma_Name (P);
+ Error_Msg_Name_1 := Pragma_Name_Unmapped (P);
Error_Msg_N
("pragma% must be in declaration/statement context", P);
else
@@ -476,17 +483,73 @@ package body Ch2 is
-- Error recovery: cannot raise Error_Resync
procedure Scan_Pragma_Argument_Association
- (Identifier_Seen : in out Boolean;
- Association : out Node_Id)
+ (Identifier_Seen : in out Boolean;
+ Association : out Node_Id;
+ Reserved_Words_OK : Boolean := False)
is
- Scan_State : Saved_Scan_State;
+ function P_Expression_Or_Reserved_Word return Node_Id;
+ -- Parse an expression or, if the token is one of the following reserved
+ -- words, construct an identifier with proper Chars field.
+ -- Access
+ -- Delta
+ -- Digits
+ -- Mod
+ -- Range
+
+ -----------------------------------
+ -- P_Expression_Or_Reserved_Word --
+ -----------------------------------
+
+ function P_Expression_Or_Reserved_Word return Node_Id is
+ Word : Node_Id;
+ Word_Id : Name_Id;
+
+ begin
+ Word_Id := No_Name;
+
+ if Token = Tok_Access then
+ Word_Id := Name_Access;
+ Scan; -- past ACCESS
+
+ elsif Token = Tok_Delta then
+ Word_Id := Name_Delta;
+ Scan; -- past DELTA
+
+ elsif Token = Tok_Digits then
+ Word_Id := Name_Digits;
+ Scan; -- past DIGITS
+
+ elsif Token = Tok_Mod then
+ Word_Id := Name_Mod;
+ Scan; -- past MOD
+
+ elsif Token = Tok_Range then
+ Word_Id := Name_Range;
+ Scan; -- post RANGE
+ end if;
+
+ if Word_Id = No_Name then
+ return P_Expression;
+ else
+ Word := New_Node (N_Identifier, Token_Ptr);
+ Set_Chars (Word, Word_Id);
+ return Word;
+ end if;
+ end P_Expression_Or_Reserved_Word;
+
+ -- Local variables
+
+ Expression_Node : Node_Id;
Identifier_Node : Node_Id;
- Id_Present : Boolean;
+ Identifier_OK : Boolean;
+ Scan_State : Saved_Scan_State;
+
+ -- Start of processing for Scan_Pragma_Argument_Association
begin
Association := New_Node (N_Pragma_Argument_Association, Token_Ptr);
Set_Chars (Association, No_Name);
- Id_Present := False;
+ Identifier_OK := False;
-- Argument starts with identifier
@@ -497,7 +560,7 @@ package body Ch2 is
if Token = Tok_Arrow then
Scan; -- past arrow
- Id_Present := True;
+ Identifier_OK := True;
-- Case of one of the special aspect forms
@@ -520,7 +583,7 @@ package body Ch2 is
-- Here we have scanned identifier'Class =>
else
- Id_Present := True;
+ Identifier_OK := True;
Scan; -- past arrow
case Chars (Identifier_Node) is
@@ -550,7 +613,7 @@ package body Ch2 is
-- Identifier was present
- if Id_Present then
+ if Identifier_OK then
Set_Chars (Association, Chars (Identifier_Node));
Identifier_Seen := True;
@@ -569,16 +632,32 @@ package body Ch2 is
-- message in Relaxed_RM_Semantics mode to help legacy code using e.g.
-- codepeer.
- if Identifier_Seen and not Id_Present and not Relaxed_RM_Semantics then
+ if Identifier_Seen
+ and not Identifier_OK
+ and not Relaxed_RM_Semantics
+ then
Error_Msg_SC ("|pragma argument identifier required here");
Error_Msg_SC ("\since previous argument had identifier (RM 2.8(4))");
end if;
- if Id_Present then
- Set_Expression (Association, P_Expression);
+ if Identifier_OK then
+
+ -- Certain pragmas such as Restriction_Warnings and Restrictions
+ -- allow reserved words to appear as expressions when checking for
+ -- prohibited uses of attributes.
+
+ if Reserved_Words_OK
+ and then Chars (Identifier_Node) = Name_No_Use_Of_Attribute
+ then
+ Expression_Node := P_Expression_Or_Reserved_Word;
+ else
+ Expression_Node := P_Expression;
+ end if;
else
- Set_Expression (Association, P_Expression_If_OK);
+ Expression_Node := P_Expression_If_OK;
end if;
+
+ Set_Expression (Association, Expression_Node);
end Scan_Pragma_Argument_Association;
end Ch2;
diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb
index 3863c5a56f..5c846645e9 100644
--- a/gcc/ada/par-ch3.adb
+++ b/gcc/ada/par-ch3.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -464,9 +464,9 @@ package body Ch3 is
loop
case Token is
-
- when Tok_Access |
- Tok_Not => -- Ada 2005 (AI-231)
+ when Tok_Access
+ | Tok_Not -- Ada 2005 (AI-231)
+ =>
Typedef_Node := P_Access_Type_Definition;
exit;
@@ -777,10 +777,10 @@ package body Ch3 is
-- Ada 2005 (AI-345): Protected, synchronized or task interface
-- or Ada 2005 (AI-443): Synchronized private extension.
- when Tok_Protected |
- Tok_Synchronized |
- Tok_Task =>
-
+ when Tok_Protected
+ | Tok_Synchronized
+ | Tok_Task
+ =>
declare
Saved_Token : constant Token_Type := Token;
@@ -864,7 +864,6 @@ package body Ch3 is
Error_Msg_AP ("type definition expected");
raise Error_Resync;
end if;
-
end case;
end loop;
@@ -1899,6 +1898,11 @@ package body Ch3 is
("aspect specifications must come after initialization "
& "expression",
Sloc (First (Aspect_Specifications (Decl_Node))));
+
+ else
+ -- In any case, the assignment symbol doesn't belong.
+
+ Error_Msg ("misplaced assignment symbol", Scan_Ptr);
end if;
Set_Expression (Decl_Node, Init_Expr_Opt);
@@ -3852,6 +3856,10 @@ package body Ch3 is
end if;
if Token = Tok_Comma then
+ if Nkind (Expr_Node) = N_Iterated_Component_Association then
+ return Choices;
+ end if;
+
Scan; -- past comma
if Token = Tok_Vertical_Bar then
@@ -4311,7 +4319,6 @@ package body Ch3 is
end if;
case Token is
-
when Tok_Function =>
Check_Bad_Layout;
Append (P_Subprogram (Pf_Decl_Gins_Pbod_Rnam_Stub_Pexp), Decls);
@@ -4576,19 +4583,19 @@ package body Ch3 is
-- judgment, because it is a real mess to go into statement mode
-- prematurely in response to a junk declaration.
- when Tok_Abort |
- Tok_Accept |
- Tok_Declare |
- Tok_Delay |
- Tok_Exit |
- Tok_Goto |
- Tok_If |
- Tok_Loop |
- Tok_Null |
- Tok_Requeue |
- Tok_Select |
- Tok_While =>
-
+ when Tok_Abort
+ | Tok_Accept
+ | Tok_Declare
+ | Tok_Delay
+ | Tok_Exit
+ | Tok_Goto
+ | Tok_If
+ | Tok_Loop
+ | Tok_Null
+ | Tok_Requeue
+ | Tok_Select
+ | Tok_While
+ =>
-- But before we decide that it's a statement, let's check for
-- a reserved word misused as an identifier.
diff --git a/gcc/ada/par-ch4.adb b/gcc/ada/par-ch4.adb
index 071853a01a..e9a3a23b3f 100644
--- a/gcc/ada/par-ch4.adb
+++ b/gcc/ada/par-ch4.adb
@@ -1,4 +1,4 @@
-------------------------------------------------------------------------------
+-----------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -76,6 +76,7 @@ package body Ch4 is
function P_Aggregate_Or_Paren_Expr return Node_Id;
function P_Allocator return Node_Id;
function P_Case_Expression_Alternative return Node_Id;
+ function P_Iterated_Component_Association return Node_Id;
function P_Record_Or_Array_Component_Association return Node_Id;
function P_Factor return Node_Id;
function P_Primary return Node_Id;
@@ -144,7 +145,7 @@ package body Ch4 is
-- | INDEXED_COMPONENT | SLICE
-- | SELECTED_COMPONENT | ATTRIBUTE
-- | TYPE_CONVERSION | FUNCTION_CALL
- -- | CHARACTER_LITERAL
+ -- | CHARACTER_LITERAL | TARGET_NAME
-- DIRECT_NAME ::= IDENTIFIER | OPERATOR_SYMBOL
@@ -180,6 +181,8 @@ package body Ch4 is
-- EXPLICIT_ACTUAL_PARAMETER ::= EXPRESSION | variable_NAME
+ -- TARGET_NAME ::= @ (AI12-0125-3: abbreviation for LHS)
+
-- Note: syntactically a procedure call looks just like a function call,
-- so this routine is in practice used to scan out procedure calls as well.
@@ -228,6 +231,11 @@ package body Ch4 is
end if;
-- Loop through designators in qualified name
+ -- AI12-0125 : target_name
+
+ if Token = Tok_At_Sign then
+ Scan_Reserved_Identifier (Force_Msg => False);
+ end if;
Name_Node := Token_Node;
@@ -461,7 +469,7 @@ package body Ch4 is
loop
Discard_Junk_Node (P_Expression_If_OK);
- exit when not Comma_Present;
+ exit when not Comma_Present;
end loop;
T_Right_Paren;
@@ -1260,6 +1268,10 @@ package body Ch4 is
-- Called if <> is encountered as positional aggregate element. Issues
-- error message and sets Expr_Node to Error.
+ function Is_Quantified_Expression return Boolean;
+ -- The presence of iterated component associations requires a one
+ -- token lookahead to distinguish it from quantified expressions.
+
---------------
-- Box_Error --
---------------
@@ -1281,6 +1293,22 @@ package body Ch4 is
Expr_Node := Error;
end Box_Error;
+ ------------------------------
+ -- Is_Quantified_Expression --
+ ------------------------------
+
+ function Is_Quantified_Expression return Boolean is
+ Maybe : Boolean;
+ Scan_State : Saved_Scan_State;
+
+ begin
+ Save_Scan_State (Scan_State);
+ Scan; -- past FOR
+ Maybe := Token = Tok_All or else Token = Tok_Some;
+ Restore_Scan_State (Scan_State); -- to FOR
+ return Maybe;
+ end Is_Quantified_Expression;
+
-- Start of processing for P_Aggregate_Or_Paren_Expr
begin
@@ -1309,7 +1337,7 @@ package body Ch4 is
-- Quantified expression
- elsif Token = Tok_For then
+ elsif Token = Tok_For and then Is_Quantified_Expression then
Expr_Node := P_Quantified_Expression;
T_Right_Paren;
Set_Paren_Count (Expr_Node, Paren_Count (Expr_Node) + 1);
@@ -1338,6 +1366,11 @@ package body Ch4 is
else
Restore_Scan_State (Scan_State); -- to NULL that must be expr
end if;
+
+ elsif Token = Tok_For then
+ Aggregate_Node := New_Node (N_Aggregate, Lparen_Sloc);
+ Expr_Node := P_Iterated_Component_Association;
+ goto Aggregate;
end if;
-- Scan expression, handling box appearing as positional argument
@@ -1348,7 +1381,7 @@ package body Ch4 is
Expr_Node := P_Expression_Or_Range_Attribute_If_OK;
end if;
- -- Extension aggregate
+ -- Extension or Delta aggregate
if Token = Tok_With then
if Nkind (Expr_Node) = N_Attribute_Reference
@@ -1362,9 +1395,18 @@ package body Ch4 is
Error_Msg_SC ("(Ada 83) extension aggregate not allowed");
end if;
- Aggregate_Node := New_Node (N_Extension_Aggregate, Lparen_Sloc);
- Set_Ancestor_Part (Aggregate_Node, Expr_Node);
Scan; -- past WITH
+ if Token = Tok_Delta then
+ Scan; -- past DELTA
+ Aggregate_Node := New_Node (N_Delta_Aggregate, Lparen_Sloc);
+ Set_Expression (Aggregate_Node, Expr_Node);
+ Expr_Node := Empty;
+ goto Aggregate;
+
+ else
+ Aggregate_Node := New_Node (N_Extension_Aggregate, Lparen_Sloc);
+ Set_Ancestor_Part (Aggregate_Node, Expr_Node);
+ end if;
-- Deal with WITH NULL RECORD case
@@ -1425,7 +1467,7 @@ package body Ch4 is
end if;
-- Prepare to scan list of component associations
-
+ <<Aggregate>>
Expr_List := No_List; -- don't set yet, maybe all named entries
Assoc_List := No_List; -- don't set yet, maybe all positional entries
@@ -1464,7 +1506,14 @@ package body Ch4 is
-- Assume positional case if comma, right paren, or literal or
-- identifier or OTHERS follows (the latter cases are missing
-- comma cases). Also assume positional if a semicolon follows,
- -- which can happen if there are missing parens
+ -- which can happen if there are missing parens.
+
+ elsif Nkind (Expr_Node) = N_Iterated_Component_Association then
+ if No (Assoc_List) then
+ Assoc_List := New_List (Expr_Node);
+ else
+ Append_To (Assoc_List, Expr_Node);
+ end if;
elsif Token = Tok_Comma
or else Token = Tok_Right_Paren
@@ -1474,8 +1523,8 @@ package body Ch4 is
then
if Present (Assoc_List) then
Error_Msg_BC -- CODEFIX
- ("""='>"" expected (positional association cannot follow " &
- "named association)");
+ ("""='>"" expected (positional association cannot follow "
+ & "named association)");
end if;
if No (Expr_List) then
@@ -1515,7 +1564,7 @@ package body Ch4 is
-- wrong, so let's get out now, before we start eating up stuff
-- that doesn't belong to us.
- if Token in Token_Class_Eterm then
+ if Token in Token_Class_Eterm and then Token /= Tok_For then
Error_Msg_AP
("expecting expression or component association");
exit;
@@ -1527,11 +1576,15 @@ package body Ch4 is
Box_Error;
-- Otherwise initiate for reentry to top of loop by scanning an
- -- initial expression, unless the first token is OTHERS.
+ -- initial expression, unless the first token is OTHERS or FOR,
+ -- which indicates an iterated component association.
elsif Token = Tok_Others then
Expr_Node := Empty;
+ elsif Token = Tok_For then
+ Expr_Node := P_Iterated_Component_Association;
+
else
Save_Scan_State (Scan_State); -- at start of expression
Expr_Node := P_Expression_Or_Range_Attribute_If_OK;
@@ -1542,7 +1595,11 @@ package body Ch4 is
-- All component associations (positional and named) have been scanned
T_Right_Paren;
- Set_Expressions (Aggregate_Node, Expr_List);
+
+ if Nkind (Aggregate_Node) /= N_Delta_Aggregate then
+ Set_Expressions (Aggregate_Node, Expr_List);
+ end if;
+
Set_Component_Associations (Aggregate_Node, Assoc_List);
return Aggregate_Node;
end P_Aggregate_Or_Paren_Expr;
@@ -1562,6 +1619,7 @@ package body Ch4 is
-- ARRAY_COMPONENT_ASSOCIATION ::=
-- DISCRETE_CHOICE_LIST => EXPRESSION
-- | DISCRETE_CHOICE_LIST => <>
+ -- | ITERATED_COMPONENT_ASSOCIATION
-- Note: this routine only handles the named cases, including others.
-- Cases where the component choice list is not present have already
@@ -1577,6 +1635,10 @@ package body Ch4 is
Assoc_Node : Node_Id;
begin
+ if Token = Tok_For then
+ return P_Iterated_Component_Association;
+ end if;
+
Assoc_Node := New_Node (N_Component_Association, Token_Ptr);
Set_Choices (Assoc_Node, P_Discrete_Choice_List);
Set_Sloc (Assoc_Node, Token_Ptr);
@@ -2287,9 +2349,9 @@ package body Ch4 is
-- Come here at end of simple expression, where we do a couple of
-- special checks to improve error recovery.
- -- Special test to improve error recovery. If the current token
- -- is a period, then someone is trying to do selection on something
- -- that is not a name, e.g. a qualified expression.
+ -- Special test to improve error recovery. If the current token is a
+ -- period, then someone is trying to do selection on something that is
+ -- not a name, e.g. a qualified expression.
if Token = Tok_Dot then
Error_Msg_SC ("prefix for selection is not a name");
@@ -2552,7 +2614,10 @@ package body Ch4 is
-- that string literal is included in name (as operator symbol)
-- and type conversion is included in name (as indexed component).
- when Tok_Char_Literal | Tok_Operator_Symbol | Tok_Identifier =>
+ when Tok_Char_Literal
+ | Tok_Identifier
+ | Tok_Operator_Symbol
+ =>
Node1 := P_Name;
-- All done unless apostrophe follows
@@ -2593,10 +2658,10 @@ package body Ch4 is
-- Numeric or string literal
- when Tok_Integer_Literal |
- Tok_Real_Literal |
- Tok_String_Literal =>
-
+ when Tok_Integer_Literal
+ | Tok_Real_Literal
+ | Tok_String_Literal
+ =>
Node1 := Token_Node;
Scan; -- past number
return Node1;
@@ -2718,12 +2783,21 @@ package body Ch4 is
return Error;
elsif Ada_Version >= Ada_2012 then
- Node1 := P_Quantified_Expression;
+ Save_Scan_State (Scan_State);
+ Scan; -- past FOR
- if not (Lparen and then Token = Tok_Right_Paren) then
- Error_Msg
- ("quantified expression must be parenthesized",
- Sloc (Node1));
+ if Token = Tok_All or else Token = Tok_Some then
+ Restore_Scan_State (Scan_State); -- To FOR
+ Node1 := P_Quantified_Expression;
+
+ if not (Lparen and then Token = Tok_Right_Paren) then
+ Error_Msg
+ ("quantified expression must be parenthesized",
+ Sloc (Node1));
+ end if;
+ else
+ Restore_Scan_State (Scan_State); -- To FOR
+ Node1 := P_Iterated_Component_Association;
end if;
return Node1;
@@ -2741,6 +2815,15 @@ package body Ch4 is
Error_Msg_SC ("parentheses required for unary minus");
Scan; -- past minus
+ when Tok_At_Sign => -- AI12-0125 : target_name
+ if Ada_Version < Ada_2020 then
+ Error_Msg_SC ("target name is an Ada 2020 extension");
+ Error_Msg_SC ("\compile with -gnatX");
+ end if;
+
+ Node1 := P_Name;
+ return Node1;
+
-- Anything else is illegal as the first token of a primary, but
-- we test for some common errors, to improve error messages.
@@ -2757,7 +2840,6 @@ package body Ch4 is
Error_Msg_AP ("missing operand");
raise Error_Resync;
end if;
-
end case;
end loop;
end P_Primary;
@@ -2786,7 +2868,7 @@ package body Ch4 is
raise Error_Resync;
end if;
- Scan; -- past SOME
+ Scan; -- past ALL or SOME
I_Spec := P_Loop_Parameter_Specification;
if Nkind (I_Spec) = N_Loop_Parameter_Specification then
@@ -3172,12 +3254,40 @@ package body Ch4 is
return Case_Alt_Node;
end P_Case_Expression_Alternative;
+ --------------------------------------
+ -- P_Iterated_Component_Association --
+ --------------------------------------
+
+ -- ITERATED_COMPONENT_ASSOCIATION ::=
+ -- for DEFINING_IDENTIFIER in DISCRETE_CHOICE_LIST => EXPRESSION
+
+ function P_Iterated_Component_Association return Node_Id is
+ Assoc_Node : Node_Id;
+
+ begin
+ Scan; -- past FOR
+ Assoc_Node :=
+ New_Node (N_Iterated_Component_Association, Prev_Token_Ptr);
+ Set_Defining_Identifier (Assoc_Node, P_Defining_Identifier);
+ T_In;
+ Set_Discrete_Choices (Assoc_Node, P_Discrete_Choice_List);
+ TF_Arrow;
+ Set_Expression (Assoc_Node, P_Expression);
+ return Assoc_Node;
+ end P_Iterated_Component_Association;
+
---------------------
-- P_If_Expression --
---------------------
- function P_If_Expression return Node_Id is
+ -- IF_EXPRESSION ::=
+ -- if CONDITION then DEPENDENT_EXPRESSION
+ -- {elsif CONDITION then DEPENDENT_EXPRESSION}
+ -- [else DEPENDENT_EXPRESSION]
+
+ -- DEPENDENT_EXPRESSION ::= EXPRESSION
+ function P_If_Expression return Node_Id is
function P_If_Expression_Internal
(Loc : Source_Ptr;
Cond : Node_Id) return Node_Id;
@@ -3355,7 +3465,9 @@ package body Ch4 is
function P_Unparen_Cond_Case_Quant_Expression return Node_Id is
Lparen : constant Boolean := Prev_Token = Tok_Left_Paren;
- Result : Node_Id;
+
+ Result : Node_Id;
+ Scan_State : Saved_Scan_State;
begin
-- Case expression
@@ -3376,14 +3488,28 @@ package body Ch4 is
Error_Msg_N ("if expression must be parenthesized!", Result);
end if;
- -- Quantified expression
+ -- Quantified expression or iterated component association
elsif Token = Tok_For then
- Result := P_Quantified_Expression;
- if not (Lparen and then Token = Tok_Right_Paren) then
- Error_Msg_N
- ("quantified expression must be parenthesized!", Result);
+ Save_Scan_State (Scan_State);
+ Scan; -- past FOR
+
+ if Token = Tok_All or else Token = Tok_Some then
+ Restore_Scan_State (Scan_State);
+ Result := P_Quantified_Expression;
+
+ if not (Lparen and then Token = Tok_Right_Paren) then
+ Error_Msg_N
+ ("quantified expression must be parenthesized!", Result);
+ end if;
+
+ else
+ -- If no quantifier keyword, this is an iterated component in
+ -- an aggregate.
+
+ Restore_Scan_State (Scan_State);
+ Result := P_Iterated_Component_Association;
end if;
-- No other possibility should exist (caller was supposed to check)
diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb
index a7d0e5a3d7..5d8b45ceae 100644
--- a/gcc/ada/par-ch5.adb
+++ b/gcc/ada/par-ch5.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -42,7 +42,7 @@ package body Ch5 is
function P_Label return Node_Id;
function P_Null_Statement return Node_Id;
- function P_Assignment_Statement (LHS : Node_Id) return Node_Id;
+ function P_Assignment_Statement (LHS : Node_Id) return Node_Id;
-- Parse assignment statement. On entry, the caller has scanned the left
-- hand side (passed in as Lhs), and the colon-equal (or some symbol
-- taken to be an error equivalent such as equal).
@@ -342,8 +342,9 @@ package body Ch5 is
-- Case of end or EOF
- when Tok_End | Tok_EOF =>
-
+ when Tok_End
+ | Tok_EOF
+ =>
-- These tokens always terminate the statement sequence
Test_Statement_Required;
@@ -459,13 +460,14 @@ package body Ch5 is
-- Case of WHEN (error because we are not in a case)
- when Tok_When | Tok_Others =>
-
+ when Tok_Others
+ | Tok_When
+ =>
-- Terminate if Whtm set or if the WHEN is to the left of
-- the expected column of the end for this sequence.
if SS_Flags.Whtm
- or else Start_Column < Scope.Table (Scope.Last).Ecol
+ or else Start_Column < Scope.Table (Scope.Last).Ecol
then
Test_Statement_Required;
exit;
@@ -948,7 +950,6 @@ package body Ch5 is
-- handling of a bad statement.
when others =>
-
if Token in Token_Class_Declk then
Junk_Declaration;
@@ -972,11 +973,9 @@ package body Ch5 is
end;
exit when SS_Flags.Unco;
-
end loop;
return Statement_List;
-
end P_Sequence_Of_Statements;
--------------------
diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb
index 73a0066c0a..a1733d99bf 100644
--- a/gcc/ada/par-ch6.adb
+++ b/gcc/ada/par-ch6.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1909,8 +1909,9 @@ package body Ch6 is
if Token = Tok_Do then
Push_Scope_Stack;
- Scope.Table (Scope.Last).Etyp := E_Return;
Scope.Table (Scope.Last).Ecol := Ret_Strt;
+ Scope.Table (Scope.Last).Etyp := E_Return;
+ Scope.Table (Scope.Last).Labl := Error;
Scope.Table (Scope.Last).Sloc := Ret_Sloc;
Scan; -- past DO
diff --git a/gcc/ada/par-ch9.adb b/gcc/ada/par-ch9.adb
index 1137823133..11b6542e54 100644
--- a/gcc/ada/par-ch9.adb
+++ b/gcc/ada/par-ch9.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -338,10 +338,10 @@ package body Ch9 is
Decl_Sloc := Token_Ptr;
if Token = Tok_Pragma then
- Append (P_Pragma, Items);
+ P_Pragmas_Opt (Items);
- -- Ada 2005 (AI-397): Reserved words NOT and OVERRIDING
- -- may begin an entry declaration.
+ -- Ada 2005 (AI-397): Reserved words NOT and OVERRIDING may begin an
+ -- entry declaration.
elsif Token = Tok_Entry
or else Token = Tok_Not
@@ -350,8 +350,9 @@ package body Ch9 is
Append (P_Entry_Declaration, Items);
elsif Token = Tok_For then
- -- Representation clause in task declaration. The only rep
- -- clause which is legal in a protected is an address clause,
+
+ -- Representation clause in task declaration. The only rep clause
+ -- which is legal in a protected declaration is an address clause,
-- so that is what we try to scan out.
Item_Node := P_Representation_Clause;
@@ -617,8 +618,10 @@ package body Ch9 is
-- Error recovery: cannot raise Error_Resync
function P_Protected_Definition return Node_Id is
- Def_Node : Node_Id;
- Item_Node : Node_Id;
+ Def_Node : Node_Id;
+ Item_Node : Node_Id;
+ Priv_Decls : List_Id;
+ Vis_Decls : List_Id;
begin
Def_Node := New_Node (N_Protected_Definition, Token_Ptr);
@@ -631,33 +634,63 @@ package body Ch9 is
-- Loop to scan visible declarations (protected operation declarations)
- Set_Visible_Declarations (Def_Node, New_List);
+ Vis_Decls := New_List;
+ Set_Visible_Declarations (Def_Node, Vis_Decls);
+
+ -- Flag and discard all pragmas which cannot appear in the protected
+ -- definition. Note that certain pragmas are still allowed as long as
+ -- they apply to entries, entry families, or protected subprograms.
+
+ P_Pragmas_Opt (Vis_Decls);
loop
Item_Node := P_Protected_Operation_Declaration_Opt;
+
+ if Present (Item_Node) then
+ Append (Item_Node, Vis_Decls);
+ end if;
+
+ P_Pragmas_Opt (Vis_Decls);
+
exit when No (Item_Node);
- Append (Item_Node, Visible_Declarations (Def_Node));
end loop;
-- Deal with PRIVATE part (including graceful handling of multiple
-- PRIVATE parts).
Private_Loop : while Token = Tok_Private loop
- if No (Private_Declarations (Def_Node)) then
- Set_Private_Declarations (Def_Node, New_List);
- else
+ Priv_Decls := Private_Declarations (Def_Node);
+
+ if Present (Priv_Decls) then
Error_Msg_SC ("duplicate private part");
+ else
+ Priv_Decls := New_List;
+ Set_Private_Declarations (Def_Node, Priv_Decls);
end if;
Scan; -- past PRIVATE
+ -- Flag and discard all pragmas which cannot appear in the protected
+ -- definition. Note that certain pragmas are still allowed as long as
+ -- they apply to entries, entry families, or protected subprograms.
+
+ P_Pragmas_Opt (Priv_Decls);
+
Declaration_Loop : loop
if Token = Tok_Identifier then
- P_Component_Items (Private_Declarations (Def_Node));
+ P_Component_Items (Priv_Decls);
+ P_Pragmas_Opt (Priv_Decls);
+
else
Item_Node := P_Protected_Operation_Declaration_Opt;
+
+ if Present (Item_Node) then
+ Append (Item_Node, Priv_Decls);
+ end if;
+
+ P_Pragmas_Opt (Priv_Decls);
+
exit Declaration_Loop when No (Item_Node);
- Append (Item_Node, Private_Declarations (Def_Node));
end if;
end loop Declaration_Loop;
end loop Private_Loop;
diff --git a/gcc/ada/par-endh.adb b/gcc/ada/par-endh.adb
index 3c065ec9fb..bbcbff92c1 100644
--- a/gcc/ada/par-endh.adb
+++ b/gcc/ada/par-endh.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -576,7 +576,6 @@ package body Endh is
-- Cases of normal tokens following an END
(Token = Tok_Case or else
- Token = Tok_For or else
Token = Tok_If or else
Token = Tok_Loop or else
Token = Tok_Record or else
diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb
index c317949d7c..0046badb39 100644
--- a/gcc/ada/par-prag.adb
+++ b/gcc/ada/par-prag.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -43,7 +43,7 @@ with System.WCh_Con; use System.WCh_Con;
separate (Par)
function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is
- Prag_Name : constant Name_Id := Pragma_Name (Pragma_Node);
+ Prag_Name : constant Name_Id := Pragma_Name_Unmapped (Pragma_Node);
Prag_Id : constant Pragma_Id := Get_Pragma_Id (Prag_Name);
Pragma_Sloc : constant Source_Ptr := Sloc (Pragma_Node);
Arg_Count : Nat;
@@ -257,7 +257,9 @@ function Prag (Pragma_Node : Node_Id; Semi : Source_Ptr) return Node_Id is
Restriction_Warnings (No_Obsolescent_Features) :=
Prag_Id = Pragma_Restriction_Warnings;
- when Name_SPARK | Name_SPARK_05 =>
+ when Name_SPARK
+ | Name_SPARK_05
+ =>
Set_Restriction (SPARK_05, Pragma_Node);
Restriction_Warnings (SPARK_05) :=
Prag_Id = Pragma_Restriction_Warnings;
@@ -329,9 +331,11 @@ begin
-- Ada version syntax.
when Pragma_Ada_83 =>
- Ada_Version := Ada_83;
- Ada_Version_Explicit := Ada_83;
- Ada_Version_Pragma := Pragma_Node;
+ if not Latest_Ada_Only then
+ Ada_Version := Ada_83;
+ Ada_Version_Explicit := Ada_83;
+ Ada_Version_Pragma := Pragma_Node;
+ end if;
------------
-- Ada_95 --
@@ -342,9 +346,11 @@ begin
-- Ada version syntax.
when Pragma_Ada_95 =>
- Ada_Version := Ada_95;
- Ada_Version_Explicit := Ada_95;
- Ada_Version_Pragma := Pragma_Node;
+ if not Latest_Ada_Only then
+ Ada_Version := Ada_95;
+ Ada_Version_Explicit := Ada_95;
+ Ada_Version_Pragma := Pragma_Node;
+ end if;
---------------------
-- Ada_05/Ada_2005 --
@@ -355,8 +361,10 @@ begin
-- Ada version syntax. However, it is only the zero argument form that
-- must be processed at parse time.
- when Pragma_Ada_05 | Pragma_Ada_2005 =>
- if Arg_Count = 0 then
+ when Pragma_Ada_05
+ | Pragma_Ada_2005
+ =>
+ if Arg_Count = 0 and not Latest_Ada_Only then
Ada_Version := Ada_2005;
Ada_Version_Explicit := Ada_2005;
Ada_Version_Pragma := Pragma_Node;
@@ -371,7 +379,9 @@ begin
-- Ada version syntax. However, it is only the zero argument form that
-- must be processed at parse time.
- when Pragma_Ada_12 | Pragma_Ada_2012 =>
+ when Pragma_Ada_12
+ | Pragma_Ada_2012
+ =>
if Arg_Count = 0 then
Ada_Version := Ada_2012;
Ada_Version_Explicit := Ada_2012;
@@ -385,7 +395,9 @@ begin
-- This pragma must be processed at parse time, since the resulting
-- status may be tested during the parsing of the program.
- when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning =>
+ when Pragma_Compiler_Unit
+ | Pragma_Compiler_Unit_Warning
+ =>
Check_Arg_Count (0);
-- Only recognized in main unit
@@ -574,7 +586,9 @@ begin
-- source file names set well before the semantic analysis starts,
-- since we load the spec and with'ed packages before analysis.
- when Pragma_Source_File_Name | Pragma_Source_File_Name_Project =>
+ when Pragma_Source_File_Name
+ | Pragma_Source_File_Name_Project
+ =>
Source_File_Name : declare
Unam : Unit_Name_Type;
Expr1 : Node_Id;
@@ -974,13 +988,13 @@ begin
declare
Slen : constant Natural := Natural (String_Length (S));
Options : String (1 .. Slen);
- J : Natural;
- Ptr : Natural;
+ J : Positive;
+ Ptr : Positive;
begin
J := 1;
loop
- C := Get_String_Char (S, Int (J));
+ C := Get_String_Char (S, Pos (J));
if not In_Character_Range (C) then
OK := False;
@@ -1281,216 +1295,221 @@ begin
-- For all other pragmas, checking and processing is handled
-- entirely in Sem_Prag, and no further checking is done by Par.
- when Pragma_Abort_Defer |
- Pragma_Abstract_State |
- Pragma_Async_Readers |
- Pragma_Async_Writers |
- Pragma_Assertion_Policy |
- Pragma_Assume |
- Pragma_Assume_No_Invalid_Values |
- Pragma_All_Calls_Remote |
- Pragma_Allow_Integer_Address |
- Pragma_Annotate |
- Pragma_Assert |
- Pragma_Assert_And_Cut |
- Pragma_Asynchronous |
- Pragma_Atomic |
- Pragma_Atomic_Components |
- Pragma_Attach_Handler |
- Pragma_Attribute_Definition |
- Pragma_Check |
- Pragma_Check_Float_Overflow |
- Pragma_Check_Name |
- Pragma_Check_Policy |
- Pragma_Compile_Time_Error |
- Pragma_Compile_Time_Warning |
- Pragma_Constant_After_Elaboration |
- Pragma_Contract_Cases |
- Pragma_Convention_Identifier |
- Pragma_CPP_Class |
- Pragma_CPP_Constructor |
- Pragma_CPP_Virtual |
- Pragma_CPP_Vtable |
- Pragma_CPU |
- Pragma_C_Pass_By_Copy |
- Pragma_Comment |
- Pragma_Common_Object |
- Pragma_Complete_Representation |
- Pragma_Complex_Representation |
- Pragma_Component_Alignment |
- Pragma_Controlled |
- Pragma_Convention |
- Pragma_Debug_Policy |
- Pragma_Depends |
- Pragma_Detect_Blocking |
- Pragma_Default_Initial_Condition |
- Pragma_Default_Scalar_Storage_Order |
- Pragma_Default_Storage_Pool |
- Pragma_Disable_Atomic_Synchronization |
- Pragma_Discard_Names |
- Pragma_Dispatching_Domain |
- Pragma_Effective_Reads |
- Pragma_Effective_Writes |
- Pragma_Eliminate |
- Pragma_Elaborate |
- Pragma_Elaborate_All |
- Pragma_Elaborate_Body |
- Pragma_Elaboration_Checks |
- Pragma_Enable_Atomic_Synchronization |
- Pragma_Export |
- Pragma_Export_Function |
- Pragma_Export_Object |
- Pragma_Export_Procedure |
- Pragma_Export_Value |
- Pragma_Export_Valued_Procedure |
- Pragma_Extend_System |
- Pragma_Extensions_Visible |
- Pragma_External |
- Pragma_External_Name_Casing |
- Pragma_Favor_Top_Level |
- Pragma_Fast_Math |
- Pragma_Finalize_Storage_Only |
- Pragma_Ghost |
- Pragma_Global |
- Pragma_Ident |
- Pragma_Implementation_Defined |
- Pragma_Implemented |
- Pragma_Implicit_Packing |
- Pragma_Import |
- Pragma_Import_Function |
- Pragma_Import_Object |
- Pragma_Import_Procedure |
- Pragma_Import_Valued_Procedure |
- Pragma_Independent |
- Pragma_Independent_Components |
- Pragma_Initial_Condition |
- Pragma_Initialize_Scalars |
- Pragma_Initializes |
- Pragma_Inline |
- Pragma_Inline_Always |
- Pragma_Inline_Generic |
- Pragma_Inspection_Point |
- Pragma_Interface |
- Pragma_Interface_Name |
- Pragma_Interrupt_Handler |
- Pragma_Interrupt_State |
- Pragma_Interrupt_Priority |
- Pragma_Invariant |
- Pragma_Keep_Names |
- Pragma_License |
- Pragma_Link_With |
- Pragma_Linker_Alias |
- Pragma_Linker_Constructor |
- Pragma_Linker_Destructor |
- Pragma_Linker_Options |
- Pragma_Linker_Section |
- Pragma_Lock_Free |
- Pragma_Locking_Policy |
- Pragma_Loop_Invariant |
- Pragma_Loop_Optimize |
- Pragma_Loop_Variant |
- Pragma_Machine_Attribute |
- Pragma_Main |
- Pragma_Main_Storage |
- Pragma_Memory_Size |
- Pragma_No_Body |
- Pragma_No_Elaboration_Code_All |
- Pragma_No_Inline |
- Pragma_No_Return |
- Pragma_No_Run_Time |
- Pragma_No_Strict_Aliasing |
- Pragma_No_Tagged_Streams |
- Pragma_Normalize_Scalars |
- Pragma_Obsolescent |
- Pragma_Ordered |
- Pragma_Optimize |
- Pragma_Optimize_Alignment |
- Pragma_Overflow_Mode |
- Pragma_Overriding_Renamings |
- Pragma_Pack |
- Pragma_Part_Of |
- Pragma_Partition_Elaboration_Policy |
- Pragma_Passive |
- Pragma_Preelaborable_Initialization |
- Pragma_Polling |
- Pragma_Prefix_Exception_Messages |
- Pragma_Persistent_BSS |
- Pragma_Post |
- Pragma_Postcondition |
- Pragma_Post_Class |
- Pragma_Pre |
- Pragma_Precondition |
- Pragma_Predicate |
- Pragma_Predicate_Failure |
- Pragma_Preelaborate |
- Pragma_Pre_Class |
- Pragma_Priority |
- Pragma_Priority_Specific_Dispatching |
- Pragma_Profile |
- Pragma_Profile_Warnings |
- Pragma_Propagate_Exceptions |
- Pragma_Provide_Shift_Operators |
- Pragma_Psect_Object |
- Pragma_Pure |
- Pragma_Pure_Function |
- Pragma_Queuing_Policy |
- Pragma_Refined_Depends |
- Pragma_Refined_Global |
- Pragma_Refined_Post |
- Pragma_Refined_State |
- Pragma_Relative_Deadline |
- Pragma_Remote_Access_Type |
- Pragma_Remote_Call_Interface |
- Pragma_Remote_Types |
- Pragma_Restricted_Run_Time |
- Pragma_Rational |
- Pragma_Ravenscar |
- Pragma_Reviewable |
- Pragma_Share_Generic |
- Pragma_Shared |
- Pragma_Shared_Passive |
- Pragma_Short_Circuit_And_Or |
- Pragma_Short_Descriptors |
- Pragma_Simple_Storage_Pool_Type |
- Pragma_SPARK_Mode |
- Pragma_Storage_Size |
- Pragma_Storage_Unit |
- Pragma_Static_Elaboration_Desired |
- Pragma_Stream_Convert |
- Pragma_Subtitle |
- Pragma_Suppress |
- Pragma_Suppress_Debug_Info |
- Pragma_Suppress_Exception_Locations |
- Pragma_Suppress_Initialization |
- Pragma_System_Name |
- Pragma_Task_Dispatching_Policy |
- Pragma_Task_Info |
- Pragma_Task_Name |
- Pragma_Task_Storage |
- Pragma_Test_Case |
- Pragma_Thread_Local_Storage |
- Pragma_Time_Slice |
- Pragma_Title |
- Pragma_Type_Invariant |
- Pragma_Type_Invariant_Class |
- Pragma_Unchecked_Union |
- Pragma_Unevaluated_Use_Of_Old |
- Pragma_Unimplemented_Unit |
- Pragma_Universal_Aliasing |
- Pragma_Universal_Data |
- Pragma_Unmodified |
- Pragma_Unreferenced |
- Pragma_Unreferenced_Objects |
- Pragma_Unreserve_All_Interrupts |
- Pragma_Unsuppress |
- Pragma_Use_VADS_Size |
- Pragma_Volatile |
- Pragma_Volatile_Components |
- Pragma_Volatile_Full_Access |
- Pragma_Volatile_Function |
- Pragma_Warning_As_Error |
- Pragma_Weak_External |
- Pragma_Validity_Checks =>
+ when Pragma_Abort_Defer
+ | Pragma_Abstract_State
+ | Pragma_Async_Readers
+ | Pragma_Async_Writers
+ | Pragma_Assertion_Policy
+ | Pragma_Assume
+ | Pragma_Assume_No_Invalid_Values
+ | Pragma_All_Calls_Remote
+ | Pragma_Allow_Integer_Address
+ | Pragma_Annotate
+ | Pragma_Assert
+ | Pragma_Assert_And_Cut
+ | Pragma_Asynchronous
+ | Pragma_Atomic
+ | Pragma_Atomic_Components
+ | Pragma_Attach_Handler
+ | Pragma_Attribute_Definition
+ | Pragma_Check
+ | Pragma_Check_Float_Overflow
+ | Pragma_Check_Name
+ | Pragma_Check_Policy
+ | Pragma_Compile_Time_Error
+ | Pragma_Compile_Time_Warning
+ | Pragma_Constant_After_Elaboration
+ | Pragma_Contract_Cases
+ | Pragma_Convention_Identifier
+ | Pragma_CPP_Class
+ | Pragma_CPP_Constructor
+ | Pragma_CPP_Virtual
+ | Pragma_CPP_Vtable
+ | Pragma_CPU
+ | Pragma_C_Pass_By_Copy
+ | Pragma_Comment
+ | Pragma_Common_Object
+ | Pragma_Complete_Representation
+ | Pragma_Complex_Representation
+ | Pragma_Component_Alignment
+ | Pragma_Controlled
+ | Pragma_Convention
+ | Pragma_Debug_Policy
+ | Pragma_Depends
+ | Pragma_Detect_Blocking
+ | Pragma_Default_Initial_Condition
+ | Pragma_Default_Scalar_Storage_Order
+ | Pragma_Default_Storage_Pool
+ | Pragma_Disable_Atomic_Synchronization
+ | Pragma_Discard_Names
+ | Pragma_Dispatching_Domain
+ | Pragma_Effective_Reads
+ | Pragma_Effective_Writes
+ | Pragma_Eliminate
+ | Pragma_Elaborate
+ | Pragma_Elaborate_All
+ | Pragma_Elaborate_Body
+ | Pragma_Elaboration_Checks
+ | Pragma_Enable_Atomic_Synchronization
+ | Pragma_Export
+ | Pragma_Export_Function
+ | Pragma_Export_Object
+ | Pragma_Export_Procedure
+ | Pragma_Export_Value
+ | Pragma_Export_Valued_Procedure
+ | Pragma_Extend_System
+ | Pragma_Extensions_Visible
+ | Pragma_External
+ | Pragma_External_Name_Casing
+ | Pragma_Favor_Top_Level
+ | Pragma_Fast_Math
+ | Pragma_Finalize_Storage_Only
+ | Pragma_Ghost
+ | Pragma_Global
+ | Pragma_Ident
+ | Pragma_Implementation_Defined
+ | Pragma_Implemented
+ | Pragma_Implicit_Packing
+ | Pragma_Import
+ | Pragma_Import_Function
+ | Pragma_Import_Object
+ | Pragma_Import_Procedure
+ | Pragma_Import_Valued_Procedure
+ | Pragma_Independent
+ | Pragma_Independent_Components
+ | Pragma_Initial_Condition
+ | Pragma_Initialize_Scalars
+ | Pragma_Initializes
+ | Pragma_Inline
+ | Pragma_Inline_Always
+ | Pragma_Inline_Generic
+ | Pragma_Inspection_Point
+ | Pragma_Interface
+ | Pragma_Interface_Name
+ | Pragma_Interrupt_Handler
+ | Pragma_Interrupt_State
+ | Pragma_Interrupt_Priority
+ | Pragma_Invariant
+ | Pragma_Keep_Names
+ | Pragma_License
+ | Pragma_Link_With
+ | Pragma_Linker_Alias
+ | Pragma_Linker_Constructor
+ | Pragma_Linker_Destructor
+ | Pragma_Linker_Options
+ | Pragma_Linker_Section
+ | Pragma_Lock_Free
+ | Pragma_Locking_Policy
+ | Pragma_Loop_Invariant
+ | Pragma_Loop_Optimize
+ | Pragma_Loop_Variant
+ | Pragma_Machine_Attribute
+ | Pragma_Main
+ | Pragma_Main_Storage
+ | Pragma_Max_Queue_Length
+ | Pragma_Memory_Size
+ | Pragma_No_Body
+ | Pragma_No_Elaboration_Code_All
+ | Pragma_No_Inline
+ | Pragma_No_Return
+ | Pragma_No_Run_Time
+ | Pragma_No_Strict_Aliasing
+ | Pragma_No_Tagged_Streams
+ | Pragma_Normalize_Scalars
+ | Pragma_Obsolescent
+ | Pragma_Ordered
+ | Pragma_Optimize
+ | Pragma_Optimize_Alignment
+ | Pragma_Overflow_Mode
+ | Pragma_Overriding_Renamings
+ | Pragma_Pack
+ | Pragma_Part_Of
+ | Pragma_Partition_Elaboration_Policy
+ | Pragma_Passive
+ | Pragma_Preelaborable_Initialization
+ | Pragma_Polling
+ | Pragma_Prefix_Exception_Messages
+ | Pragma_Persistent_BSS
+ | Pragma_Post
+ | Pragma_Postcondition
+ | Pragma_Post_Class
+ | Pragma_Pre
+ | Pragma_Precondition
+ | Pragma_Predicate
+ | Pragma_Predicate_Failure
+ | Pragma_Preelaborate
+ | Pragma_Pre_Class
+ | Pragma_Priority
+ | Pragma_Priority_Specific_Dispatching
+ | Pragma_Profile
+ | Pragma_Profile_Warnings
+ | Pragma_Propagate_Exceptions
+ | Pragma_Provide_Shift_Operators
+ | Pragma_Psect_Object
+ | Pragma_Pure
+ | Pragma_Pure_Function
+ | Pragma_Queuing_Policy
+ | Pragma_Refined_Depends
+ | Pragma_Refined_Global
+ | Pragma_Refined_Post
+ | Pragma_Refined_State
+ | Pragma_Relative_Deadline
+ | Pragma_Remote_Access_Type
+ | Pragma_Remote_Call_Interface
+ | Pragma_Remote_Types
+ | Pragma_Restricted_Run_Time
+ | Pragma_Rational
+ | Pragma_Ravenscar
+ | Pragma_Rename_Pragma
+ | Pragma_Reviewable
+ | Pragma_Secondary_Stack_Size
+ | Pragma_Share_Generic
+ | Pragma_Shared
+ | Pragma_Shared_Passive
+ | Pragma_Short_Circuit_And_Or
+ | Pragma_Short_Descriptors
+ | Pragma_Simple_Storage_Pool_Type
+ | Pragma_SPARK_Mode
+ | Pragma_Storage_Size
+ | Pragma_Storage_Unit
+ | Pragma_Static_Elaboration_Desired
+ | Pragma_Stream_Convert
+ | Pragma_Subtitle
+ | Pragma_Suppress
+ | Pragma_Suppress_Debug_Info
+ | Pragma_Suppress_Exception_Locations
+ | Pragma_Suppress_Initialization
+ | Pragma_System_Name
+ | Pragma_Task_Dispatching_Policy
+ | Pragma_Task_Info
+ | Pragma_Task_Name
+ | Pragma_Task_Storage
+ | Pragma_Test_Case
+ | Pragma_Thread_Local_Storage
+ | Pragma_Time_Slice
+ | Pragma_Title
+ | Pragma_Type_Invariant
+ | Pragma_Type_Invariant_Class
+ | Pragma_Unchecked_Union
+ | Pragma_Unevaluated_Use_Of_Old
+ | Pragma_Unimplemented_Unit
+ | Pragma_Universal_Aliasing
+ | Pragma_Universal_Data
+ | Pragma_Unmodified
+ | Pragma_Unreferenced
+ | Pragma_Unreferenced_Objects
+ | Pragma_Unreserve_All_Interrupts
+ | Pragma_Unsuppress
+ | Pragma_Unused
+ | Pragma_Use_VADS_Size
+ | Pragma_Volatile
+ | Pragma_Volatile_Components
+ | Pragma_Volatile_Full_Access
+ | Pragma_Volatile_Function
+ | Pragma_Warning_As_Error
+ | Pragma_Weak_External
+ | Pragma_Validity_Checks
+ =>
null;
--------------------
diff --git a/gcc/ada/par.adb b/gcc/ada/par.adb
index 7c38084033..d3c069a04a 100644
--- a/gcc/ada/par.adb
+++ b/gcc/ada/par.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -476,8 +476,8 @@ function Par (Configuration_Pragmas : Boolean) return List_Id is
-- subprogram specifications and bodies the field holds the correponding
-- program unit name. For task declarations and bodies, protected types
-- and bodies, and accept statements the field hold the name of the type
- -- or operation. For if-statements, case-statements, and selects, the
- -- field is initialized to Error.
+ -- or operation. For if-statements, case-statements, return statements,
+ -- and selects, the field is initialized to Error.
-- Note: this is a bit of an odd (mis)use of Error, since there is no
-- Error, but we use this value as a place holder to indicate that it
@@ -1481,10 +1481,12 @@ begin
-- Give error if bad pragma
- if not Is_Configuration_Pragma_Name (Pragma_Name (P_Node))
- and then Pragma_Name (P_Node) /= Name_Source_Reference
+ if not Is_Configuration_Pragma_Name
+ (Pragma_Name_Unmapped (P_Node))
+ and then
+ Pragma_Name_Unmapped (P_Node) /= Name_Source_Reference
then
- if Is_Pragma_Name (Pragma_Name (P_Node)) then
+ if Is_Pragma_Name (Pragma_Name_Unmapped (P_Node)) then
Error_Msg_N
("only configuration pragmas allowed " &
"in configuration file", P_Node);
@@ -1611,7 +1613,7 @@ begin
Name (Name'First .. Name'First + 3) = "ada."
then
Error_Msg
- ("user-defined descendents of package Ada " &
+ ("user-defined descendants of package Ada " &
"are not allowed",
Sloc (Unit (Comp_Unit_Node)));
@@ -1620,7 +1622,7 @@ begin
Name (Name'First .. Name'First + 10) = "interfaces."
then
Error_Msg
- ("user-defined descendents of package Interfaces " &
+ ("user-defined descendants of package Interfaces " &
"are not allowed",
Sloc (Unit (Comp_Unit_Node)));
@@ -1633,7 +1635,7 @@ begin
"system.rpc.")
then
Error_Msg
- ("user-defined descendents of package System " &
+ ("user-defined descendants of package System " &
"are not allowed",
Sloc (Unit (Comp_Unit_Node)));
end if;
diff --git a/gcc/ada/par_sco.adb b/gcc/ada/par_sco.adb
index c1e6f03778..3747605a29 100644
--- a/gcc/ada/par_sco.adb
+++ b/gcc/ada/par_sco.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2009-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -76,12 +76,12 @@ package body Par_SCO is
-- running some steps multiple times (the second pass has to be started
-- from multiple places).
- package SCO_Raw_Table is new GNAT.Table (
- Table_Component_Type => SCO_Table_Entry,
- Table_Index_Type => Nat,
- Table_Low_Bound => 1,
- Table_Initial => 500,
- Table_Increment => 300);
+ package SCO_Raw_Table is new GNAT.Table
+ (Table_Component_Type => SCO_Table_Entry,
+ Table_Index_Type => Nat,
+ Table_Low_Bound => 1,
+ Table_Initial => 500,
+ Table_Increment => 300);
-----------------------
-- Unit Number Table --
@@ -95,13 +95,13 @@ package body Par_SCO is
-- Note that the zero'th entry is here for convenience in sorting the
-- table, the real lower bound is 1.
- package SCO_Unit_Number_Table is new Table.Table (
- Table_Component_Type => Unit_Number_Type,
- Table_Index_Type => SCO_Unit_Index,
- Table_Low_Bound => 0, -- see note above on sort
- Table_Initial => 20,
- Table_Increment => 200,
- Table_Name => "SCO_Unit_Number_Entry");
+ package SCO_Unit_Number_Table is new Table.Table
+ (Table_Component_Type => Unit_Number_Type,
+ Table_Index_Type => SCO_Unit_Index,
+ Table_Low_Bound => 0, -- see note above on sort
+ Table_Initial => 20,
+ Table_Increment => 200,
+ Table_Name => "SCO_Unit_Number_Entry");
------------------------------------------
-- Condition/Operator/Pragma Hash Table --
@@ -120,10 +120,10 @@ package body Par_SCO is
function Hash (F : Source_Ptr) return Header_Num;
-- Function to Hash source pointer value
- function Equal (F1, F2 : Source_Ptr) return Boolean;
+ function Equal (F1 : Source_Ptr; F2 : Source_Ptr) return Boolean;
-- Function to test two keys for equality
- function "<" (S1, S2 : Source_Location) return Boolean;
+ function "<" (S1 : Source_Location; S2 : Source_Location) return Boolean;
-- Function to test for source locations order
package SCO_Raw_Hash_Table is new Simple_HTable
@@ -199,8 +199,8 @@ package body Par_SCO is
(L : List_Id;
D : Dominant_Info := No_Dominant;
P : Node_Id := Empty);
- -- Process L, a list of statements or declarations dominated by D.
- -- If P is present, it is processed as though it had been prepended to L.
+ -- Process L, a list of statements or declarations dominated by D. If P is
+ -- present, it is processed as though it had been prepended to L.
function Traverse_Declarations_Or_Statements
(L : List_Id;
@@ -218,20 +218,31 @@ package body Par_SCO is
-- the others are not???
procedure Traverse_Generic_Package_Declaration (N : Node_Id);
+
procedure Traverse_Handled_Statement_Sequence
(N : Node_Id;
D : Dominant_Info := No_Dominant);
- procedure Traverse_Package_Body (N : Node_Id);
+
+ procedure Traverse_Package_Body (N : Node_Id);
+
procedure Traverse_Package_Declaration
(N : Node_Id;
D : Dominant_Info := No_Dominant);
+
procedure Traverse_Subprogram_Or_Task_Body
(N : Node_Id;
D : Dominant_Info := No_Dominant);
- procedure Traverse_Sync_Definition (N : Node_Id);
+ procedure Traverse_Sync_Definition (N : Node_Id);
-- Traverse a protected definition or task definition
+ -- Note regarding traversals: In a few cases where an Alternatives list is
+ -- involved, pragmas such as "pragma Page" may show up before the first
+ -- alternative. We skip them because we're out of statement or declaration
+ -- context, so these can't be pragmas of interest for SCO purposes, and
+ -- the regular alternative processing typically involves attribute queries
+ -- which aren't valid for a pragma.
+
procedure Write_SCOs_To_ALI_File is new Put_SCOs;
-- Write SCO information to the ALI file using routines in Lib.Util
@@ -366,7 +377,7 @@ package body Par_SCO is
-- Equal --
-----------
- function Equal (F1, F2 : Source_Ptr) return Boolean is
+ function Equal (F1 : Source_Ptr; F2 : Source_Ptr) return Boolean is
begin
return F1 = F2;
end Equal;
@@ -375,7 +386,7 @@ package body Par_SCO is
-- < --
-------
- function "<" (S1, S2 : Source_Location) return Boolean is
+ function "<" (S1 : Source_Location; S2 : Source_Location) return Boolean is
begin
return S1.Line < S2.Line
or else (S1.Line = S2.Line and then S1.Col < S2.Col);
@@ -386,10 +397,9 @@ package body Par_SCO is
------------------
function Has_Decision (N : Node_Id) return Boolean is
-
function Check_Node (N : Node_Id) return Traverse_Result;
- -- Determine if Nkind (N) indicates the presence of a decision (i.e.
- -- N is a logical operator, which is a decision in itself, or an
+ -- Determine if Nkind (N) indicates the presence of a decision (i.e. N
+ -- is a logical operator, which is a decision in itself, or an
-- IF-expression whose Condition attribute is a decision).
----------------
@@ -404,7 +414,7 @@ package body Par_SCO is
-- needed in the secord pass.
if Is_Logical_Operator (N) /= False
- or else Nkind (N) = N_If_Expression
+ or else Nkind (N) = N_If_Expression
then
return Abandon;
else
@@ -449,7 +459,7 @@ package body Par_SCO is
function Is_Logical_Operator (N : Node_Id) return Tristate is
begin
- if Nkind_In (N, N_Op_Not, N_And_Then, N_Or_Else) then
+ if Nkind_In (N, N_And_Then, N_Op_Not, N_Or_Else) then
return True;
elsif Nkind_In (N, N_Op_And, N_Op_Or) then
return Unknown;
@@ -470,6 +480,7 @@ package body Par_SCO is
Pragma_Sloc : Source_Ptr)
is
N : Node_Id;
+
begin
if L /= No_List then
N := First (L);
@@ -511,13 +522,13 @@ package body Par_SCO is
-- This data structure holds the conditions/pragmas to register in
-- SCO_Raw_Hash_Table.
- package Hash_Entries is new Table.Table (
- Table_Component_Type => Hash_Entry,
- Table_Index_Type => Nat,
- Table_Low_Bound => 1,
- Table_Initial => 10,
- Table_Increment => 10,
- Table_Name => "Hash_Entries");
+ package Hash_Entries is new Table.Table
+ (Table_Component_Type => Hash_Entry,
+ Table_Index_Type => Nat,
+ Table_Low_Bound => 1,
+ Table_Initial => 10,
+ Table_Increment => 10,
+ Table_Name => "Hash_Entries");
-- Hold temporarily (i.e. free'd before returning) the Hash_Entry before
-- they are registered in SCO_Raw_Hash_Table.
@@ -527,10 +538,6 @@ package body Par_SCO is
-- The flag will be set False if T is other than X, or if an operator
-- other than NOT is in the sequence.
- function Process_Node (N : Node_Id) return Traverse_Result;
- -- Processes one node in the traversal, looking for logical operators,
- -- and if one is found, outputs the appropriate table entries.
-
procedure Output_Decision_Operand (N : Node_Id);
-- The node N is the top level logical operator of a decision, or it is
-- one of the operands of a logical operator belonging to a single
@@ -556,19 +563,24 @@ package body Par_SCO is
-- the complex decision. It process the suboperands of the decision
-- looking for nested decisions.
+ function Process_Node (N : Node_Id) return Traverse_Result;
+ -- Processes one node in the traversal, looking for logical operators,
+ -- and if one is found, outputs the appropriate table entries.
+
-----------------------------
-- Output_Decision_Operand --
-----------------------------
procedure Output_Decision_Operand (N : Node_Id) is
- C1, C2 : Character;
+ C1 : Character;
+ C2 : Character;
-- C1 holds a character that identifies the operation while C2
-- indicates whether we are sure (' ') or not ('?') this operation
-- belongs to the decision. '?' entries will be filtered out in the
-- second (SCO_Record_Filtered) pass.
- L : Node_Id;
- T : Tristate;
+ L : Node_Id;
+ T : Tristate;
begin
if No (N) then
@@ -744,7 +756,12 @@ package body Par_SCO is
-- Logical operators, output table entries and then process
-- operands recursively to deal with nested conditions.
- when N_And_Then | N_Or_Else | N_Op_Not | N_Op_And | N_Op_Or =>
+ when N_And_Then
+ | N_Op_And
+ | N_Op_Not
+ | N_Op_Or
+ | N_Or_Else
+ =>
declare
T : Character;
@@ -761,7 +778,7 @@ package body Par_SCO is
-- Output header for sequence
X_Not_Decision := T = 'X' and then Nkind (N) = N_Op_Not;
- Mark := SCO_Raw_Table.Last;
+ Mark := SCO_Raw_Table.Last;
Mark_Hash := Hash_Entries.Last;
Output_Header (T);
@@ -804,6 +821,7 @@ package body Par_SCO is
Cond : constant Node_Id := First (Expressions (N));
Thnx : constant Node_Id := Next (Cond);
Elsx : constant Node_Id := Next (Thnx);
+
begin
Process_Decisions (Cond, 'I', Pragma_Sloc);
Process_Decisions (Thnx, 'X', Pragma_Sloc);
@@ -815,7 +833,6 @@ package body Par_SCO is
when others =>
return OK;
-
end case;
end Process_Node;
@@ -865,7 +882,6 @@ package body Par_SCO is
-----------
procedure pscos is
-
procedure Write_Info_Char (C : Character) renames Write_Char;
-- Write one character;
@@ -907,6 +923,7 @@ package body Par_SCO is
((Inst_Dep_Num => Dependency_Num (Unit (Inst_Src)),
Inst_Loc => To_Source_Location (Inst_Sloc),
Enclosing_Instance => SCO_Instance_Index (Instance (Inst_Src))));
+
pragma Assert
(SCO_Instance_Table.Last = SCO_Instance_Index (Id));
end Record_Instance;
@@ -918,6 +935,7 @@ package body Par_SCO is
procedure SCO_Output is
procedure Populate_SCO_Instance_Table is
new Sinput.Iterate_On_Instances (Record_Instance);
+
begin
pragma Assert (SCO_Generation_State = Filtered);
@@ -930,8 +948,7 @@ package body Par_SCO is
-- Sort the unit tables based on dependency numbers
Unit_Table_Sort : declare
-
- function Lt (Op1, Op2 : Natural) return Boolean;
+ function Lt (Op1 : Natural; Op2 : Natural) return Boolean;
-- Comparison routine for sort call
procedure Move (From : Natural; To : Natural);
@@ -941,7 +958,7 @@ package body Par_SCO is
-- Lt --
--------
- function Lt (Op1, Op2 : Natural) return Boolean is
+ function Lt (Op1 : Natural; Op2 : Natural) return Boolean is
begin
return
Dependency_Num
@@ -978,6 +995,7 @@ package body Par_SCO is
declare
U : constant Unit_Number_Type := SCO_Unit_Number_Table.Table (J);
UTE : SCO_Unit_Table_Entry renames SCO_Unit_Table.Table (J);
+
begin
Get_Name_String (Reference_Name (Source_Index (U)));
UTE.File_Name := new String'(Name_Buffer (1 .. Name_Len));
@@ -1050,9 +1068,6 @@ package body Par_SCO is
--------------------
procedure SCO_Record_Raw (U : Unit_Number_Type) is
- Lu : Node_Id;
- From : Nat;
-
procedure Traverse_Aux_Decls (N : Node_Id);
-- Traverse the Aux_Decls_Node of compilation unit N
@@ -1062,6 +1077,7 @@ package body Par_SCO is
procedure Traverse_Aux_Decls (N : Node_Id) is
ADN : constant Node_Id := Aux_Decls_Node (N);
+
begin
Traverse_Declarations_Or_Statements (Config_Pragmas (ADN));
Traverse_Declarations_Or_Statements (Pragmas_After (ADN));
@@ -1074,6 +1090,11 @@ package body Par_SCO is
pragma Assert (No (Actions (ADN)));
end Traverse_Aux_Decls;
+ -- Local variables
+
+ From : Nat;
+ Lu : Node_Id;
+
-- Start of processing for SCO_Record_Raw
begin
@@ -1114,23 +1135,21 @@ package body Par_SCO is
Traverse_Aux_Decls (Cunit (U));
case Nkind (Lu) is
- when
- N_Package_Declaration |
- N_Package_Body |
- N_Subprogram_Declaration |
- N_Subprogram_Body |
- N_Generic_Package_Declaration |
- N_Protected_Body |
- N_Task_Body |
- N_Generic_Instantiation =>
-
+ when N_Generic_Instantiation
+ | N_Generic_Package_Declaration
+ | N_Package_Body
+ | N_Package_Declaration
+ | N_Protected_Body
+ | N_Subprogram_Body
+ | N_Subprogram_Declaration
+ | N_Task_Body
+ =>
Traverse_Declarations_Or_Statements (L => No_List, P => Lu);
- when others =>
-
- -- All other cases of compilation units (e.g. renamings), generate
- -- no SCO information.
+ -- All other cases of compilation units (e.g. renamings), generate no
+ -- SCO information.
+ when others =>
null;
end case;
@@ -1157,13 +1176,14 @@ package body Par_SCO is
pragma Assert (not Generate_SCO or else SCO_Generation_State = Raw);
+ Constant_Condition_Code : constant array (Boolean) of Character :=
+ (False => 'f', True => 't');
+
Orig : constant Node_Id := Original_Node (Cond);
+ Dummy : Source_Ptr;
Index : Nat;
Start : Source_Ptr;
- Dummy : Source_Ptr;
- Constant_Condition_Code : constant array (Boolean) of Character :=
- (False => 'f', True => 't');
begin
Sloc_Range (Orig, Start, Dummy);
Index := SCO_Raw_Hash_Table.Get (Start);
@@ -1191,9 +1211,9 @@ package body Par_SCO is
pragma Assert (not Generate_SCO or else SCO_Generation_State = Raw);
- Orig : constant Node_Id := Original_Node (Op);
+ Orig : constant Node_Id := Original_Node (Op);
Orig_Sloc : constant Source_Ptr := Sloc (Orig);
- Index : constant Nat := SCO_Raw_Hash_Table.Get (Orig_Sloc);
+ Index : constant Nat := SCO_Raw_Hash_Table.Get (Orig_Sloc);
begin
-- All (putative) logical operators are supposed to have their own entry
@@ -1333,25 +1353,25 @@ package body Par_SCO is
-- the range of entries in the CS line entry, and typ is the type, with
-- space meaning that no type letter will accompany the entry.
- package SC is new Table.Table (
- Table_Component_Type => SC_Entry,
- Table_Index_Type => Nat,
- Table_Low_Bound => 1,
- Table_Initial => 1000,
- Table_Increment => 200,
- Table_Name => "SCO_SC");
- -- Used to store statement components for a CS entry to be output
- -- as a result of the call to this procedure. SC.Last is the last
- -- entry stored, so the current statement sequence is represented
- -- by SC_Array (SC_First .. SC.Last), where SC_First is saved on
- -- entry to each recursive call to the routine.
- --
- -- Extend_Statement_Sequence adds an entry to this array, and then
- -- Set_Statement_Entry clears the entries starting with SC_First,
- -- copying these entries to the main SCO output table. The reason that
- -- we do the temporary caching of results in this array is that we want
- -- the SCO table entries for a given CS line to be contiguous, and the
- -- processing may output intermediate entries such as decision entries.
+ package SC is new Table.Table
+ (Table_Component_Type => SC_Entry,
+ Table_Index_Type => Nat,
+ Table_Low_Bound => 1,
+ Table_Initial => 1000,
+ Table_Increment => 200,
+ Table_Name => "SCO_SC");
+ -- Used to store statement components for a CS entry to be output as a
+ -- result of the call to this procedure. SC.Last is the last entry stored,
+ -- so the current statement sequence is represented by SC_Array (SC_First
+ -- .. SC.Last), where SC_First is saved on entry to each recursive call to
+ -- the routine.
+ --
+ -- Extend_Statement_Sequence adds an entry to this array, and then
+ -- Set_Statement_Entry clears the entries starting with SC_First, copying
+ -- these entries to the main SCO output table. The reason that we do the
+ -- temporary caching of results in this array is that we want the SCO table
+ -- entries for a given CS line to be contiguous, and the processing may
+ -- output intermediate entries such as decision entries.
type SD_Entry is record
Nod : Node_Id;
@@ -1366,13 +1386,13 @@ package body Par_SCO is
-- argument (in which case Nod is set to Empty). Plo is the sloc of the
-- enclosing pragma, if any.
- package SD is new Table.Table (
- Table_Component_Type => SD_Entry,
- Table_Index_Type => Nat,
- Table_Low_Bound => 1,
- Table_Initial => 1000,
- Table_Increment => 200,
- Table_Name => "SCO_SD");
+ package SD is new Table.Table
+ (Table_Component_Type => SD_Entry,
+ Table_Index_Type => Nat,
+ Table_Low_Bound => 1,
+ Table_Initial => 1000,
+ Table_Increment => 200,
+ Table_Name => "SCO_SD");
-- Used to store possible decision information. Instead of calling the
-- Process_Decisions procedures directly, we call Process_Decisions_Defer,
-- which simply stores the arguments in this table. Then when we clear
@@ -1411,32 +1431,124 @@ package body Par_SCO is
-- Record first entries used in SC/SD at this recursive level
procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character);
- -- Extend the current statement sequence to encompass the node N. Typ
- -- is the letter that identifies the type of statement/declaration that
- -- is being added to the sequence.
-
- procedure Set_Statement_Entry;
- -- Output CS entries for all statements saved in table SC, and end the
- -- current CS sequence. Then output entries for all decisions nested in
- -- these statements, which have been deferred so far.
+ -- Extend the current statement sequence to encompass the node N. Typ is
+ -- the letter that identifies the type of statement/declaration that is
+ -- being added to the sequence.
procedure Process_Decisions_Defer (N : Node_Id; T : Character);
pragma Inline (Process_Decisions_Defer);
-- This routine is logically the same as Process_Decisions, except that
-- the arguments are saved in the SD table for later processing when
-- Set_Statement_Entry is called, which goes through the saved entries
- -- making the corresponding calls to Process_Decision.
+ -- making the corresponding calls to Process_Decision. Note: the
+ -- enclosing statement must have already been added to the current
+ -- statement sequence, so that nested decisions are properly
+ -- identified as such.
procedure Process_Decisions_Defer (L : List_Id; T : Character);
pragma Inline (Process_Decisions_Defer);
-- Same case for list arguments, deferred call to Process_Decisions
+ procedure Set_Statement_Entry;
+ -- Output CS entries for all statements saved in table SC, and end the
+ -- current CS sequence. Then output entries for all decisions nested in
+ -- these statements, which have been deferred so far.
+
procedure Traverse_One (N : Node_Id);
-- Traverse one declaration or statement
procedure Traverse_Aspects (N : Node_Id);
-- Helper for Traverse_One: traverse N's aspect specifications
+ procedure Traverse_Degenerate_Subprogram (N : Node_Id);
+ -- Common code to handle null procedures and expression functions. Emit
+ -- a SCO of the given Kind and N outside of the dominance flow.
+
+ -------------------------------
+ -- Extend_Statement_Sequence --
+ -------------------------------
+
+ procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character) is
+ Dummy : Source_Ptr;
+ F : Source_Ptr;
+ T : Source_Ptr;
+ To_Node : Node_Id := Empty;
+
+ begin
+ Sloc_Range (N, F, T);
+
+ case Nkind (N) is
+ when N_Accept_Statement =>
+ if Present (Parameter_Specifications (N)) then
+ To_Node := Last (Parameter_Specifications (N));
+ elsif Present (Entry_Index (N)) then
+ To_Node := Entry_Index (N);
+ end if;
+
+ when N_Case_Statement =>
+ To_Node := Expression (N);
+
+ when N_Elsif_Part
+ | N_If_Statement
+ =>
+ To_Node := Condition (N);
+
+ when N_Extended_Return_Statement =>
+ To_Node := Last (Return_Object_Declarations (N));
+
+ when N_Loop_Statement =>
+ To_Node := Iteration_Scheme (N);
+
+ when N_Asynchronous_Select
+ | N_Conditional_Entry_Call
+ | N_Selective_Accept
+ | N_Single_Protected_Declaration
+ | N_Single_Task_Declaration
+ | N_Timed_Entry_Call
+ =>
+ T := F;
+
+ when N_Protected_Type_Declaration
+ | N_Task_Type_Declaration
+ =>
+ if Has_Aspects (N) then
+ To_Node := Last (Aspect_Specifications (N));
+
+ elsif Present (Discriminant_Specifications (N)) then
+ To_Node := Last (Discriminant_Specifications (N));
+
+ else
+ To_Node := Defining_Identifier (N);
+ end if;
+
+ when N_Subexpr =>
+ To_Node := N;
+
+ when others =>
+ null;
+ end case;
+
+ if Present (To_Node) then
+ Sloc_Range (To_Node, Dummy, T);
+ end if;
+
+ SC.Append ((N, F, T, Typ));
+ end Extend_Statement_Sequence;
+
+ -----------------------------
+ -- Process_Decisions_Defer --
+ -----------------------------
+
+ procedure Process_Decisions_Defer (N : Node_Id; T : Character) is
+ begin
+ SD.Append ((N, No_List, T, Current_Pragma_Sloc));
+ end Process_Decisions_Defer;
+
+ procedure Process_Decisions_Defer (L : List_Id; T : Character) is
+ begin
+ SD.Append ((Empty, L, T, Current_Pragma_Sloc));
+ end Process_Decisions_Defer;
+
-------------------------
-- Set_Statement_Entry --
-------------------------
@@ -1453,12 +1565,16 @@ package body Par_SCO is
if Current_Dominant /= No_Dominant then
declare
- From, To : Source_Ptr;
+ From : Source_Ptr;
+ To : Source_Ptr;
+
begin
Sloc_Range (Current_Dominant.N, From, To);
+
if Current_Dominant.K /= 'E' then
To := No_Location;
end if;
+
Set_Raw_Table_Entry
(C1 => '>',
C2 => Current_Dominant.K,
@@ -1475,6 +1591,7 @@ package body Par_SCO is
SCE : SC_Entry renames SC.Table (J);
Pragma_Sloc : Source_Ptr := No_Location;
Pragma_Aspect_Name : Name_Id := No_Name;
+
begin
-- For the case of a statement SCO for a pragma controlled by
-- Set_SCO_Pragma_Enabled, set Pragma_Sloc so that the SCO (and
@@ -1485,11 +1602,11 @@ package body Par_SCO is
Pragma_Sloc := SCE.From;
SCO_Raw_Hash_Table.Set
(Pragma_Sloc, SCO_Raw_Table.Last + 1);
- Pragma_Aspect_Name := Pragma_Name (SCE.N);
+ Pragma_Aspect_Name := Pragma_Name_Unmapped (SCE.N);
pragma Assert (Pragma_Aspect_Name /= No_Name);
elsif SCE.Typ = 'P' then
- Pragma_Aspect_Name := Pragma_Name (SCE.N);
+ Pragma_Aspect_Name := Pragma_Name_Unmapped (SCE.N);
pragma Assert (Pragma_Aspect_Name /= No_Name);
end if;
@@ -1520,6 +1637,7 @@ package body Par_SCO is
for J in SD_First .. SD_Last loop
declare
SDE : SD_Entry renames SD.Table (J);
+
begin
if Present (SDE.Nod) then
Process_Decisions (SDE.Nod, SDE.Typ, SDE.Plo);
@@ -1534,91 +1652,13 @@ package body Par_SCO is
SD.Set_Last (SD_First - 1);
end Set_Statement_Entry;
- -------------------------------
- -- Extend_Statement_Sequence --
- -------------------------------
-
- procedure Extend_Statement_Sequence (N : Node_Id; Typ : Character) is
- F : Source_Ptr;
- T : Source_Ptr;
- Dummy : Source_Ptr;
- To_Node : Node_Id := Empty;
-
- begin
- Sloc_Range (N, F, T);
-
- case Nkind (N) is
- when N_Accept_Statement =>
- if Present (Parameter_Specifications (N)) then
- To_Node := Last (Parameter_Specifications (N));
- elsif Present (Entry_Index (N)) then
- To_Node := Entry_Index (N);
- end if;
-
- when N_Case_Statement =>
- To_Node := Expression (N);
-
- when N_If_Statement | N_Elsif_Part =>
- To_Node := Condition (N);
-
- when N_Extended_Return_Statement =>
- To_Node := Last (Return_Object_Declarations (N));
-
- when N_Loop_Statement =>
- To_Node := Iteration_Scheme (N);
-
- when N_Selective_Accept |
- N_Timed_Entry_Call |
- N_Conditional_Entry_Call |
- N_Asynchronous_Select |
- N_Single_Protected_Declaration |
- N_Single_Task_Declaration =>
- T := F;
-
- when N_Protected_Type_Declaration | N_Task_Type_Declaration =>
- if Has_Aspects (N) then
- To_Node := Last (Aspect_Specifications (N));
-
- elsif Present (Discriminant_Specifications (N)) then
- To_Node := Last (Discriminant_Specifications (N));
-
- else
- To_Node := Defining_Identifier (N);
- end if;
-
- when others =>
- null;
-
- end case;
-
- if Present (To_Node) then
- Sloc_Range (To_Node, Dummy, T);
- end if;
-
- SC.Append ((N, F, T, Typ));
- end Extend_Statement_Sequence;
-
- -----------------------------
- -- Process_Decisions_Defer --
- -----------------------------
-
- procedure Process_Decisions_Defer (N : Node_Id; T : Character) is
- begin
- SD.Append ((N, No_List, T, Current_Pragma_Sloc));
- end Process_Decisions_Defer;
-
- procedure Process_Decisions_Defer (L : List_Id; T : Character) is
- begin
- SD.Append ((Empty, L, T, Current_Pragma_Sloc));
- end Process_Decisions_Defer;
-
----------------------
-- Traverse_Aspects --
----------------------
procedure Traverse_Aspects (N : Node_Id) is
- AN : Node_Id;
AE : Node_Id;
+ AN : Node_Id;
C1 : Character;
begin
@@ -1640,12 +1680,13 @@ package body Par_SCO is
-- specification. The corresponding pragma will have the same
-- sloc.
- when Aspect_Pre |
- Aspect_Precondition |
- Aspect_Post |
- Aspect_Postcondition |
- Aspect_Invariant =>
-
+ when Aspect_Invariant
+ | Aspect_Post
+ | Aspect_Postcondition
+ | Aspect_Pre
+ | Aspect_Precondition
+ | Aspect_Type_Invariant
+ =>
C1 := 'a';
-- Aspects whose checks are generated in client units,
@@ -1658,22 +1699,19 @@ package body Par_SCO is
-- Pre/post can have checks in client units too because of
-- inheritance, so should they be moved here???
- when Aspect_Predicate |
- Aspect_Static_Predicate |
- Aspect_Dynamic_Predicate |
- Aspect_Type_Invariant =>
-
+ when Aspect_Dynamic_Predicate
+ | Aspect_Predicate
+ | Aspect_Static_Predicate
+ =>
C1 := 'A';
-- Other aspects: just process any decision nested in the
-- aspect expression.
when others =>
-
if Has_Decision (AE) then
C1 := 'X';
end if;
-
end case;
if C1 /= ASCII.NUL then
@@ -1692,6 +1730,45 @@ package body Par_SCO is
end loop;
end Traverse_Aspects;
+ ------------------------------------
+ -- Traverse_Degenerate_Subprogram --
+ ------------------------------------
+
+ procedure Traverse_Degenerate_Subprogram (N : Node_Id) is
+ begin
+ -- Complete current sequence of statements
+
+ Set_Statement_Entry;
+
+ declare
+ Saved_Dominant : constant Dominant_Info := Current_Dominant;
+ -- Save last statement in current sequence as dominant
+
+ begin
+ -- Output statement SCO for degenerate subprogram body (null
+ -- statement or freestanding expression) outside of the dominance
+ -- chain.
+
+ Current_Dominant := No_Dominant;
+ Extend_Statement_Sequence (N, Typ => ' ');
+
+ -- For the case of an expression-function, collect decisions
+ -- embedded in the expression now.
+
+ if Nkind (N) in N_Subexpr then
+ Process_Decisions_Defer (N, 'X');
+ end if;
+
+ Set_Statement_Entry;
+
+ -- Restore current dominant information designating last statement
+ -- in previous sequence (i.e. make the dominance chain skip over
+ -- the degenerate body).
+
+ Current_Dominant := Saved_Dominant;
+ end;
+ end Traverse_Degenerate_Subprogram;
+
------------------
-- Traverse_One --
------------------
@@ -1725,9 +1802,32 @@ package body Par_SCO is
-- Subprogram declaration or subprogram body stub
- when N_Subprogram_Declaration | N_Subprogram_Body_Stub =>
- Process_Decisions_Defer
- (Parameter_Specifications (Specification (N)), 'X');
+ when N_Expression_Function
+ | N_Subprogram_Body_Stub
+ | N_Subprogram_Declaration
+ =>
+ declare
+ Spec : constant Node_Id := Specification (N);
+ begin
+ Process_Decisions_Defer
+ (Parameter_Specifications (Spec), 'X');
+
+ -- Case of a null procedure: generate a NULL statement SCO
+
+ if Nkind (N) = N_Subprogram_Declaration
+ and then Nkind (Spec) = N_Procedure_Specification
+ and then Null_Present (Spec)
+ then
+ Traverse_Degenerate_Subprogram (N);
+
+ -- Case of an expression function: generate a statement SCO
+ -- for the expression (and then decision SCOs for any nested
+ -- decisions).
+
+ elsif Nkind (N) = N_Expression_Function then
+ Traverse_Degenerate_Subprogram (Expression (N));
+ end if;
+ end;
-- Entry declaration
@@ -1744,7 +1844,9 @@ package body Par_SCO is
-- Task or subprogram body
- when N_Task_Body | N_Subprogram_Body =>
+ when N_Subprogram_Body
+ | N_Task_Body
+ =>
Set_Statement_Entry;
Traverse_Subprogram_Or_Task_Body (N);
@@ -1901,7 +2003,7 @@ package body Par_SCO is
declare
Alt : Node_Id;
begin
- Alt := First (Alternatives (N));
+ Alt := First_Non_Pragma (Alternatives (N));
while Present (Alt) loop
Traverse_Declarations_Or_Statements
(L => Statements (Alt),
@@ -1961,7 +2063,9 @@ package body Par_SCO is
(L => Else_Statements (N),
D => Current_Dominant);
- when N_Timed_Entry_Call | N_Conditional_Entry_Call =>
+ when N_Conditional_Entry_Call
+ | N_Timed_Entry_Call
+ =>
Extend_Statement_Sequence (N, 'S');
Set_Statement_Entry;
@@ -2023,9 +2127,10 @@ package body Par_SCO is
-- Unconditional exit points, which are included in the current
-- statement sequence, but then terminate it
- when N_Requeue_Statement |
- N_Goto_Statement |
- N_Raise_Statement =>
+ when N_Goto_Statement
+ | N_Raise_Statement
+ | N_Requeue_Statement
+ =>
Extend_Statement_Sequence (N, ' ');
Set_Statement_Entry;
Current_Dominant := No_Dominant;
@@ -2043,8 +2148,7 @@ package body Par_SCO is
when N_Extended_Return_Statement =>
Extend_Statement_Sequence (N, 'R');
- Process_Decisions_Defer
- (Return_Object_Declarations (N), 'X');
+ Process_Decisions_Defer (Return_Object_Declarations (N), 'X');
Set_Statement_Entry;
Traverse_Handled_Statement_Sequence
@@ -2114,21 +2218,21 @@ package body Par_SCO is
-- Processing depends on the kind of pragma
declare
- Nam : constant Name_Id := Pragma_Name (N);
+ Nam : constant Name_Id := Pragma_Name_Unmapped (N);
Arg : Node_Id :=
First (Pragma_Argument_Associations (N));
Typ : Character;
begin
case Nam is
- when Name_Assert |
- Name_Assert_And_Cut |
- Name_Assume |
- Name_Check |
- Name_Loop_Invariant |
- Name_Precondition |
- Name_Postcondition =>
-
+ when Name_Assert
+ | Name_Assert_And_Cut
+ | Name_Assume
+ | Name_Check
+ | Name_Loop_Invariant
+ | Name_Postcondition
+ | Name_Precondition
+ =>
-- For Assert/Check/Precondition/Postcondition, we
-- must generate a P entry for the decision. Note
-- that this is done unconditionally at this stage.
@@ -2186,7 +2290,9 @@ package body Par_SCO is
-- want one entry in the SCOs, so we take the first, for which
-- Prev_Ids is False.
- when N_Object_Declaration | N_Number_Declaration =>
+ when N_Number_Declaration
+ | N_Object_Declaration
+ =>
if not Prev_Ids (N) then
Extend_Statement_Sequence (N, 'o');
@@ -2198,14 +2304,18 @@ package body Par_SCO is
-- All other cases, which extend the current statement sequence
-- but do not terminate it, even if they have nested decisions.
- when N_Protected_Type_Declaration | N_Task_Type_Declaration =>
+ when N_Protected_Type_Declaration
+ | N_Task_Type_Declaration
+ =>
Extend_Statement_Sequence (N, 't');
Process_Decisions_Defer (Discriminant_Specifications (N), 'X');
Set_Statement_Entry;
Traverse_Sync_Definition (N);
- when N_Single_Protected_Declaration | N_Single_Task_Declaration =>
+ when N_Single_Protected_Declaration
+ | N_Single_Task_Declaration
+ =>
Extend_Statement_Sequence (N, 'o');
Set_Statement_Entry;
@@ -2222,33 +2332,35 @@ package body Par_SCO is
begin
case NK is
- when N_Full_Type_Declaration |
- N_Incomplete_Type_Declaration |
- N_Private_Type_Declaration |
- N_Private_Extension_Declaration =>
+ when N_Full_Type_Declaration
+ | N_Incomplete_Type_Declaration
+ | N_Private_Extension_Declaration
+ | N_Private_Type_Declaration
+ =>
Typ := 't';
- when N_Subtype_Declaration =>
+ when N_Subtype_Declaration =>
Typ := 's';
- when N_Renaming_Declaration =>
+ when N_Renaming_Declaration =>
Typ := 'r';
- when N_Generic_Instantiation =>
+ when N_Generic_Instantiation =>
Typ := 'i';
- when N_Representation_Clause |
- N_Use_Package_Clause |
- N_Use_Type_Clause |
- N_Package_Body_Stub |
- N_Task_Body_Stub |
- N_Protected_Body_Stub =>
+ when N_Package_Body_Stub
+ | N_Protected_Body_Stub
+ | N_Representation_Clause
+ | N_Task_Body_Stub
+ | N_Use_Package_Clause
+ | N_Use_Type_Clause
+ =>
Typ := ASCII.NUL;
when N_Procedure_Call_Statement =>
Typ := ' ';
- when others =>
+ when others =>
if NK in N_Statement_Other_Than_Procedure_Call then
Typ := ' ';
else
@@ -2338,7 +2450,7 @@ package body Par_SCO is
Traverse_Declarations_Or_Statements (Statements (N), D);
if Present (Exception_Handlers (N)) then
- Handler := First (Exception_Handlers (N));
+ Handler := First_Non_Pragma (Exception_Handlers (N));
while Present (Handler) loop
Traverse_Declarations_Or_Statements
(L => Statements (Handler),
@@ -2397,22 +2509,36 @@ package body Par_SCO is
Sync_Def : Node_Id;
-- N's protected or task definition
- Vis_Decl : List_Id;
- -- Sync_Def's Visible_Declarations
+ Priv_Decl : List_Id;
+ Vis_Decl : List_Id;
+ -- Sync_Def's Visible_Declarations and Private_Declarations
begin
case Nkind (N) is
- when N_Single_Protected_Declaration | N_Protected_Type_Declaration =>
+ when N_Protected_Type_Declaration
+ | N_Single_Protected_Declaration
+ =>
Sync_Def := Protected_Definition (N);
- when N_Single_Task_Declaration | N_Task_Type_Declaration =>
+ when N_Single_Task_Declaration
+ | N_Task_Type_Declaration
+ =>
Sync_Def := Task_Definition (N);
when others =>
raise Program_Error;
end case;
- Vis_Decl := Visible_Declarations (Sync_Def);
+ -- Sync_Def may be Empty at least for empty Task_Type_Declarations.
+ -- Querying Visible or Private_Declarations is invalid in this case.
+
+ if Present (Sync_Def) then
+ Vis_Decl := Visible_Declarations (Sync_Def);
+ Priv_Decl := Private_Declarations (Sync_Def);
+ else
+ Vis_Decl := No_List;
+ Priv_Decl := No_List;
+ end if;
Dom_Info := Traverse_Declarations_Or_Statements
(L => Vis_Decl,
@@ -2422,7 +2548,7 @@ package body Par_SCO is
-- is dominated by the last visible declaration.
Traverse_Declarations_Or_Statements
- (L => Private_Declarations (Sync_Def),
+ (L => Priv_Decl,
D => Dom_Info);
end Traverse_Sync_Definition;
@@ -2435,7 +2561,8 @@ package body Par_SCO is
D : Dominant_Info := No_Dominant)
is
Decls : constant List_Id := Declarations (N);
- Dom_Info : Dominant_Info := D;
+ Dom_Info : Dominant_Info := D;
+
begin
-- If declarations are present, the first statement is dominated by the
-- last declaration.
@@ -2475,23 +2602,9 @@ package body Par_SCO is
Table_Name => "Filter_Pending_Decisions");
-- Table used to hold decisions to process during the collection pass
- function Is_Decision (Idx : Nat) return Boolean;
- -- Return if the expression tree starting at Idx has adjacent nested
- -- nodes that make a decision.
-
- procedure Search_Nested_Decisions (Idx : in out Nat);
- -- Collect decisions to add to the filtered SCO table starting at the
- -- node at Idx in the SCO raw table. This node must not be part of an
- -- already-processed decision. Set Idx to the first node index passed
- -- the whole expression tree.
-
- procedure Skip_Decision
- (Idx : in out Nat;
- Process_Nested_Decisions : Boolean);
- -- Skip all the nodes that belong to the decision starting at Idx. If
- -- Process_Nested_Decision, call Search_Nested_Decisions on the first
- -- nested nodes that do not belong to the decision. Set Idx to the first
- -- node index passed the whole expression tree.
+ procedure Add_Expression_Tree (Idx : in out Nat);
+ -- Add SCO raw table entries for the decision controlling expression
+ -- tree starting at Idx to the filtered SCO table.
procedure Collect_Decisions
(D : Decision;
@@ -2507,149 +2620,87 @@ package body Par_SCO is
-- Compute the source location range for the expression tree starting at
-- Idx in the SCO raw table. Store its bounds in From and To.
- procedure Add_Expression_Tree (Idx : in out Nat);
- -- Add SCO raw table entries for the decision controlling expression
- -- tree starting at Idx to the filtered SCO table.
+ function Is_Decision (Idx : Nat) return Boolean;
+ -- Return if the expression tree starting at Idx has adjacent nested
+ -- nodes that make a decision.
procedure Process_Pending_Decisions
(Original_Decision : SCO_Table_Entry);
-- Complete the filtered SCO table using collected decisions. Output
-- decisions inherit the pragma information from the original decision.
- -----------------
- -- Is_Decision --
- -----------------
-
- function Is_Decision (Idx : Nat) return Boolean is
- Index : Nat := Idx;
-
- begin
- loop
- declare
- T : SCO_Table_Entry renames SCO_Raw_Table.Table (Index);
-
- begin
- case T.C1 is
- when ' ' =>
- return False;
-
- when '!' =>
-
- -- This is a decision iff the only operand of the NOT
- -- operator could be a standalone decision.
-
- Index := Idx + 1;
-
- when others =>
-
- -- This node is a logical operator (and thus could be a
- -- standalone decision) iff it is a short circuit
- -- operator.
+ procedure Search_Nested_Decisions (Idx : in out Nat);
+ -- Collect decisions to add to the filtered SCO table starting at the
+ -- node at Idx in the SCO raw table. This node must not be part of an
+ -- already-processed decision. Set Idx to the first node index passed
+ -- the whole expression tree.
- return T.C2 /= '?';
+ procedure Skip_Decision
+ (Idx : in out Nat;
+ Process_Nested_Decisions : Boolean);
+ -- Skip all the nodes that belong to the decision starting at Idx. If
+ -- Process_Nested_Decision, call Search_Nested_Decisions on the first
+ -- nested nodes that do not belong to the decision. Set Idx to the first
+ -- node index passed the whole expression tree.
- end case;
- end;
- end loop;
- end Is_Decision;
+ -------------------------
+ -- Add_Expression_Tree --
+ -------------------------
- -----------------------------
- -- Search_Nested_Decisions --
- -----------------------------
+ procedure Add_Expression_Tree (Idx : in out Nat) is
+ Node_Idx : constant Nat := Idx;
+ T : SCO_Table_Entry renames SCO_Raw_Table.Table (Node_Idx);
+ From : Source_Location;
+ To : Source_Location;
- procedure Search_Nested_Decisions (Idx : in out Nat)
- is
begin
- loop
- declare
- T : SCO_Table_Entry renames SCO_Raw_Table.Table (Idx);
-
- begin
- case T.C1 is
- when ' ' =>
- Idx := Idx + 1;
- exit;
-
- when '!' =>
- Collect_Decisions
- ((Kind => 'X',
- Sloc => T.From,
- Top => Idx),
- Idx);
- exit;
-
- when others =>
- if T.C2 = '?' then
-
- -- This in not a logical operator: start looking for
- -- nested decisions from here. Recurse over the left
- -- child and let the loop take care of the right one.
-
- Idx := Idx + 1;
- Search_Nested_Decisions (Idx);
+ case T.C1 is
+ when ' ' =>
- else
- -- We found a nested decision
+ -- This is a single condition. Add an entry for it and move on
- Collect_Decisions
- ((Kind => 'X',
- Sloc => T.From,
- Top => Idx),
- Idx);
- exit;
- end if;
- end case;
- end;
- end loop;
- end Search_Nested_Decisions;
+ SCO_Table.Append (T);
+ Idx := Idx + 1;
- -------------------
- -- Skip_Decision --
- -------------------
+ when '!' =>
- procedure Skip_Decision
- (Idx : in out Nat;
- Process_Nested_Decisions : Boolean)
- is
- begin
- loop
- declare
- T : SCO_Table_Entry renames SCO_Raw_Table.Table (Idx);
+ -- This is a NOT operator: add an entry for it and browse its
+ -- only child.
- begin
+ SCO_Table.Append (T);
Idx := Idx + 1;
+ Add_Expression_Tree (Idx);
- case T.C1 is
- when ' ' =>
- exit;
-
- when '!' =>
-
- -- This NOT operator belongs to the outside decision:
- -- just skip it.
+ when others =>
- null;
+ -- This must be an AND/OR/AND THEN/OR ELSE operator
- when others =>
- if T.C2 = '?' and then Process_Nested_Decisions then
+ if T.C2 = '?' then
- -- This in not a logical operator: start looking for
- -- nested decisions from here. Recurse over the left
- -- child and let the loop take care of the right one.
+ -- This is not a short circuit operator: consider this one
+ -- and all its children as a single condition.
- Search_Nested_Decisions (Idx);
+ Compute_Range (Idx, From, To);
+ SCO_Table.Append
+ ((From => From,
+ To => To,
+ C1 => ' ',
+ C2 => 'c',
+ Last => False,
+ Pragma_Sloc => No_Location,
+ Pragma_Aspect_Name => No_Name));
- else
- -- This is a logical operator, so it belongs to the
- -- outside decision: skip its left child, then let the
- -- loop take care of the right one.
+ else
+ -- This is a real short circuit operator: add an entry for
+ -- it and browse its children.
- Skip_Decision (Idx, Process_Nested_Decisions);
- end if;
- end case;
- end;
- end loop;
- end Skip_Decision;
+ SCO_Table.Append (T);
+ Idx := Idx + 1;
+ Add_Expression_Tree (Idx);
+ Add_Expression_Tree (Idx);
+ end if;
+ end case;
+ end Add_Expression_Tree;
-----------------------
-- Collect_Decisions --
@@ -2660,6 +2711,7 @@ package body Par_SCO is
Next : out Nat)
is
Idx : Nat := D.Top;
+
begin
if D.Kind /= 'X' or else Is_Decision (D.Top) then
Pending_Decisions.Append (D);
@@ -2678,7 +2730,8 @@ package body Par_SCO is
From : out Source_Location;
To : out Source_Location)
is
- Sloc_F, Sloc_T : Source_Location := No_Source_Location;
+ Sloc_F : Source_Location := No_Source_Location;
+ Sloc_T : Source_Location := No_Source_Location;
procedure Process_One;
-- Process one node of the tree, and recurse over children. Update
@@ -2696,6 +2749,7 @@ package body Par_SCO is
then
Sloc_F := SCO_Raw_Table.Table (Idx).From;
end if;
+
if Sloc_T = No_Source_Location
or else
Sloc_T < SCO_Raw_Table.Table (Idx).To
@@ -2732,67 +2786,44 @@ package body Par_SCO is
begin
Process_One;
From := Sloc_F;
- To := Sloc_T;
+ To := Sloc_T;
end Compute_Range;
- -------------------------
- -- Add_Expression_Tree --
- -------------------------
+ -----------------
+ -- Is_Decision --
+ -----------------
- procedure Add_Expression_Tree (Idx : in out Nat)
- is
- Node_Idx : constant Nat := Idx;
- T : SCO_Table_Entry renames SCO_Raw_Table.Table (Node_Idx);
- From, To : Source_Location;
+ function Is_Decision (Idx : Nat) return Boolean is
+ Index : Nat := Idx;
begin
- case T.C1 is
- when ' ' =>
-
- -- This is a single condition. Add an entry for it and move on
-
- SCO_Table.Append (T);
- Idx := Idx + 1;
-
- when '!' =>
-
- -- This is a NOT operator: add an entry for it and browse its
- -- only child.
-
- SCO_Table.Append (T);
- Idx := Idx + 1;
- Add_Expression_Tree (Idx);
+ loop
+ declare
+ T : SCO_Table_Entry renames SCO_Raw_Table.Table (Index);
- when others =>
+ begin
+ case T.C1 is
+ when ' ' =>
+ return False;
- -- This must be an AND/OR/AND THEN/OR ELSE operator
+ when '!' =>
- if T.C2 = '?' then
+ -- This is a decision iff the only operand of the NOT
+ -- operator could be a standalone decision.
- -- This is not a short circuit operator: consider this one
- -- and all its children as a single condition.
+ Index := Idx + 1;
- Compute_Range (Idx, From, To);
- SCO_Table.Append
- ((From => From,
- To => To,
- C1 => ' ',
- C2 => 'c',
- Last => False,
- Pragma_Sloc => No_Location,
- Pragma_Aspect_Name => No_Name));
+ when others =>
- else
- -- This is a real short circuit operator: add an entry for
- -- it and browse its children.
+ -- This node is a logical operator (and thus could be a
+ -- standalone decision) iff it is a short circuit
+ -- operator.
- SCO_Table.Append (T);
- Idx := Idx + 1;
- Add_Expression_Tree (Idx);
- Add_Expression_Tree (Idx);
- end if;
- end case;
- end Add_Expression_Tree;
+ return T.C2 /= '?';
+ end case;
+ end;
+ end loop;
+ end Is_Decision;
-------------------------------
-- Process_Pending_Decisions --
@@ -2834,6 +2865,103 @@ package body Par_SCO is
Pending_Decisions.Set_Last (0);
end Process_Pending_Decisions;
+ -----------------------------
+ -- Search_Nested_Decisions --
+ -----------------------------
+
+ procedure Search_Nested_Decisions (Idx : in out Nat) is
+ begin
+ loop
+ declare
+ T : SCO_Table_Entry renames SCO_Raw_Table.Table (Idx);
+
+ begin
+ case T.C1 is
+ when ' ' =>
+ Idx := Idx + 1;
+ exit;
+
+ when '!' =>
+ Collect_Decisions
+ ((Kind => 'X',
+ Sloc => T.From,
+ Top => Idx),
+ Idx);
+ exit;
+
+ when others =>
+ if T.C2 = '?' then
+
+ -- This is not a logical operator: start looking for
+ -- nested decisions from here. Recurse over the left
+ -- child and let the loop take care of the right one.
+
+ Idx := Idx + 1;
+ Search_Nested_Decisions (Idx);
+
+ else
+ -- We found a nested decision
+
+ Collect_Decisions
+ ((Kind => 'X',
+ Sloc => T.From,
+ Top => Idx),
+ Idx);
+ exit;
+ end if;
+ end case;
+ end;
+ end loop;
+ end Search_Nested_Decisions;
+
+ -------------------
+ -- Skip_Decision --
+ -------------------
+
+ procedure Skip_Decision
+ (Idx : in out Nat;
+ Process_Nested_Decisions : Boolean)
+ is
+ begin
+ loop
+ declare
+ T : SCO_Table_Entry renames SCO_Raw_Table.Table (Idx);
+
+ begin
+ Idx := Idx + 1;
+
+ case T.C1 is
+ when ' ' =>
+ exit;
+
+ when '!' =>
+
+ -- This NOT operator belongs to the outside decision:
+ -- just skip it.
+
+ null;
+
+ when others =>
+ if T.C2 = '?' and then Process_Nested_Decisions then
+
+ -- This is not a logical operator: start looking for
+ -- nested decisions from here. Recurse over the left
+ -- child and let the loop take care of the right one.
+
+ Search_Nested_Decisions (Idx);
+
+ else
+ -- This is a logical operator, so it belongs to the
+ -- outside decision: skip its left child, then let the
+ -- loop take care of the right one.
+
+ Skip_Decision (Idx, Process_Nested_Decisions);
+ end if;
+ end case;
+ end;
+ end loop;
+ end Skip_Decision;
+
-- Start of processing for SCO_Record_Filtered
begin
@@ -2852,7 +2980,7 @@ package body Par_SCO is
for Unit_Idx in 1 .. SCO_Unit_Table.Last loop
declare
Unit : SCO_Unit_Table_Entry
- renames SCO_Unit_Table.Table (Unit_Idx);
+ renames SCO_Unit_Table.Table (Unit_Idx);
Idx : Nat := Unit.From;
-- Index of the current SCO raw table entry
@@ -2912,7 +3040,7 @@ package body Par_SCO is
-- Now, update the SCO entry indexes in the unit entry
Unit.From := New_From;
- Unit.To := SCO_Table.Last;
+ Unit.To := SCO_Table.Last;
end;
end loop;
diff --git a/gcc/ada/pprint.adb b/gcc/ada/pprint.adb
index cc0bfe5f97..fcfccd316f 100644
--- a/gcc/ada/pprint.adb
+++ b/gcc/ada/pprint.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2008-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -205,7 +205,9 @@ package body Pprint is
end if;
case Nkind (Expr) is
- when N_Defining_Identifier | N_Identifier =>
+ when N_Defining_Identifier
+ | N_Identifier
+ =>
return Ident_Image (Expr, Expression_Image.Expr, Expand_Type);
when N_Character_Literal =>
@@ -340,7 +342,9 @@ package body Pprint is
return ".all";
end if;
- when N_Expanded_Name | N_Selected_Component =>
+ when N_Expanded_Name
+ | N_Selected_Component
+ =>
if Take_Prefix then
return
Expr_Name (Prefix (Expr)) & "." &
@@ -381,7 +385,9 @@ package body Pprint is
end if;
end;
- when N_Unchecked_Expression | N_Expression_With_Actions =>
+ when N_Expression_With_Actions
+ | N_Unchecked_Expression
+ =>
return Expr_Name (Expression (Expr));
when N_Raise_Constraint_Error =>
@@ -542,13 +548,28 @@ package body Pprint is
when N_Parameter_Association =>
return Expr_Name (Explicit_Actual_Parameter (Expr));
- when N_Type_Conversion | N_Unchecked_Type_Conversion =>
+ when N_Type_Conversion =>
-- Most conversions are not very interesting (used inside
-- expanded checks to convert to larger ranges), so skip them.
return Expr_Name (Expression (Expr));
+ when N_Unchecked_Type_Conversion =>
+
+ -- Only keep the type conversion in complex cases
+
+ if not Is_Scalar_Type (Etype (Expr))
+ or else not Is_Scalar_Type (Etype (Expression (Expr)))
+ or else Is_Modular_Integer_Type (Etype (Expr)) /=
+ Is_Modular_Integer_Type (Etype (Expression (Expr)))
+ then
+ return Expr_Name (Subtype_Mark (Expr)) &
+ "(" & Expr_Name (Expression (Expr)) & ")";
+ else
+ return Expr_Name (Expression (Expr));
+ end if;
+
when N_Indexed_Component =>
if Take_Prefix then
return
@@ -608,24 +629,27 @@ package body Pprint is
loop
case Nkind (Left) is
- when N_And_Then |
- N_Binary_Op |
- N_Membership_Test |
- N_Or_Else =>
+ when N_And_Then
+ | N_Binary_Op
+ | N_Membership_Test
+ | N_Or_Else
+ =>
Left := Original_Node (Left_Opnd (Left));
- when N_Attribute_Reference |
- N_Expanded_Name |
- N_Explicit_Dereference |
- N_Indexed_Component |
- N_Reference |
- N_Selected_Component |
- N_Slice =>
+ when N_Attribute_Reference
+ | N_Expanded_Name
+ | N_Explicit_Dereference
+ | N_Indexed_Component
+ | N_Reference
+ | N_Selected_Component
+ | N_Slice
+ =>
Left := Original_Node (Prefix (Left));
- when N_Defining_Program_Unit_Name |
- N_Designator |
- N_Function_Call =>
+ when N_Defining_Program_Unit_Name
+ | N_Designator
+ | N_Function_Call
+ =>
Left := Original_Node (Name (Left));
when N_Range =>
@@ -643,14 +667,16 @@ package body Pprint is
loop
case Nkind (Right) is
- when N_And_Then |
- N_Membership_Test |
- N_Op |
- N_Or_Else =>
+ when N_And_Then
+ | N_Membership_Test
+ | N_Op
+ | N_Or_Else
+ =>
Right := Original_Node (Right_Opnd (Right));
- when N_Expanded_Name |
- N_Selected_Component =>
+ when N_Expanded_Name
+ | N_Selected_Component
+ =>
Right := Original_Node (Selector_Name (Right));
when N_Designator =>
@@ -734,33 +760,38 @@ package body Pprint is
if Right /= Expr then
while Scn < End_Sloc loop
case Src (Scn) is
- when ' ' | ASCII.HT =>
- if not Skipping_Comment and then not Underscore then
- Underscore := True;
- Index := Index + 1;
- Buffer (Index) := ' ';
- end if;
+ when ' '
+ | ASCII.HT
+ =>
+ if not Skipping_Comment and then not Underscore then
+ Underscore := True;
+ Index := Index + 1;
+ Buffer (Index) := ' ';
+ end if;
- -- CR/LF/FF is the end of any comment
+ -- CR/LF/FF is the end of any comment
- when ASCII.LF | ASCII.CR | ASCII.FF =>
- Skipping_Comment := False;
+ when ASCII.CR
+ | ASCII.FF
+ | ASCII.LF
+ =>
+ Skipping_Comment := False;
- when others =>
- Underscore := False;
+ when others =>
+ Underscore := False;
- if not Skipping_Comment then
+ if not Skipping_Comment then
- -- Ignore comment
+ -- Ignore comment
- if Src (Scn) = '-' and then Src (Scn + 1) = '-' then
- Skipping_Comment := True;
+ if Src (Scn) = '-' and then Src (Scn + 1) = '-' then
+ Skipping_Comment := True;
- else
- Index := Index + 1;
- Buffer (Index) := Src (Scn);
+ else
+ Index := Index + 1;
+ Buffer (Index) := Src (Scn);
+ end if;
end if;
- end if;
end case;
Scn := Scn + 1;
diff --git a/gcc/ada/prep.adb b/gcc/ada/prep.adb
index d5672bafb9..02256ec66c 100644
--- a/gcc/ada/prep.adb
+++ b/gcc/ada/prep.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -211,8 +211,14 @@ package body Prep is
begin
if New_Name /= No_Name then
case Token is
- when Tok_If | Tok_Else | Tok_Elsif | Tok_End |
- Tok_And | Tok_Or | Tok_Then =>
+ when Tok_And
+ | Tok_Else
+ | Tok_Elsif
+ | Tok_End
+ | Tok_If
+ | Tok_Or
+ | Tok_Then
+ =>
if All_Keywords then
Token := Tok_Identifier;
Token_Name := New_Name;
@@ -458,12 +464,11 @@ package body Prep is
-- Handle relational operator
- elsif
- Token = Tok_Equal or else
- Token = Tok_Less or else
- Token = Tok_Less_Equal or else
- Token = Tok_Greater or else
- Token = Tok_Greater_Equal
+ elsif Token = Tok_Equal
+ or else Token = Tok_Less
+ or else Token = Tok_Less_Equal
+ or else Token = Tok_Greater
+ or else Token = Tok_Greater_Equal
then
Relop := Token;
Scan.all;
@@ -1562,14 +1567,12 @@ package body Prep is
-- so we have to deduct Start_Of_Processing from the token pointer.
if Token = Tok_End_Of_Line then
- if (Sinput.Source (Token_Ptr) = ASCII.CR
- and then Sinput.Source (Token_Ptr + 1) = ASCII.LF)
- or else
- (Sinput.Source (Token_Ptr) = ASCII.CR
- and then Sinput.Source (Token_Ptr + 1) = ASCII.LF)
+ if Sinput.Source (Token_Ptr) = ASCII.CR
+ and then Sinput.Source (Token_Ptr + 1) = ASCII.LF
then
Start_Of_Processing := Token_Ptr + 2;
else
+ pragma Assert (Sinput.Source (Token_Ptr) = ASCII.LF);
Start_Of_Processing := Token_Ptr + 1;
end if;
end if;
diff --git a/gcc/ada/prepcomp.adb b/gcc/ada/prepcomp.adb
index 549d7f87ba..cffb0cef99 100644
--- a/gcc/ada/prepcomp.adb
+++ b/gcc/ada/prepcomp.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2003-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2003-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/prj-dect.adb b/gcc/ada/prj-dect.adb
index 204e577c82..9c9472cc61 100644
--- a/gcc/ada/prj-dect.adb
+++ b/gcc/ada/prj-dect.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -245,7 +245,9 @@ package body Prj.Dect is
begin
case Qualif is
- when Aggregate | Aggregate_Library =>
+ when Aggregate
+ | Aggregate_Library
+ =>
if Name = Snames.Name_Languages
or else Name = Snames.Name_Source_Files
or else Name = Snames.Name_Source_List_File
@@ -449,38 +451,39 @@ package body Prj.Dect is
if Token = Tok_At then
case Attribute_Kind_Of (Current_Attribute) is
- when Optional_Index_Associative_Array |
- Optional_Index_Case_Insensitive_Associative_Array =>
- Scan (In_Tree);
- Expect (Tok_Integer_Literal, "integer literal");
-
- if Token = Tok_Integer_Literal then
-
- -- Set the source index value from given literal
-
- declare
- Index : constant Int :=
- UI_To_Int (Int_Literal_Value);
- begin
- if Index = 0 then
- Error_Msg
- (Flags, "index cannot be zero", Token_Ptr);
- else
- Set_Source_Index_Of
- (Attribute, In_Tree, To => Index);
- end if;
- end;
-
+ when Optional_Index_Associative_Array
+ | Optional_Index_Case_Insensitive_Associative_Array
+ =>
Scan (In_Tree);
- end if;
+ Expect (Tok_Integer_Literal, "integer literal");
+
+ if Token = Tok_Integer_Literal then
+
+ -- Set the source index value from given literal
+
+ declare
+ Index : constant Int :=
+ UI_To_Int (Int_Literal_Value);
+ begin
+ if Index = 0 then
+ Error_Msg
+ (Flags, "index cannot be zero", Token_Ptr);
+ else
+ Set_Source_Index_Of
+ (Attribute, In_Tree, To => Index);
+ end if;
+ end;
- when others =>
- Error_Msg (Flags, "index not allowed here", Token_Ptr);
- Scan (In_Tree);
+ Scan (In_Tree);
+ end if;
- if Token = Tok_Integer_Literal then
+ when others =>
+ Error_Msg (Flags, "index not allowed here", Token_Ptr);
Scan (In_Tree);
- end if;
+
+ if Token = Tok_Integer_Literal then
+ Scan (In_Tree);
+ end if;
end case;
end if;
end if;
@@ -1022,7 +1025,7 @@ package body Prj.Dect is
while Present (The_Variable)
and then Name_Of (The_Variable, In_Tree) /=
- Token_Name
+ Token_Name
loop
The_Variable := Next_Variable (The_Variable, In_Tree);
end loop;
@@ -1032,10 +1035,8 @@ package body Prj.Dect is
if No (The_Variable) then
Error_Msg
- (Flags,
- "a variable cannot be declared " &
- "for the first time here",
- Token_Ptr);
+ (Flags, "a variable cannot be declared for the "
+ & "first time here", Token_Ptr);
end if;
end;
end if;
@@ -1051,7 +1052,6 @@ package body Prj.Dect is
Set_Previous_Line_Node (Current_Declaration);
when Tok_For =>
-
Parse_Attribute_Declaration
(In_Tree => In_Tree,
Attribute => Current_Declaration,
@@ -1065,7 +1065,6 @@ package body Prj.Dect is
Set_Previous_Line_Node (Current_Declaration);
when Tok_Null =>
-
Scan (In_Tree); -- past "null"
when Tok_Package =>
diff --git a/gcc/ada/prj-env.adb b/gcc/ada/prj-env.adb
index 92019fcda9..18741be791 100644
--- a/gcc/ada/prj-env.adb
+++ b/gcc/ada/prj-env.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -887,7 +887,10 @@ package body Prj.Env is
when Spec =>
Suffix :=
Source.Language.Config.Mapping_Spec_Suffix;
- when Impl | Sep =>
+
+ when Impl
+ | Sep
+ =>
Suffix :=
Source.Language.Config.Mapping_Body_Suffix;
end case;
diff --git a/gcc/ada/prj-ext.adb b/gcc/ada/prj-ext.adb
index 5f134008b1..127438d8a2 100644
--- a/gcc/ada/prj-ext.adb
+++ b/gcc/ada/prj-ext.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -116,7 +116,7 @@ package body Prj.Ext is
then
if not Silent then
Debug_Output
- ("Not overridding existing external reference '"
+ ("Not overriding existing external reference '"
& External_Name & "', value was defined in "
& N.Source'Img);
end if;
diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb
index 6c9db46033..a224e7d038 100644
--- a/gcc/ada/prj-nmsc.adb
+++ b/gcc/ada/prj-nmsc.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1501,9 +1501,9 @@ package body Prj.Nmsc is
Lang_Index.Config.Compiler_Driver :=
File_Name_Type (Element.Value.Value);
- when Name_Required_Switches
- | Name_Leading_Required_Switches
- =>
+ when Name_Leading_Required_Switches
+ | Name_Required_Switches
+ =>
Put (Into_List =>
Lang_Index.Config.
Compiler_Leading_Required_Switches,
@@ -1808,8 +1808,9 @@ package body Prj.Nmsc is
and then Element.Value.Value /= No_Name
then
case Current_Array.Name is
- when Name_Spec_Suffix | Name_Specification_Suffix =>
-
+ when Name_Spec_Suffix
+ | Name_Specification_Suffix
+ =>
-- Attribute Spec_Suffix (<language>)
Get_Name_String (Element.Value.Value);
@@ -1818,8 +1819,9 @@ package body Prj.Nmsc is
Lang_Index.Config.Naming_Data.Spec_Suffix :=
Name_Find;
- when Name_Implementation_Suffix | Name_Body_Suffix =>
-
+ when Name_Body_Suffix
+ | Name_Implementation_Suffix
+ =>
Get_Name_String (Element.Value.Value);
Canonical_Case_File_Name
(Name_Buffer (1 .. Name_Len));
@@ -2513,6 +2515,7 @@ package body Prj.Nmsc is
& """ for Objects_Linked",
Element.Value.Location, Project);
end;
+
when others =>
null;
end case;
@@ -3448,7 +3451,9 @@ package body Prj.Nmsc is
Lib_Name.Location, Project);
end if;
- when Library | Aggregate_Library =>
+ when Aggregate_Library
+ | Library
+ =>
if not Project.Library then
if Project.Library_Name = No_Name then
Error_Msg
@@ -4043,7 +4048,9 @@ package body Prj.Nmsc is
begin
case Kind is
- when Impl | Sep =>
+ when Impl
+ | Sep
+ =>
Exceptions :=
Value_Of
(Name_Implementation_Exceptions,
@@ -4139,7 +4146,9 @@ package body Prj.Nmsc is
begin
case Kind is
- when Impl | Sep =>
+ when Impl
+ | Sep
+ =>
Exceptions :=
Value_Of
(Name_Body,
@@ -4403,11 +4412,11 @@ package body Prj.Nmsc is
Lang_Id := Project.Languages;
while Lang_Id /= No_Language_Index loop
case Lang_Id.Config.Kind is
- when File_Based =>
- Process_Exceptions_File_Based (Lang_Id, Kind);
+ when File_Based =>
+ Process_Exceptions_File_Based (Lang_Id, Kind);
- when Unit_Based =>
- Process_Exceptions_Unit_Based (Lang_Id, Kind);
+ when Unit_Based =>
+ Process_Exceptions_Unit_Based (Lang_Id, Kind);
end case;
Lang_Id := Lang_Id.Next;
@@ -4452,7 +4461,7 @@ package body Prj.Nmsc is
-- An extending project inherits its parent projects' languages
-- so if needed we should create entries for those languages
- if Lang = null then
+ if Lang = null then
Extended := Project.Extends;
while Extended /= null loop
Lang := Get_Language_From_Name
@@ -6001,7 +6010,9 @@ package body Prj.Nmsc is
end if;
end loop;
- when Mixed_Case | Unknown =>
+ when Mixed_Case
+ | Unknown
+ =>
null;
end case;
end if;
@@ -8412,11 +8423,13 @@ package body Prj.Nmsc is
when Silent =>
null;
- when Warning | Error =>
+ when Error
+ | Warning
+ =>
declare
Msg : constant String :=
- "<there are no "
- & Lang_Name & " sources in this project";
+ "<there are no " & Lang_Name
+ & " sources in this project";
begin
Error_Msg_Warn := Data.Flags.When_No_Sources = Warning;
diff --git a/gcc/ada/prj-pp.adb b/gcc/ada/prj-pp.adb
index 2b05eaadef..6da5ae2325 100644
--- a/gcc/ada/prj-pp.adb
+++ b/gcc/ada/prj-pp.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -393,16 +393,21 @@ package body Prj.PP is
Start_Line (Indent);
case Project_Qualifier_Of (Node, In_Tree) is
- when Unspecified | Standard =>
+ when Standard
+ | Unspecified
+ =>
null;
- when Aggregate =>
+ when Aggregate =>
Write_String ("aggregate ", Indent);
+
when Aggregate_Library =>
Write_String ("aggregate library ", Indent);
- when Library =>
+ when Library =>
Write_String ("library ", Indent);
+
when Configuration =>
Write_String ("configuration ", Indent);
+
when Abstract_Project =>
Write_String ("abstract ", Indent);
end case;
diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb
index 3a014f1f6b..ff68ce79b6 100644
--- a/gcc/ada/prj-proc.adb
+++ b/gcc/ada/prj-proc.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -547,7 +547,6 @@ package body Prj.Proc is
Kind_Of (The_Current_Term, From_Project_Node_Tree);
case Current_Term_Kind is
-
when N_Literal_String =>
case Kind is
when Undefined =>
@@ -566,7 +565,6 @@ package body Prj.Proc is
(The_Current_Term, From_Project_Node_Tree);
when List =>
-
String_Element_Table.Increment_Last
(Shared.String_Elements);
@@ -695,7 +693,9 @@ package body Prj.Proc is
end if;
end;
- when N_Variable_Reference | N_Attribute_Reference =>
+ when N_Attribute_Reference
+ | N_Variable_Reference
+ =>
declare
The_Project : Project_Id := Project;
The_Package : Package_Id := Pkg;
@@ -981,16 +981,17 @@ package body Prj.Proc is
when Read_Only_Value =>
null;
- when Empty_Value =>
+ when Empty_Value =>
The_Variable.Values := Nil_String;
- when Dot_Value =>
+ when Dot_Value =>
The_Variable.Values :=
Shared.Dot_String_List;
- when Object_Dir_Value |
- Target_Value |
- Runtime_Value =>
+ when Object_Dir_Value
+ | Runtime_Value
+ | Target_Value
+ =>
null;
end case;
end case;
@@ -1008,7 +1009,6 @@ package body Prj.Proc is
when Single =>
case The_Variable.Kind is
-
when Undefined =>
null;
@@ -1028,7 +1028,6 @@ package body Prj.Proc is
when List =>
case The_Variable.Kind is
-
when Undefined =>
null;
@@ -1066,7 +1065,6 @@ package body Prj.Proc is
Index => 0);
when List =>
-
declare
The_List : String_List_Id :=
The_Variable.Values;
@@ -1283,7 +1281,6 @@ package body Prj.Proc is
end if;
case Kind is
-
when Undefined =>
null;
@@ -1365,7 +1362,6 @@ package body Prj.Proc is
(False,
"illegal node kind in an expression");
raise Program_Error;
-
end case;
end if;
@@ -2465,9 +2461,10 @@ package body Prj.Proc is
when N_String_Type_Declaration =>
null;
- when N_Attribute_Declaration |
- N_Typed_Variable_Declaration |
- N_Variable_Declaration =>
+ when N_Attribute_Declaration
+ | N_Typed_Variable_Declaration
+ | N_Variable_Declaration
+ =>
Process_Attribute_Declaration (Current);
when N_Case_Construction =>
diff --git a/gcc/ada/prj-strt.adb b/gcc/ada/prj-strt.adb
index 8956e97a14..eb7aaa3f4d 100644
--- a/gcc/ada/prj-strt.adb
+++ b/gcc/ada/prj-strt.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1556,7 +1556,9 @@ package body Prj.Strt is
end if;
end if;
- when Tok_External | Tok_External_As_List =>
+ when Tok_External
+ | Tok_External_As_List
+ =>
External_Reference
(In_Tree => In_Tree,
Flags => Flags,
diff --git a/gcc/ada/prj-tree.adb b/gcc/ada/prj-tree.adb
index 75def1c06e..ea852d110c 100644
--- a/gcc/ada/prj-tree.adb
+++ b/gcc/ada/prj-tree.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1743,8 +1743,8 @@ package body Prj.Tree is
-- comment zone with the node of the preceding line (either
-- a Previous_Line or a Previous_End node), if any.
- if Comments.Last > 0 and then
- not Comments.Table (1).Follows_Empty_Line
+ if Comments.Last > 0
+ and then not Comments.Table (1).Follows_Empty_Line
then
if Present (Previous_Line_Node) then
Add_Comments
diff --git a/gcc/ada/prj-tree.ads b/gcc/ada/prj-tree.ads
index a36e9f919d..f2290bb20a 100644
--- a/gcc/ada/prj-tree.ads
+++ b/gcc/ada/prj-tree.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb
index ac5b445cda..e14f63e7fe 100644
--- a/gcc/ada/prj.adb
+++ b/gcc/ada/prj.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -190,7 +190,7 @@ package body Prj is
pragma Warnings (Off, Dont_Care);
begin
- if not Opt.Keep_Temporary_Files then
+ if not Opt.Keep_Temporary_Files then
if Current_Verbosity = High then
Write_Line ("Removing temp file: " & Get_Name_String (Path));
end if;
@@ -306,7 +306,9 @@ package body Prj is
when Makefile =>
return Extend_Name (Source_File_Name, Makefile_Dependency_Suffix);
- when ALI_File | ALI_Closure =>
+ when ALI_Closure
+ | ALI_File
+ =>
return Extend_Name (Source_File_Name, ALI_Dependency_Suffix);
end case;
end Dependency_Name;
@@ -1250,7 +1252,9 @@ package body Prj is
Free_List (Project.Languages);
case Project.Qualifier is
- when Aggregate | Aggregate_Library =>
+ when Aggregate
+ | Aggregate_Library
+ =>
Free (Project.Aggregated_Projects);
when others =>
@@ -1899,12 +1903,9 @@ package body Prj is
begin
if Source.Unit /= No_Unit_Index then
case Source.Kind is
- when Impl =>
- return Source.Unit.File_Names (Spec);
- when Spec =>
- return Source.Unit.File_Names (Impl);
- when Sep =>
- return No_Source;
+ when Impl => return Source.Unit.File_Names (Spec);
+ when Spec => return Source.Unit.File_Names (Impl);
+ when Sep => return No_Source;
end case;
else
return No_Source;
diff --git a/gcc/ada/prj.ads b/gcc/ada/prj.ads
index 2b20f6ad10..8920890dcf 100644
--- a/gcc/ada/prj.ads
+++ b/gcc/ada/prj.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2001-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/put_spark_xrefs.adb b/gcc/ada/put_spark_xrefs.adb
index f200e21327..a65fa8a929 100644
--- a/gcc/ada/put_spark_xrefs.adb
+++ b/gcc/ada/put_spark_xrefs.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -31,47 +31,30 @@ begin
for J in 1 .. SPARK_File_Table.Last loop
declare
- F : SPARK_File_Record renames SPARK_File_Table.Table (J);
- Start : Scope_Index;
- Stop : Scope_Index;
+ F : SPARK_File_Record renames SPARK_File_Table.Table (J);
begin
- Start := F.From_Scope;
- Stop := F.To_Scope;
-
Write_Info_Initiate ('F');
Write_Info_Char ('D');
Write_Info_Char (' ');
Write_Info_Nat (F.File_Num);
Write_Info_Char (' ');
- for N in F.File_Name'Range loop
- Write_Info_Char (F.File_Name (N));
- end loop;
+ Write_Info_Str (F.File_Name.all);
-- If file is a subunit, print the file name for the unit
if F.Unit_File_Name /= null then
- Write_Info_Char (' ');
- Write_Info_Char ('-');
- Write_Info_Char ('>');
- Write_Info_Char (' ');
-
- for N in F.Unit_File_Name'Range loop
- Write_Info_Char (F.Unit_File_Name (N));
- end loop;
+ Write_Info_Str (" -> " & F.Unit_File_Name.all);
end if;
Write_Info_Terminate;
-- Loop through scope entries for this file
- loop
- exit when Start = Stop + 1;
- pragma Assert (Start <= Stop);
-
+ for J in F.From_Scope .. F.To_Scope loop
declare
- S : SPARK_Scope_Record renames SPARK_Scope_Table.Table (Start);
+ S : SPARK_Scope_Record renames SPARK_Scope_Table.Table (J);
begin
Write_Info_Initiate ('F');
@@ -87,15 +70,10 @@ begin
pragma Assert (S.Scope_Name.all /= "");
- for N in S.Scope_Name'Range loop
- Write_Info_Char (S.Scope_Name (N));
- end loop;
+ Write_Info_Str (S.Scope_Name.all);
if S.Spec_File_Num /= 0 then
- Write_Info_Char (' ');
- Write_Info_Char ('-');
- Write_Info_Char ('>');
- Write_Info_Char (' ');
+ Write_Info_Str (" -> ");
Write_Info_Nat (S.Spec_File_Num);
Write_Info_Char ('.');
Write_Info_Nat (S.Spec_Scope_Num);
@@ -103,8 +81,6 @@ begin
Write_Info_Terminate;
end;
-
- Start := Start + 1;
end loop;
end;
end loop;
@@ -114,129 +90,104 @@ begin
for J in 1 .. SPARK_File_Table.Last loop
declare
F : SPARK_File_Record renames SPARK_File_Table.Table (J);
- Start : Scope_Index;
- Stop : Scope_Index;
File : Nat;
Scope : Nat;
Entity_Line : Nat;
Entity_Col : Nat;
begin
- Start := F.From_Scope;
- Stop := F.To_Scope;
-
-- Loop through scope entries for this file
- loop
- exit when Start = Stop + 1;
- pragma Assert (Start <= Stop);
-
+ for K in F.From_Scope .. F.To_Scope loop
Output_One_Scope : declare
- S : SPARK_Scope_Record renames SPARK_Scope_Table.Table (Start);
-
- XStart : Xref_Index;
- XStop : Xref_Index;
+ S : SPARK_Scope_Record renames SPARK_Scope_Table.Table (K);
begin
- XStart := S.From_Xref;
- XStop := S.To_Xref;
+ -- Write only non-empty tables
- if XStart > XStop then
- goto Continue;
- end if;
+ if S.From_Xref <= S.To_Xref then
- Write_Info_Initiate ('F');
- Write_Info_Char ('X');
- Write_Info_Char (' ');
- Write_Info_Nat (F.File_Num);
- Write_Info_Char (' ');
+ Write_Info_Initiate ('F');
+ Write_Info_Char ('X');
+ Write_Info_Char (' ');
+ Write_Info_Nat (F.File_Num);
+ Write_Info_Char (' ');
- for N in F.File_Name'Range loop
- Write_Info_Char (F.File_Name (N));
- end loop;
+ Write_Info_Str (F.File_Name.all);
- Write_Info_Char (' ');
- Write_Info_Char ('.');
- Write_Info_Nat (S.Scope_Num);
- Write_Info_Char (' ');
+ Write_Info_Char (' ');
+ Write_Info_Char ('.');
+ Write_Info_Nat (S.Scope_Num);
+ Write_Info_Char (' ');
- for N in S.Scope_Name'Range loop
- Write_Info_Char (S.Scope_Name (N));
- end loop;
+ Write_Info_Str (S.Scope_Name.all);
- -- Default value of (0,0) is used for the special __HEAP
- -- variable so use another default value.
+ -- Default value of (0,0) is used for the special __HEAP
+ -- variable so use another default value.
- Entity_Line := 0;
- Entity_Col := 1;
+ Entity_Line := 0;
+ Entity_Col := 1;
- -- Loop through cross reference entries for this scope
+ -- Loop through cross reference entries for this scope
- loop
- exit when XStart = XStop + 1;
- pragma Assert (XStart <= XStop);
+ for X in S.From_Xref .. S.To_Xref loop
- Output_One_Xref : declare
- R : SPARK_Xref_Record renames
- SPARK_Xref_Table.Table (XStart);
+ Output_One_Xref : declare
+ R : SPARK_Xref_Record renames
+ SPARK_Xref_Table.Table (X);
- begin
- if R.Entity_Line /= Entity_Line
- or else R.Entity_Col /= Entity_Col
- then
- Write_Info_Terminate;
+ begin
+ if R.Entity_Line /= Entity_Line
+ or else R.Entity_Col /= Entity_Col
+ then
+ Write_Info_Terminate;
+
+ Write_Info_Initiate ('F');
+ Write_Info_Char (' ');
+ Write_Info_Nat (R.Entity_Line);
+ Write_Info_Char (R.Etype);
+ Write_Info_Nat (R.Entity_Col);
+ Write_Info_Char (' ');
+
+ Write_Info_Str (R.Entity_Name.all);
+
+ Entity_Line := R.Entity_Line;
+ Entity_Col := R.Entity_Col;
+ File := F.File_Num;
+ Scope := S.Scope_Num;
+ end if;
+
+ if Write_Info_Col > 72 then
+ Write_Info_Terminate;
+ Write_Info_Initiate ('.');
+ end if;
- Write_Info_Initiate ('F');
- Write_Info_Char (' ');
- Write_Info_Nat (R.Entity_Line);
- Write_Info_Char (R.Etype);
- Write_Info_Nat (R.Entity_Col);
Write_Info_Char (' ');
- for N in R.Entity_Name'Range loop
- Write_Info_Char (R.Entity_Name (N));
- end loop;
-
- Entity_Line := R.Entity_Line;
- Entity_Col := R.Entity_Col;
- File := F.File_Num;
- Scope := S.Scope_Num;
- end if;
-
- if Write_Info_Col > 72 then
- Write_Info_Terminate;
- Write_Info_Initiate ('.');
- end if;
-
- Write_Info_Char (' ');
-
- if R.File_Num /= File then
- Write_Info_Nat (R.File_Num);
- Write_Info_Char ('|');
- File := R.File_Num;
- Scope := 0;
- end if;
-
- if R.Scope_Num /= Scope then
- Write_Info_Char ('.');
- Write_Info_Nat (R.Scope_Num);
- Write_Info_Char (':');
- Scope := R.Scope_Num;
- end if;
-
- Write_Info_Nat (R.Line);
- Write_Info_Char (R.Rtype);
- Write_Info_Nat (R.Col);
- end Output_One_Xref;
-
- XStart := XStart + 1;
- end loop;
+ if R.File_Num /= File then
+ Write_Info_Nat (R.File_Num);
+ Write_Info_Char ('|');
+ File := R.File_Num;
+ Scope := 0;
+ end if;
- Write_Info_Terminate;
- end Output_One_Scope;
+ if R.Scope_Num /= Scope then
+ Write_Info_Char ('.');
+ Write_Info_Nat (R.Scope_Num);
+ Write_Info_Char (':');
+ Scope := R.Scope_Num;
+ end if;
- <<Continue>>
- Start := Start + 1;
+ Write_Info_Nat (R.Line);
+ Write_Info_Char (R.Rtype);
+ Write_Info_Nat (R.Col);
+ end Output_One_Xref;
+
+ end loop;
+
+ Write_Info_Terminate;
+ end if;
+ end Output_One_Scope;
end loop;
end;
end loop;
diff --git a/gcc/ada/put_spark_xrefs.ads b/gcc/ada/put_spark_xrefs.ads
index fa0b81c068..fa4a4bc04e 100644
--- a/gcc/ada/put_spark_xrefs.ads
+++ b/gcc/ada/put_spark_xrefs.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -43,6 +43,9 @@ generic
with procedure Write_Info_Char (C : Character) is <>;
-- Output one character
+ with procedure Write_Info_Str (Val : String) is <>;
+ -- Output string stored in string pointer
+
with procedure Write_Info_Initiate (Key : Character) is <>;
-- Initiate write of new line to output file, the parameter is the
-- keyword character for the line.
diff --git a/gcc/ada/raise-gcc.c b/gcc/ada/raise-gcc.c
index 4a10fbff0d..0074ad53fb 100644
--- a/gcc/ada/raise-gcc.c
+++ b/gcc/ada/raise-gcc.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2014, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2016, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -36,8 +36,13 @@
#error "RTS unit only"
#endif
+#ifndef CERT
#include "tconfig.h"
#include "tsystem.h"
+#else
+#define ATTRIBUTE_UNUSED __attribute__((unused))
+#define HAVE_GETIPINFO 1
+#endif
#include <stdarg.h>
typedef char bool;
@@ -80,6 +85,12 @@ extern struct Exception_Occurrence *__gnat_setup_current_excep
(_Unwind_Exception *);
extern void __gnat_unhandled_except_handler (_Unwind_Exception *);
+#ifdef CERT
+/* Called in case of error during propagation. */
+extern void __gnat_raise_abort (void) __attribute__ ((noreturn));
+#define abort() __gnat_raise_abort()
+#endif
+
#include "unwind-pe.h"
/* The known and handled exception classes. */
@@ -928,9 +939,13 @@ is_handled_by (_Unwind_Ptr choice, _GNAT_Exception *propagated_exception)
/* All others and others choice match any foreign exception. */
if (choice == GNAT_ALL_OTHERS
|| choice == GNAT_OTHERS
- || choice == (_Unwind_Ptr) &Foreign_Exception)
+#ifndef CERT
+ || choice == (_Unwind_Ptr) &Foreign_Exception
+#endif
+ )
return handler;
+#ifndef CERT
/* C++ exception occurrences. */
if (exception_class_eq (propagated_exception, CXX_EXCEPTION_CLASS)
&& Language_For (choice) == 'C')
@@ -947,6 +962,7 @@ is_handled_by (_Unwind_Ptr choice, _GNAT_Exception *propagated_exception)
if (choice_typeinfo == except_typeinfo)
return handler;
}
+#endif
return nothing;
}
@@ -1172,6 +1188,7 @@ personality_body (_Unwind_Action uw_phases,
}
else
{
+#ifndef CERT
struct Exception_Occurrence *excep;
/* Trigger the appropriate notification routines before the second
@@ -1182,6 +1199,7 @@ personality_body (_Unwind_Action uw_phases,
__gnat_notify_unhandled_exception (excep);
else
__gnat_notify_handled_exception (excep);
+#endif
return _URC_HANDLER_FOUND;
}
@@ -1195,10 +1213,12 @@ personality_body (_Unwind_Action uw_phases,
setup_to_install
(uw_context, uw_exception, action.landing_pad, action.ttype_filter);
+#ifndef CERT
/* Write current exception, so that it can be retrieved from Ada. It was
already done during phase 1 (just above), but in between, one or several
exceptions may have been raised (in cleanup handlers). */
__gnat_setup_current_excep (uw_exception);
+#endif
return _URC_INSTALL_CONTEXT;
}
@@ -1338,6 +1358,7 @@ PERSONALITY_FUNCTION (_Unwind_State state,
/* Callback routine called by Unwind_ForcedUnwind to execute all the cleanup
before exiting the task. */
+#ifndef CERT
_Unwind_Reason_Code
__gnat_cleanupunwind_handler (int version ATTRIBUTE_UNUSED,
_Unwind_Action phases,
@@ -1362,6 +1383,7 @@ __gnat_cleanupunwind_handler (int version ATTRIBUTE_UNUSED,
and this hook will gain control again. */
return _URC_NO_REASON;
}
+#endif
/* Define the consistently named wrappers imported by Propagate_Exception. */
diff --git a/gcc/ada/raise.c b/gcc/ada/raise.c
index a0c0121677..a61723d10e 100644
--- a/gcc/ada/raise.c
+++ b/gcc/ada/raise.c
@@ -50,7 +50,7 @@ extern "C" {
/* Wrapper to builtin_longjmp. This is for the compiler eh only, as the sjlj
runtime library interfaces directly to the intrinsic. We can't yet do
this for the compiler itself, because this capability relies on changes
- made in april 2008 and we need to preserve the possibility to bootstrap
+ made in April 2008 and we need to preserve the possibility to bootstrap
with an older base version. */
#if defined (IN_GCC) && !defined (IN_RTS)
diff --git a/gcc/ada/repinfo.adb b/gcc/ada/repinfo.adb
index 51b8b67d98..90bb6dacc2 100644
--- a/gcc/ada/repinfo.adb
+++ b/gcc/ada/repinfo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -58,8 +58,6 @@ package body Repinfo is
-- this introduces problematic dependencies in ASIS, and in any case this
-- value is assumed to be 8 for the implementation of the DDA.
- -- This is wrong for AAMP???
-
---------------------------------------
-- Representation of gcc Expressions --
---------------------------------------
@@ -137,10 +135,15 @@ package body Repinfo is
-- Called before outputting anything for an entity. Ensures that
-- a blank line precedes the output for a particular entity.
- procedure List_Entities (Ent : Entity_Id; Bytes_Big_Endian : Boolean);
+ procedure List_Entities
+ (Ent : Entity_Id;
+ Bytes_Big_Endian : Boolean;
+ In_Subprogram : Boolean := False);
-- This procedure lists the entities associated with the entity E, starting
-- with the First_Entity and using the Next_Entity link. If a nested
-- package is found, entities within the package are recursively processed.
+ -- When recursing within a subprogram body, Is_Subprogram suppresses
+ -- duplicate information about signature.
procedure List_Name (Ent : Entity_Id);
-- List name of entity Ent in appropriate case. The name is listed with
@@ -316,7 +319,11 @@ package body Repinfo is
-- List_Entities --
-------------------
- procedure List_Entities (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is
+ procedure List_Entities
+ (Ent : Entity_Id;
+ Bytes_Big_Endian : Boolean;
+ In_Subprogram : Boolean := False)
+ is
Body_E : Entity_Id;
E : Entity_Id;
@@ -355,12 +362,15 @@ package body Repinfo is
and then Nkind (Declaration_Node (Ent)) not in N_Renaming_Declaration
then
-- If entity is a subprogram and we are listing mechanisms,
- -- then we need to list mechanisms for this entity.
+ -- then we need to list mechanisms for this entity. We skip this
+ -- if it is a nested subprogram, as the information has already
+ -- been produced when listing the enclosing scope.
if List_Representation_Info_Mechanisms
and then (Is_Subprogram (Ent)
or else Ekind (Ent) = E_Entry
or else Ekind (Ent) = E_Entry_Family)
+ and then not In_Subprogram
then
Need_Blank_Line := True;
List_Mechanisms (Ent);
@@ -388,6 +398,13 @@ package body Repinfo is
List_Mechanisms (E);
end if;
+ -- Recurse into entities local to subprogram
+
+ List_Entities (E, Bytes_Big_Endian, True);
+
+ elsif Ekind (E) in Formal_Kind and then In_Subprogram then
+ null;
+
elsif Ekind_In (E, E_Entry,
E_Entry_Family,
E_Subprogram_Type)
@@ -626,7 +643,6 @@ package body Repinfo is
when Discrim_Val =>
Write_Char ('#');
UI_Write (Node.Op1);
-
end case;
end;
end if;
@@ -694,7 +710,9 @@ package body Repinfo is
when E_Subprogram_Type =>
Write_Str ("type ");
- when E_Entry | E_Entry_Family =>
+ when E_Entry
+ | E_Entry_Family
+ =>
Write_Str ("entry ");
when others =>
@@ -710,31 +728,43 @@ package body Repinfo is
Write_Str (" convention : ");
case Convention (Ent) is
- when Convention_Ada =>
+ when Convention_Ada =>
Write_Line ("Ada");
- when Convention_Ada_Pass_By_Copy =>
+
+ when Convention_Ada_Pass_By_Copy =>
Write_Line ("Ada_Pass_By_Copy");
+
when Convention_Ada_Pass_By_Reference =>
Write_Line ("Ada_Pass_By_Reference");
- when Convention_Intrinsic =>
+
+ when Convention_Intrinsic =>
Write_Line ("Intrinsic");
- when Convention_Entry =>
+
+ when Convention_Entry =>
Write_Line ("Entry");
- when Convention_Protected =>
+
+ when Convention_Protected =>
Write_Line ("Protected");
- when Convention_Assembler =>
+
+ when Convention_Assembler =>
Write_Line ("Assembler");
- when Convention_C =>
+
+ when Convention_C =>
Write_Line ("C");
- when Convention_COBOL =>
+
+ when Convention_COBOL =>
Write_Line ("COBOL");
- when Convention_CPP =>
+
+ when Convention_CPP =>
Write_Line ("C++");
- when Convention_Fortran =>
+
+ when Convention_Fortran =>
Write_Line ("Fortran");
- when Convention_Stdcall =>
+
+ when Convention_Stdcall =>
Write_Line ("Stdcall");
- when Convention_Stubbed =>
+
+ when Convention_Stubbed =>
Write_Line ("Stubbed");
end case;
@@ -1418,7 +1448,6 @@ package body Repinfo is
pragma Assert (Sub in D'Range);
return D (Sub);
end;
-
end case;
end;
end if;
diff --git a/gcc/ada/restrict.adb b/gcc/ada/restrict.adb
index aaaaf40bb0..a66fffb5ee 100644
--- a/gcc/ada/restrict.adb
+++ b/gcc/ada/restrict.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -195,6 +195,15 @@ package body Restrict is
Check_Restriction (No_Elaboration_Code, N);
end Check_Elaboration_Code_Allowed;
+ -----------------------------------------
+ -- Check_Implicit_Dynamic_Code_Allowed --
+ -----------------------------------------
+
+ procedure Check_Implicit_Dynamic_Code_Allowed (N : Node_Id) is
+ begin
+ Check_Restriction (No_Implicit_Dynamic_Code, N);
+ end Check_Implicit_Dynamic_Code_Allowed;
+
--------------------------------
-- Check_No_Implicit_Aliasing --
--------------------------------
@@ -267,15 +276,6 @@ package body Restrict is
Check_Restriction (No_Implicit_Aliasing, Obj);
end Check_No_Implicit_Aliasing;
- -----------------------------------------
- -- Check_Implicit_Dynamic_Code_Allowed --
- -----------------------------------------
-
- procedure Check_Implicit_Dynamic_Code_Allowed (N : Node_Id) is
- begin
- Check_Restriction (No_Implicit_Dynamic_Code, N);
- end Check_Implicit_Dynamic_Code_Allowed;
-
----------------------------------
-- Check_No_Implicit_Heap_Alloc --
----------------------------------
@@ -676,31 +676,44 @@ package body Restrict is
--------------------------------------------
procedure Check_Restriction_No_Use_Of_Attribute (N : Node_Id) is
- Id : constant Name_Id := Chars (N);
- A_Id : constant Attribute_Id := Get_Attribute_Id (Id);
+ Attr_Id : Attribute_Id;
+ Attr_Nam : Name_Id;
begin
- -- Ignore call if node N is not in the main source unit, since we only
- -- give messages for the main unit. This avoids giving messages for
- -- aspects that are specified in withed units.
+ -- Nothing to do if the attribute is not in the main source unit, since
+ -- we only give messages for the main unit. This avoids giving messages
+ -- for attributes that are specified in withed units.
if not In_Extended_Main_Source_Unit (N) then
return;
- end if;
- -- If nothing set, nothing to check
+ -- Nothing to do if not checking No_Use_Of_Attribute
+
+ elsif not No_Use_Of_Attribute_Set then
+ return;
+
+ -- Do not consider internally generated attributes because this leads to
+ -- bizarre errors.
- if not No_Use_Of_Attribute_Set then
+ elsif not Comes_From_Source (N) then
return;
end if;
- Error_Msg_Sloc := No_Use_Of_Attribute (A_Id);
+ if Nkind (N) = N_Attribute_Definition_Clause then
+ Attr_Nam := Chars (N);
+ else
+ pragma Assert (Nkind (N) = N_Attribute_Reference);
+ Attr_Nam := Attribute_Name (N);
+ end if;
+
+ Attr_Id := Get_Attribute_Id (Attr_Nam);
+ Error_Msg_Sloc := No_Use_Of_Attribute (Attr_Id);
if Error_Msg_Sloc /= No_Location then
- Error_Msg_Node_1 := N;
- Error_Msg_Warn := No_Use_Of_Attribute_Warning (A_Id);
+ Error_Msg_Name_1 := Attr_Nam;
+ Error_Msg_Warn := No_Use_Of_Attribute_Warning (Attr_Id);
Error_Msg_N
- ("<*<violation of restriction `No_Use_Of_Attribute '='> &`#", N);
+ ("<*<violation of restriction `No_Use_Of_Attribute '='> %` #", N);
end if;
end Check_Restriction_No_Use_Of_Attribute;
@@ -723,10 +736,10 @@ package body Restrict is
return;
end if;
- -- Restriction is only recognized within a configuration
- -- pragma file, or within a unit of the main extended
- -- program. Note: the test for Main_Unit is needed to
- -- properly include the case of configuration pragma files.
+ -- Restriction is only recognized within a configuration pragma file,
+ -- or within a unit of the main extended program. Note: the test for
+ -- Main_Unit is needed to properly include the case of configuration
+ -- pragma files.
if Current_Sem_Unit /= Main_Unit
and then not In_Extended_Main_Source_Unit (N)
@@ -746,9 +759,16 @@ package body Restrict is
Ent := Entity (N);
Expr := NE_Ent.Entity;
loop
- -- Here if at outer level of entity name in reference
-
- if Scope (Ent) = Standard_Standard then
+ -- Here if at outer level of entity name in reference (handle
+ -- also the direct use of Text_IO in the pragma). For example:
+ -- pragma Restrictions (No_Use_Of_Entity => Text_IO.Put);
+
+ if Scope (Ent) = Standard_Standard
+ or else (Nkind (Expr) = N_Identifier
+ and then Chars (Ent) = Name_Text_IO
+ and then Chars (Scope (Ent)) = Name_Ada
+ and then Scope (Scope (Ent)) = Standard_Standard)
+ then
if Nkind_In (Expr, N_Identifier, N_Operator_Symbol)
and then Chars (Ent) = Chars (Expr)
then
@@ -761,22 +781,19 @@ package body Restrict is
return;
else
- goto Continue;
+ exit;
end if;
-- Here if at outer level of entity name in table
elsif Nkind_In (Expr, N_Identifier, N_Operator_Symbol) then
- goto Continue;
+ exit;
-- Here if neither at the outer level
else
pragma Assert (Nkind (Expr) = N_Selected_Component);
-
- if Chars (Selector_Name (Expr)) /= Chars (Ent) then
- goto Continue;
- end if;
+ exit when Chars (Selector_Name (Expr)) /= Chars (Ent);
end if;
-- Move up a level
@@ -787,10 +804,6 @@ package body Restrict is
end loop;
Expr := Prefix (Expr);
-
- -- Entry did not match
-
- <<Continue>> null;
end loop;
end;
end loop;
@@ -805,30 +818,122 @@ package body Restrict is
P_Id : constant Pragma_Id := Get_Pragma_Id (Chars (Id));
begin
- -- Ignore call if node N is not in the main source unit, since we only
- -- give messages for the main unit. This avoids giving messages for
- -- aspects that are specified in withed units.
+ -- Nothing to do if the pragma is not in the main source unit, since we
+ -- only give messages for the main unit. This avoids giving messages for
+ -- pragmas that are specified in withed units.
if not In_Extended_Main_Source_Unit (N) then
return;
- end if;
- -- If nothing set, nothing to check
+ -- Nothing to do if not checking No_Use_Of_Pragma
+
+ elsif not No_Use_Of_Pragma_Set then
+ return;
+
+ -- Do not consider internally generated pragmas because this leads to
+ -- bizarre errors.
- if not No_Use_Of_Pragma_Set then
+ elsif not Comes_From_Source (N) then
return;
end if;
Error_Msg_Sloc := No_Use_Of_Pragma (P_Id);
if Error_Msg_Sloc /= No_Location then
- Error_Msg_Node_1 := Id;
Error_Msg_Warn := No_Use_Of_Pragma_Warning (P_Id);
Error_Msg_N
- ("<*<violation of restriction `No_Use_Of_Pragma '='> &`#", Id);
+ ("<*<violation of restriction `No_Use_Of_Pragma '='> &` #", Id);
end if;
end Check_Restriction_No_Use_Of_Pragma;
+ --------------------------------
+ -- Check_SPARK_05_Restriction --
+ --------------------------------
+
+ procedure Check_SPARK_05_Restriction
+ (Msg : String;
+ N : Node_Id;
+ Force : Boolean := False)
+ is
+ Msg_Issued : Boolean;
+ Save_Error_Msg_Sloc : Source_Ptr;
+ Onode : constant Node_Id := Original_Node (N);
+
+ begin
+ -- Output message if Force set
+
+ if Force
+
+ -- Or if this node comes from source
+
+ or else Comes_From_Source (N)
+
+ -- Or if this is a range node which rewrites a range attribute and
+ -- the range attribute comes from source.
+
+ or else (Nkind (N) = N_Range
+ and then Nkind (Onode) = N_Attribute_Reference
+ and then Attribute_Name (Onode) = Name_Range
+ and then Comes_From_Source (Onode))
+
+ -- Or this is an expression that does not come from source, which is
+ -- a rewriting of an expression that does come from source.
+
+ or else (Nkind (N) in N_Subexpr and then Comes_From_Source (Onode))
+ then
+ if Restriction_Check_Required (SPARK_05)
+ and then Is_In_Hidden_Part_In_SPARK (Sloc (N))
+ then
+ return;
+ end if;
+
+ -- Since the call to Restriction_Msg from Check_Restriction may set
+ -- Error_Msg_Sloc to the location of the pragma restriction, save and
+ -- restore the previous value of the global variable around the call.
+
+ Save_Error_Msg_Sloc := Error_Msg_Sloc;
+ Check_Restriction (Msg_Issued, SPARK_05, First_Node (N));
+ Error_Msg_Sloc := Save_Error_Msg_Sloc;
+
+ if Msg_Issued then
+ Error_Msg_F ("\\| " & Msg, N);
+ end if;
+ end if;
+ end Check_SPARK_05_Restriction;
+
+ procedure Check_SPARK_05_Restriction
+ (Msg1 : String;
+ Msg2 : String;
+ N : Node_Id)
+ is
+ Msg_Issued : Boolean;
+ Save_Error_Msg_Sloc : Source_Ptr;
+
+ begin
+ pragma Assert (Msg2'Length /= 0 and then Msg2 (Msg2'First) = '\');
+
+ if Comes_From_Source (Original_Node (N)) then
+ if Restriction_Check_Required (SPARK_05)
+ and then Is_In_Hidden_Part_In_SPARK (Sloc (N))
+ then
+ return;
+ end if;
+
+ -- Since the call to Restriction_Msg from Check_Restriction may set
+ -- Error_Msg_Sloc to the location of the pragma restriction, save and
+ -- restore the previous value of the global variable around the call.
+
+ Save_Error_Msg_Sloc := Error_Msg_Sloc;
+ Check_Restriction (Msg_Issued, SPARK_05, First_Node (N));
+ Error_Msg_Sloc := Save_Error_Msg_Sloc;
+
+ if Msg_Issued then
+ Error_Msg_F ("\\| " & Msg1, N);
+ Error_Msg_F (Msg2, N);
+ end if;
+ end if;
+ end Check_SPARK_05_Restriction;
+
--------------------------------------
-- Check_Wide_Character_Restriction --
--------------------------------------
@@ -1008,8 +1113,7 @@ package body Restrict is
-- Note: body of this function must be coordinated with list of renaming
-- declarations in System.Rident.
- function Process_Restriction_Synonyms (N : Node_Id) return Name_Id
- is
+ function Process_Restriction_Synonyms (N : Node_Id) return Name_Id is
Old_Name : constant Name_Id := Chars (N);
New_Name : Name_Id;
@@ -1090,16 +1194,18 @@ package body Restrict is
Restricted_Profile_Cached := True;
declare
- R : Restriction_Flags renames Profile_Info (Restricted).Set;
- V : Restriction_Values renames Profile_Info (Restricted).Value;
+ R : Restriction_Flags renames
+ Profile_Info (Restricted_Tasking).Set;
+ V : Restriction_Values renames
+ Profile_Info (Restricted_Tasking).Value;
begin
for J in R'Range loop
if R (J)
and then (Restrictions.Set (J) = False
- or else Restriction_Warnings (J)
- or else
- (J in All_Parameter_Restrictions
- and then Restrictions.Value (J) > V (J)))
+ or else Restriction_Warnings (J)
+ or else
+ (J in All_Parameter_Restrictions
+ and then Restrictions.Value (J) > V (J)))
then
Restricted_Profile_Result := False;
exit;
@@ -1527,7 +1633,7 @@ package body Restrict is
procedure Set_Restriction_No_Use_Of_Entity
(Entity : Node_Id;
- Warn : Boolean;
+ Warning : Boolean;
Profile : Profile_Name := No_Profile)
is
Nam : Node_Id;
@@ -1543,7 +1649,7 @@ package body Restrict is
-- Error has precedence over warning
- if not Warn then
+ if not Warning then
No_Use_Of_Entity.Table (J).Warn := False;
end if;
@@ -1553,7 +1659,7 @@ package body Restrict is
-- Entry is not currently in table
- No_Use_Of_Entity.Append ((Entity, Warn, Profile));
+ No_Use_Of_Entity.Append ((Entity, Warning, Profile));
-- Now we need to find the direct name and set Boolean2 flag
@@ -1580,13 +1686,9 @@ package body Restrict is
A_Id : constant Aspect_Id_Exclude_No_Aspect := Get_Aspect_Id (Chars (N));
begin
- No_Specification_Of_Aspects (A_Id) := Sloc (N);
-
- if Warning = False then
- No_Specification_Of_Aspect_Warning (A_Id) := False;
- end if;
-
No_Specification_Of_Aspect_Set := True;
+ No_Specification_Of_Aspects (A_Id) := Sloc (N);
+ No_Specification_Of_Aspect_Warning (A_Id) := Warning;
end Set_Restriction_No_Specification_Of_Aspect;
procedure Set_Restriction_No_Specification_Of_Aspect (A_Id : Aspect_Id) is
@@ -1609,10 +1711,7 @@ package body Restrict is
begin
No_Use_Of_Attribute_Set := True;
No_Use_Of_Attribute (A_Id) := Sloc (N);
-
- if Warning = False then
- No_Use_Of_Attribute_Warning (A_Id) := False;
- end if;
+ No_Use_Of_Attribute_Warning (A_Id) := Warning;
end Set_Restriction_No_Use_Of_Attribute;
procedure Set_Restriction_No_Use_Of_Attribute (A_Id : Attribute_Id) is
@@ -1635,10 +1734,7 @@ package body Restrict is
begin
No_Use_Of_Pragma_Set := True;
No_Use_Of_Pragma (A_Id) := Sloc (N);
-
- if Warning = False then
- No_Use_Of_Pragma_Warning (A_Id) := False;
- end if;
+ No_Use_Of_Pragma_Warning (A_Id) := Warning;
end Set_Restriction_No_Use_Of_Pragma;
procedure Set_Restriction_No_Use_Of_Pragma (A_Id : Pragma_Id) is
@@ -1648,90 +1744,6 @@ package body Restrict is
No_Use_Of_Pragma_Warning (A_Id) := False;
end Set_Restriction_No_Use_Of_Pragma;
- --------------------------------
- -- Check_SPARK_05_Restriction --
- --------------------------------
-
- procedure Check_SPARK_05_Restriction
- (Msg : String;
- N : Node_Id;
- Force : Boolean := False)
- is
- Msg_Issued : Boolean;
- Save_Error_Msg_Sloc : Source_Ptr;
- Onode : constant Node_Id := Original_Node (N);
-
- begin
- -- Output message if Force set
-
- if Force
-
- -- Or if this node comes from source
-
- or else Comes_From_Source (N)
-
- -- Or if this is a range node which rewrites a range attribute and
- -- the range attribute comes from source.
-
- or else (Nkind (N) = N_Range
- and then Nkind (Onode) = N_Attribute_Reference
- and then Attribute_Name (Onode) = Name_Range
- and then Comes_From_Source (Onode))
-
- -- Or this is an expression that does not come from source, which is
- -- a rewriting of an expression that does come from source.
-
- or else (Nkind (N) in N_Subexpr and then Comes_From_Source (Onode))
- then
- if Restriction_Check_Required (SPARK_05)
- and then Is_In_Hidden_Part_In_SPARK (Sloc (N))
- then
- return;
- end if;
-
- -- Since the call to Restriction_Msg from Check_Restriction may set
- -- Error_Msg_Sloc to the location of the pragma restriction, save and
- -- restore the previous value of the global variable around the call.
-
- Save_Error_Msg_Sloc := Error_Msg_Sloc;
- Check_Restriction (Msg_Issued, SPARK_05, First_Node (N));
- Error_Msg_Sloc := Save_Error_Msg_Sloc;
-
- if Msg_Issued then
- Error_Msg_F ("\\| " & Msg, N);
- end if;
- end if;
- end Check_SPARK_05_Restriction;
-
- procedure Check_SPARK_05_Restriction (Msg1, Msg2 : String; N : Node_Id) is
- Msg_Issued : Boolean;
- Save_Error_Msg_Sloc : Source_Ptr;
-
- begin
- pragma Assert (Msg2'Length /= 0 and then Msg2 (Msg2'First) = '\');
-
- if Comes_From_Source (Original_Node (N)) then
- if Restriction_Check_Required (SPARK_05)
- and then Is_In_Hidden_Part_In_SPARK (Sloc (N))
- then
- return;
- end if;
-
- -- Since the call to Restriction_Msg from Check_Restriction may set
- -- Error_Msg_Sloc to the location of the pragma restriction, save and
- -- restore the previous value of the global variable around the call.
-
- Save_Error_Msg_Sloc := Error_Msg_Sloc;
- Check_Restriction (Msg_Issued, SPARK_05, First_Node (N));
- Error_Msg_Sloc := Save_Error_Msg_Sloc;
-
- if Msg_Issued then
- Error_Msg_F ("\\| " & Msg1, N);
- Error_Msg_F (Msg2, N);
- end if;
- end if;
- end Check_SPARK_05_Restriction;
-
----------------------------------
-- Suppress_Restriction_Message --
----------------------------------
diff --git a/gcc/ada/restrict.ads b/gcc/ada/restrict.ads
index c8c050c20a..d725de799a 100644
--- a/gcc/ada/restrict.ads
+++ b/gcc/ada/restrict.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -287,9 +287,9 @@ package Restrict is
-- for this aspect using Set_No_Specification_Of_Aspect.
procedure Check_Restriction_No_Use_Of_Attribute (N : Node_Id);
- -- N is the node of an attribute definition clause. An error message
- -- (warning) will be issued if a restriction (warning) was previously set
- -- for this attribute using Set_No_Use_Of_Attribute.
+ -- N denotes an attribute definition clause or an attribute reference. An
+ -- error message (warning) will be issued if a restriction (warning) was
+ -- previously set for this attribute using Set_No_Use_Of_Attribute.
procedure Check_Restriction_No_Use_Of_Entity (N : Node_Id);
-- N is the node id for an entity reference. An error message (warning)
@@ -316,7 +316,10 @@ package Restrict is
-- the SPARK_05 restriction is set, then an error is issued on N. Msg
-- is appended to the restriction failure message.
- procedure Check_SPARK_05_Restriction (Msg1, Msg2 : String; N : Node_Id);
+ procedure Check_SPARK_05_Restriction
+ (Msg1 : String;
+ Msg2 : String;
+ N : Node_Id);
-- Same as Check_SPARK_05_Restriction except there is a continuation
-- message Msg2 following the initial message Msg1.
@@ -421,10 +424,10 @@ package Restrict is
-- executing this code only if needed.
function Restricted_Profile return Boolean;
- -- Tests if set of restrictions corresponding to Profile (Restricted) is
- -- currently in effect (set by pragma Profile, or by an appropriate set of
- -- individual Restrictions pragmas). Returns True only if all the required
- -- restrictions are set.
+ -- Tests if set of restrictions corresponding to Restricted_Tasking profile
+ -- is currently in effect (set by pragma Profile, or by an appropriate set
+ -- of individual Restrictions pragmas). Returns True only if all the
+ -- required restrictions are set.
procedure Set_Hidden_Part_In_SPARK (Loc1, Loc2 : Source_Ptr);
-- Insert a new hidden region range in the SPARK hides table. The effect
@@ -490,7 +493,7 @@ package Restrict is
procedure Set_Restriction_No_Use_Of_Entity
(Entity : Node_Id;
- Warn : Boolean;
+ Warning : Boolean;
Profile : Profile_Name := No_Profile);
-- Sets given No_Use_Of_Entity restriction in table if not there already.
-- Warn is True if from Restriction_Warnings, or for Restrictions if the
diff --git a/gcc/ada/rtinit.c b/gcc/ada/rtinit.c
index 97582db3a0..42defa8ca1 100644
--- a/gcc/ada/rtinit.c
+++ b/gcc/ada/rtinit.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2014-2015, Free Software Foundation, Inc. *
+ * Copyright (C) 2014-2016, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -86,6 +86,9 @@ extern HANDLE ProcListEvt;
#define EXPAND_ARGV_RATE 128
+int __gnat_do_argv_expansion = 1;
+#pragma weak __gnat_do_argv_expansion
+
static void
append_arg (int *index, LPWSTR dir, LPWSTR value,
char ***argv, int *last, int quoted)
@@ -166,14 +169,14 @@ __gnat_runtime_initialize(int install_handler)
char *codepage = getenv ("GNAT_CODE_PAGE");
/* Default code page is UTF-8. */
- CurrentCodePage = CP_UTF8;
+ __gnat_current_codepage = CP_UTF8;
if (codepage != NULL)
{
if (strcmp (codepage, "CP_ACP") == 0)
- CurrentCodePage = CP_ACP;
+ __gnat_current_codepage = CP_ACP;
else if (strcmp (codepage, "CP_UTF8") == 0)
- CurrentCodePage = CP_UTF8;
+ __gnat_current_codepage = CP_UTF8;
}
}
@@ -182,29 +185,29 @@ __gnat_runtime_initialize(int install_handler)
char *ccsencoding = getenv ("GNAT_CCS_ENCODING");
/* Default CCS Encoding. */
- CurrentCCSEncoding = _O_TEXT;
+ __gnat_current_ccs_encoding = _O_TEXT;
__gnat_wide_text_translation_required = 0;
if (ccsencoding != NULL)
{
if (strcmp (ccsencoding, "U16TEXT") == 0)
{
- CurrentCCSEncoding = _O_U16TEXT;
+ __gnat_current_ccs_encoding = _O_U16TEXT;
__gnat_wide_text_translation_required = 1;
}
else if (strcmp (ccsencoding, "TEXT") == 0)
{
- CurrentCCSEncoding = _O_TEXT;
+ __gnat_current_ccs_encoding = _O_TEXT;
__gnat_wide_text_translation_required = 0;
}
else if (strcmp (ccsencoding, "WTEXT") == 0)
{
- CurrentCCSEncoding = _O_WTEXT;
+ __gnat_current_ccs_encoding = _O_WTEXT;
__gnat_wide_text_translation_required = 1;
}
else if (strcmp (ccsencoding, "U8TEXT") == 0)
{
- CurrentCCSEncoding = _O_U8TEXT;
+ __gnat_current_ccs_encoding = _O_U8TEXT;
__gnat_wide_text_translation_required = 1;
}
}
@@ -238,7 +241,7 @@ __gnat_runtime_initialize(int install_handler)
quoted = (wargv[k][0] == _T('\''));
/* Check for wildcard expansion if the argument is not quoted. */
- if (!quoted
+ if (!quoted && __gnat_do_argv_expansion
&& (_tcsstr (wargv[k], _T("?")) != 0 ||
_tcsstr (wargv[k], _T("*")) != 0))
{
@@ -289,7 +292,8 @@ __gnat_runtime_initialize(int install_handler)
/* No wildcard. Store parameter as-is. Remove quote if
needed. */
append_arg (&argc_expanded, NULL, wargv[k],
- &gnat_argv, &last, quoted);
+ &gnat_argv, &last,
+ quoted && __gnat_do_argv_expansion);
}
}
diff --git a/gcc/ada/rtsfind.adb b/gcc/ada/rtsfind.adb
index 3c84bbe115..3b078c2e66 100644
--- a/gcc/ada/rtsfind.adb
+++ b/gcc/ada/rtsfind.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -33,6 +33,7 @@ with Errout; use Errout;
with Exp_Dist; use Exp_Dist;
with Fname; use Fname;
with Fname.UF; use Fname.UF;
+with Ghost; use Ghost;
with Lib; use Lib;
with Lib.Load; use Lib.Load;
with Namet; use Namet;
@@ -730,7 +731,7 @@ package body Rtsfind is
declare
U : RT_Unit_Table_Record
- renames RT_Unit_Table (RE_Unit_Table (E));
+ renames RT_Unit_Table (RE_Unit_Table (E));
begin
if No (U.Entity) then
U.Entity := S;
@@ -938,7 +939,7 @@ package body Rtsfind is
-- Provide a clean environment for the unit
- Ghost_Mode := None;
+ Install_Ghost_Mode (None);
-- Note if secondary stack is used
@@ -1041,7 +1042,7 @@ package body Rtsfind is
Set_Is_Potentially_Use_Visible (U.Entity, True);
end if;
- Ghost_Mode := Save_Ghost_Mode;
+ Restore_Ghost_Mode (Save_Ghost_Mode);
end Load_RTU;
--------------------
@@ -1144,6 +1145,9 @@ package body Rtsfind is
-- M (1 .. P) is current message to be output
RE_Image : constant String := RE_Id'Image (Id);
+ S : Natural;
+ -- RE_Image (S .. RE_Image'Last) is the name of the entity without the
+ -- "RE_" or "RO_XX_" prefix.
begin
if Id = RE_Null then
@@ -1166,10 +1170,21 @@ package body Rtsfind is
M (P + 1) := '.';
P := P + 1;
+ -- Strip "RE"
+
+ if RE_Image (2) = 'E' then
+ S := 4;
+
+ -- Strip "RO_XX"
+
+ else
+ S := 7;
+ end if;
+
-- Add entity name and closing quote to message
- Name_Len := RE_Image'Length - 3;
- Name_Buffer (1 .. Name_Len) := RE_Image (4 .. RE_Image'Length);
+ Name_Len := RE_Image'Length - S + 1;
+ Name_Buffer (1 .. Name_Len) := RE_Image (S .. RE_Image'Last);
Set_Casing (Mixed_Case);
M (P + 1 .. P + Name_Len) := Name_Buffer (1 .. Name_Len);
P := P + Name_Len;
@@ -1337,7 +1352,7 @@ package body Rtsfind is
-- is System. If so, return the value from the already compiled
-- declaration and otherwise do a regular find.
- -- Not pleasant, but these kinds of annoying recursion when
+ -- Not pleasant, but these kinds of annoying recursion scenarios when
-- writing an Ada compiler in Ada have to be broken somewhere.
if Present (Main_Unit_Entity)
diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads
index 1d8cd89cc4..f3dfd3191a 100644
--- a/gcc/ada/rtsfind.ads
+++ b/gcc/ada/rtsfind.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -349,6 +349,7 @@ package Rtsfind is
System_Pool_Empty,
System_Pool_Local,
System_Pool_Size,
+ System_Relative_Delays,
System_RPC,
System_Scalar_Values,
System_Secondary_Stack,
@@ -703,6 +704,7 @@ package Rtsfind is
RE_Abort_Task, -- Ada.Task_Identification
RE_Current_Task, -- Ada.Task_Identification
RO_AT_Task_Id, -- Ada.Task_Identification
+ RE_Tasking_State, -- Ada.Task_Identification
RE_Decimal_IO, -- Ada.Text_IO
RE_Fixed_IO, -- Ada.Text_IO
@@ -725,6 +727,7 @@ package Rtsfind is
RE_Address, -- System
RE_Any_Priority, -- System
RE_Bit_Order, -- System
+ RE_Default_Priority, -- System
RE_High_Order_First, -- System
RE_Interrupt_Priority, -- System
RE_Lib_Stop, -- System
@@ -1402,6 +1405,8 @@ package Rtsfind is
RE_Tk_Objref, -- System.Partition_Interface
RE_Tk_Union, -- System.Partition_Interface
+ RO_RD_Delay_For, -- System.Relative_Delays
+
RE_IS_Is1, -- System.Scalar_Values
RE_IS_Is2, -- System.Scalar_Values
RE_IS_Is4, -- System.Scalar_Values
@@ -1543,9 +1548,7 @@ package Rtsfind is
RE_Unspecified_Task_Info, -- System.Task_Info
RE_Task_Procedure_Access, -- System.Tasking
- RE_Task_Entry_Names_Array, -- System.Tasking
RO_ST_Number_Of_Entries, -- System.Tasking
- RO_ST_Set_Entry_Names, -- System.Tasking
RO_ST_Task_Id, -- System.Tasking
RO_ST_Null_Task, -- System.Tasking
@@ -1679,7 +1682,7 @@ package Rtsfind is
RE_Dispatching_Domain, -- Multiprocessors.Dispatching_Domains
RE_Protected_Entry_Body_Array, -- Tasking.Protected_Objects.Entries
- RE_Protected_Entry_Names_Array, -- Tasking.Protected_Objects.Entries
+ RE_Protected_Entry_Queue_Max_Array, -- Tasking.Protected_Objects.Entries
RE_Protection_Entries, -- Tasking.Protected_Objects.Entries
RE_Protection_Entries_Access, -- Tasking.Protected_Objects.Entries
RE_Initialize_Protection_Entries, -- Tasking.Protected_Objects.Entries
@@ -1688,7 +1691,6 @@ package Rtsfind is
RO_PE_Get_Ceiling, -- Tasking.Protected_Objects.Entries
RO_PE_Number_Of_Entries, -- Tasking.Protected_Objects.Entries
RO_PE_Set_Ceiling, -- Tasking.Protected_Objects.Entries
- RO_PE_Set_Entry_Names, -- Tasking.Protected_Objects.Entries
RE_Communication_Block, -- Protected_Objects.Operations
RE_Protected_Entry_Call, -- Protected_Objects.Operations
@@ -1935,6 +1937,7 @@ package Rtsfind is
RE_Abort_Task => Ada_Task_Identification,
RE_Current_Task => Ada_Task_Identification,
RO_AT_Task_Id => Ada_Task_Identification,
+ RE_Tasking_State => Ada_Task_Identification,
RE_Decimal_IO => Ada_Text_IO,
RE_Fixed_IO => Ada_Text_IO,
@@ -1957,6 +1960,7 @@ package Rtsfind is
RE_Address => System,
RE_Any_Priority => System,
RE_Bit_Order => System,
+ RE_Default_Priority => System,
RE_High_Order_First => System,
RE_Interrupt_Priority => System,
RE_Lib_Stop => System,
@@ -2633,6 +2637,8 @@ package Rtsfind is
RE_Stack_Bounded_Pool => System_Pool_Size,
+ RO_RD_Delay_For => System_Relative_Delays,
+
RE_Do_Apc => System_RPC,
RE_Do_Rpc => System_RPC,
RE_Params_Stream_Type => System_RPC,
@@ -2779,9 +2785,7 @@ package Rtsfind is
RE_Unspecified_Task_Info => System_Task_Info,
RE_Task_Procedure_Access => System_Tasking,
- RE_Task_Entry_Names_Array => System_Tasking,
RO_ST_Number_Of_Entries => System_Tasking,
- RO_ST_Set_Entry_Names => System_Tasking,
RO_ST_Task_Id => System_Tasking,
RO_ST_Null_Task => System_Tasking,
@@ -2918,7 +2922,7 @@ package Rtsfind is
RE_Protected_Entry_Body_Array =>
System_Tasking_Protected_Objects_Entries,
- RE_Protected_Entry_Names_Array =>
+ RE_Protected_Entry_Queue_Max_Array =>
System_Tasking_Protected_Objects_Entries,
RE_Protection_Entries =>
System_Tasking_Protected_Objects_Entries,
@@ -2936,8 +2940,6 @@ package Rtsfind is
System_Tasking_Protected_Objects_Entries,
RO_PE_Set_Ceiling =>
System_Tasking_Protected_Objects_Entries,
- RO_PE_Set_Entry_Names =>
- System_Tasking_Protected_Objects_Entries,
RE_Communication_Block =>
System_Tasking_Protected_Objects_Operations,
diff --git a/gcc/ada/s-bignum.adb b/gcc/ada/s-bignum.adb
index 0c20a5b952..18f62c7d23 100644
--- a/gcc/ada/s-bignum.adb
+++ b/gcc/ada/s-bignum.adb
@@ -147,7 +147,7 @@ package body System.Bignums is
for J in reverse 1 .. X'Last loop
RD := RD + DD (X (J));
- if J >= 1 + (X'Last - Y'Last) then
+ if J >= 1 + (X'Last - Y'Last) then
RD := RD + DD (Y (J - (X'Last - Y'Last)));
end if;
@@ -189,7 +189,7 @@ package body System.Bignums is
for J in reverse 1 .. X'Last loop
RD := RD + DD (X (J));
- if J >= 1 + (X'Last - Y'Last) then
+ if J >= 1 + (X'Last - Y'Last) then
RD := RD - DD (Y (J - (X'Last - Y'Last)));
end if;
@@ -840,9 +840,9 @@ package body System.Bignums is
Carry := 0;
for J in reverse 1 .. n loop
- Tmp := DD (v (J)) * d + Carry;
- v (J) := LSD (Tmp);
- Carry := Tmp / Base;
+ Tmp := DD (v (J)) * d + Carry;
+ v (J) := LSD (Tmp);
+ Carry := Tmp / Base;
end loop;
pragma Assert (Carry = 0);
diff --git a/gcc/ada/s-boustr.adb b/gcc/ada/s-boustr.adb
new file mode 100644
index 0000000000..1eb168d95a
--- /dev/null
+++ b/gcc/ada/s-boustr.adb
@@ -0,0 +1,104 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . B O U N D E D _ S T R I N G S --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2016, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with System.Storage_Elements;
+
+package body System.Bounded_Strings is
+
+ ------------
+ -- Append --
+ ------------
+
+ procedure Append (X : in out Bounded_String; C : Character) is
+ begin
+ -- If we have too many characters to fit, simply drop them
+
+ if X.Length < X.Max_Length then
+ X.Length := X.Length + 1;
+ X.Chars (X.Length) := C;
+ end if;
+ end Append;
+
+ procedure Append (X : in out Bounded_String; S : String) is
+ begin
+ for C of S loop
+ Append (X, C);
+ end loop;
+ end Append;
+
+ --------------------
+ -- Append_Address --
+ --------------------
+
+ procedure Append_Address (X : in out Bounded_String; A : Address)
+ is
+ S : String (1 .. 18);
+ P : Natural;
+ use System.Storage_Elements;
+ N : Integer_Address;
+
+ H : constant array (Integer range 0 .. 15) of Character :=
+ "0123456789abcdef";
+ begin
+ P := S'Last;
+ N := To_Integer (A);
+ loop
+ S (P) := H (Integer (N mod 16));
+ P := P - 1;
+ N := N / 16;
+ exit when N = 0;
+ end loop;
+
+ S (P - 1) := '0';
+ S (P) := 'x';
+
+ Append (X, S (P - 1 .. S'Last));
+ end Append_Address;
+
+ -------------
+ -- Is_Full --
+ -------------
+
+ function Is_Full (X : Bounded_String) return Boolean is
+ begin
+ return X.Length >= X.Max_Length;
+ end Is_Full;
+
+ ---------------
+ -- To_String --
+ ---------------
+
+ function To_String (X : Bounded_String) return String is
+ begin
+ return X.Chars (1 .. X.Length);
+ end To_String;
+
+end System.Bounded_Strings;
diff --git a/gcc/ada/s-boustr.ads b/gcc/ada/s-boustr.ads
new file mode 100644
index 0000000000..0cc2ccec8b
--- /dev/null
+++ b/gcc/ada/s-boustr.ads
@@ -0,0 +1,62 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . B O U N D E D _ S T R I N G S --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2016, AdaCore --
+-- --
+-- GNAT is free software; you can redistribute it and/or modify it under --
+-- terms of the GNU General Public License as published by the Free Soft- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
+-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- A very simple implentation of bounded strings, used by tracebacks
+
+package System.Bounded_Strings is
+ type Bounded_String (Max_Length : Natural) is limited private;
+ -- A string whose length is bounded by Max_Length. The bounded string is
+ -- empty at initialization.
+
+ procedure Append (X : in out Bounded_String; C : Character);
+ procedure Append (X : in out Bounded_String; S : String);
+ -- Append a character or a string to X. If the bounded string is full,
+ -- extra characters are simply dropped.
+
+ function To_String (X : Bounded_String) return String;
+ function "+" (X : Bounded_String) return String renames To_String;
+ -- Convert to a normal string
+
+ procedure Append_Address (X : in out Bounded_String; A : Address);
+ -- Append an address to X
+
+ function Is_Full (X : Bounded_String) return Boolean;
+ -- Return True iff X is full and any character or string will be dropped
+ -- if appended.
+private
+ type Bounded_String (Max_Length : Natural) is limited record
+ Length : Natural := 0;
+ -- Current length of the string
+
+ Chars : String (1 .. Max_Length);
+ -- String content
+ end record;
+end System.Bounded_Strings;
diff --git a/gcc/ada/s-exctra.adb b/gcc/ada/s-exctra.adb
index 1d6cabfcc8..343a723b67 100644
--- a/gcc/ada/s-exctra.adb
+++ b/gcc/ada/s-exctra.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2000-2015, AdaCore --
+-- Copyright (C) 2000-2016, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -112,8 +112,10 @@ package body System.Exception_Traces is
case Kind is
when Every_Raise =>
Exception_Trace := Every_Raise;
+
when Unhandled_Raise =>
Exception_Trace := Unhandled_Raise;
+
when Unhandled_Raise_In_Main =>
Exception_Trace := Unhandled_Raise_In_Main;
end case;
diff --git a/gcc/ada/s-exnllf.adb b/gcc/ada/s-exnllf.adb
index a4386e813f..be16b07128 100644
--- a/gcc/ada/s-exnllf.adb
+++ b/gcc/ada/s-exnllf.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -34,12 +34,28 @@
-- a compile time known exponent in this range. The use of Float'Machine and
-- Long_Float'Machine is to avoid unwanted extra precision in the results.
+-- Note that for a negative exponent in Left ** Right, we compute the result
+-- as:
+
+-- 1.0 / (Left ** (-Right))
+
+-- Note that the case of Left being zero is not special, it will simply result
+-- in a division by zero at the end, yielding a correctly signed infinity, or
+-- possibly generating an overflow.
+
+-- Note on overflow: This coding assumes that the target generates infinities
+-- with standard IEEE semantics. If this is not the case, then the code
+-- for negative exponent may raise Constraint_Error. This follows the
+-- implementation permission given in RM 4.5.6(12).
+
package body System.Exn_LLF is
+ subtype Negative is Integer range Integer'First .. -1;
+
function Exp
(Left : Long_Long_Float;
- Right : Integer) return Long_Long_Float;
- -- Common routine used if Right not in 0 .. 4
+ Right : Natural) return Long_Long_Float;
+ -- Common routine used if Right is greater or equal to 5
---------------
-- Exn_Float --
@@ -63,6 +79,8 @@ package body System.Exn_LLF is
when 4 =>
Temp := Float'Machine (Left * Left);
return Float'Machine (Temp * Temp);
+ when Negative =>
+ return Float'Machine (1.0 / Exn_Float (Left, -Right));
when others =>
return
Float'Machine
@@ -92,6 +110,8 @@ package body System.Exn_LLF is
when 4 =>
Temp := Long_Float'Machine (Left * Left);
return Long_Float'Machine (Temp * Temp);
+ when Negative =>
+ return Long_Float'Machine (1.0 / Exn_Long_Float (Left, -Right));
when others =>
return
Long_Float'Machine
@@ -121,6 +141,8 @@ package body System.Exn_LLF is
when 4 =>
Temp := Left * Left;
return Temp * Temp;
+ when Negative =>
+ return 1.0 / Exn_Long_Long_Float (Left, -Right);
when others =>
return Exp (Left, Right);
end case;
@@ -132,60 +154,29 @@ package body System.Exn_LLF is
function Exp
(Left : Long_Long_Float;
- Right : Integer) return Long_Long_Float
+ Right : Natural) return Long_Long_Float
is
Result : Long_Long_Float := 1.0;
Factor : Long_Long_Float := Left;
- Exp : Integer := Right;
+ Exp : Natural := Right;
begin
-- We use the standard logarithmic approach, Exp gets shifted right
-- testing successive low order bits and Factor is the value of the
-- base raised to the next power of 2. If the low order bit or Exp is
- -- set, multiply the result by this factor. For negative exponents,
- -- invert result upon return.
-
- if Exp >= 0 then
- loop
- if Exp rem 2 /= 0 then
- Result := Result * Factor;
- end if;
-
- Exp := Exp / 2;
- exit when Exp = 0;
- Factor := Factor * Factor;
- end loop;
-
- return Result;
-
- -- Here we have a negative exponent, and we compute the result as:
-
- -- 1.0 / (Left ** (-Right))
-
- -- Note that the case of Left being zero is not special, it will
- -- simply result in a division by zero at the end, yielding a
- -- correctly signed infinity, or possibly generating an overflow.
-
- -- Note on overflow: The coding of this routine assumes that the
- -- target generates infinities with standard IEEE semantics. If this
- -- is not the case, then the code below may raise Constraint_Error.
- -- This follows the implementation permission given in RM 4.5.6(12).
-
- else
- begin
- loop
- if Exp rem 2 /= 0 then
- Result := Result * Factor;
- end if;
-
- Exp := Exp / 2;
- exit when Exp = 0;
- Factor := Factor * Factor;
- end loop;
-
- return 1.0 / Result;
- end;
- end if;
+ -- set, multiply the result by this factor.
+
+ loop
+ if Exp rem 2 /= 0 then
+ Result := Result * Factor;
+ end if;
+
+ Exp := Exp / 2;
+ exit when Exp = 0;
+ Factor := Factor * Factor;
+ end loop;
+
+ return Result;
end Exp;
end System.Exn_LLF;
diff --git a/gcc/ada/s-fatgen.adb b/gcc/ada/s-fatgen.adb
index 35d037ac38..c2185e0732 100644
--- a/gcc/ada/s-fatgen.adb
+++ b/gcc/ada/s-fatgen.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -84,7 +84,7 @@ package body System.Fat_Gen is
-- the sign of the exponent. The absolute value of Frac is in the range
-- 0.0 <= Frac < 1.0. If Frac = 0.0 or -0.0, then Expo is always zero.
- function Gradual_Scaling (Adjustment : UI) return T;
+ function Gradual_Scaling (Adjustment : UI) return T;
-- Like Scaling with a first argument of 1.0, but returns the smallest
-- denormal rather than zero when the adjustment is smaller than
-- Machine_Emin. Used for Succ and Pred.
@@ -368,7 +368,7 @@ package body System.Fat_Gen is
Result := Truncation (abs X);
Tail := abs X - Result;
- if Tail >= 0.5 then
+ if Tail >= 0.5 then
Result := Result + 1.0;
end if;
@@ -553,7 +553,7 @@ package body System.Fat_Gen is
Result := Truncation (abs X);
Tail := abs X - Result;
- if Tail >= 0.5 then
+ if Tail >= 0.5 then
Result := Result + 1.0;
end if;
@@ -775,7 +775,7 @@ package body System.Fat_Gen is
Result := Truncation (Abs_X);
Tail := Abs_X - Result;
- if Tail > 0.5 then
+ if Tail > 0.5 then
Result := Result + 1.0;
elsif Tail = 0.5 then
diff --git a/gcc/ada/s-fileio.adb b/gcc/ada/s-fileio.adb
index e9d54f84f4..9c27a0e907 100644
--- a/gcc/ada/s-fileio.adb
+++ b/gcc/ada/s-fileio.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -106,17 +106,18 @@ package body System.File_IO is
-- Holds open string (longest is "w+b" & nul)
procedure Fopen_Mode
- (Mode : File_Mode;
+ (Namestr : String;
+ Mode : File_Mode;
Text : Boolean;
Creat : Boolean;
Amethod : Character;
Fopstr : out Fopen_String);
-- Determines proper open mode for a file to be opened in the given Ada
- -- mode. Text is true for a text file and false otherwise, and Creat is
- -- true for a create call, and False for an open call. The value stored
- -- in Fopstr is a nul-terminated string suitable for a call to fopen or
- -- freopen. Amethod is the character designating the access method from
- -- the Access_Method field of the FCB.
+ -- mode. Namestr is the NUL-terminated file name. Text is true for a text
+ -- file and false otherwise, and Creat is true for a create call, and False
+ -- for an open call. The value stored in Fopstr is a nul-terminated string
+ -- suitable for a call to fopen or freopen. Amethod is the character
+ -- designating the access method from the Access_Method field of the FCB.
function Errno_Message
(Name : String;
@@ -433,10 +434,14 @@ package body System.File_IO is
-- OPEN CREATE
-- Append_File "r+" "w+"
-- In_File "r" "w+"
- -- Out_File (Direct_IO, Stream_IO) "r+" "w"
+ -- Out_File (Direct_IO, Stream_IO) "r+" [*] "w"
-- Out_File (others) "w" "w"
-- Inout_File "r+" "w+"
+ -- [*] Except that for Out_File, if the file exists and is a fifo (i.e. a
+ -- named pipe), we use "w" instead of "r+". This is necessary to make a
+ -- write to the fifo block until a reader is ready.
+
-- Note: we do not use "a" or "a+" for Append_File, since this would not
-- work in the case of stream files, where even if in append file mode,
-- you can reset to earlier points in the file. The caller must use the
@@ -458,7 +463,8 @@ package body System.File_IO is
-- to the mode, depending on the setting of Text.
procedure Fopen_Mode
- (Mode : File_Mode;
+ (Namestr : String;
+ Mode : File_Mode;
Text : Boolean;
Creat : Boolean;
Amethod : Character;
@@ -466,6 +472,9 @@ package body System.File_IO is
is
Fptr : Positive;
+ function is_fifo (Path : Address) return Integer;
+ pragma Import (C, is_fifo, "__gnat_is_fifo");
+
begin
case Mode is
when In_File =>
@@ -479,7 +488,10 @@ package body System.File_IO is
end if;
when Out_File =>
- if Amethod in 'D' | 'S' and then not Creat then
+ if Amethod in 'D' | 'S'
+ and then not Creat
+ and then is_fifo (Namestr'Address) = 0
+ then
Fopstr (1) := 'r';
Fopstr (2) := '+';
Fptr := 3;
@@ -488,7 +500,9 @@ package body System.File_IO is
Fptr := 2;
end if;
- when Inout_File | Append_File =>
+ when Append_File
+ | Inout_File
+ =>
Fopstr (1) := (if Creat then 'w' else 'r');
Fopstr (2) := '+';
Fptr := 3;
@@ -1045,8 +1059,12 @@ package body System.File_IO is
else
Fopen_Mode
- (Mode, Text_Encoding in Text_Content_Encoding,
- Creat, Amethod, Fopstr);
+ (Namestr => Namestr,
+ Mode => Mode,
+ Text => Text_Encoding in Text_Content_Encoding,
+ Creat => Creat,
+ Amethod => Amethod,
+ Fopstr => Fopstr);
-- A special case, if we are opening (OPEN case) a file and the
-- mode returned by Fopen_Mode is not "r" or "r+", then we first
@@ -1218,8 +1236,12 @@ package body System.File_IO is
else
Fopen_Mode
- (Mode, File.Text_Encoding in Text_Content_Encoding,
- False, File.Access_Method, Fopstr);
+ (Namestr => File.Name.all,
+ Mode => Mode,
+ Text => File.Text_Encoding in Text_Content_Encoding,
+ Creat => False,
+ Amethod => File.Access_Method,
+ Fopstr => Fopstr);
File.Stream := freopen
(File.Name.all'Address, Fopstr'Address, File.Stream,
diff --git a/gcc/ada/s-gearop.adb b/gcc/ada/s-gearop.adb
index f84280ee8b..b6d6f22d51 100644
--- a/gcc/ada/s-gearop.adb
+++ b/gcc/ada/s-gearop.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2006-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -30,9 +30,7 @@
------------------------------------------------------------------------------
with Ada.Numerics; use Ada.Numerics;
-
package body System.Generic_Array_Operations is
-
function Check_Unit_Last
(Index : Integer;
Order : Positive;
@@ -696,6 +694,11 @@ package body System.Generic_Array_Operations is
end loop;
Forward_Eliminate (MA, MX, Det);
+
+ if Det = Zero then
+ raise Constraint_Error with "matrix is singular";
+ end if;
+
Back_Substitute (MA, MX);
for J in 0 .. R'Length - 1 loop
@@ -735,6 +738,11 @@ package body System.Generic_Array_Operations is
end loop;
Forward_Eliminate (MA, MB, Det);
+
+ if Det = Zero then
+ raise Constraint_Error with "matrix is singular";
+ end if;
+
Back_Substitute (MA, MB);
return MB;
diff --git a/gcc/ada/s-gearop.ads b/gcc/ada/s-gearop.ads
index f401da219e..7e252eefb2 100644
--- a/gcc/ada/s-gearop.ads
+++ b/gcc/ada/s-gearop.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2006-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 2006-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -396,6 +396,7 @@ pragma Pure (Generic_Array_Operations);
generic
type Scalar is private;
+ Zero : Scalar;
type Vector is array (Integer range <>) of Scalar;
type Matrix is array (Integer range <>, Integer range <>) of Scalar;
with procedure Back_Substitute (M, N : in out Matrix) is <>;
@@ -411,6 +412,7 @@ pragma Pure (Generic_Array_Operations);
generic
type Scalar is private;
+ Zero : Scalar;
type Matrix is array (Integer range <>, Integer range <>) of Scalar;
with procedure Back_Substitute (M, N : in out Matrix) is <>;
with procedure Forward_Eliminate
diff --git a/gcc/ada/s-htable.adb b/gcc/ada/s-htable.adb
index 2d6a3c6f47..ba956fcdd7 100644
--- a/gcc/ada/s-htable.adb
+++ b/gcc/ada/s-htable.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2015, AdaCore --
+-- Copyright (C) 1995-2016, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -258,7 +258,7 @@ package body System.HTable is
-- Get --
---------
- function Get (K : Key) return Element is
+ function Get (K : Key) return Element is
Tmp : constant Elmt_Ptr := Tab.Get (K);
begin
if Tmp = null then
diff --git a/gcc/ada/s-imgint.adb b/gcc/ada/s-imgint.adb
index 88dc5849de..0d19e56fca 100644
--- a/gcc/ada/s-imgint.adb
+++ b/gcc/ada/s-imgint.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -31,6 +31,14 @@
package body System.Img_Int is
+ procedure Set_Digits
+ (T : Integer;
+ S : in out String;
+ P : in out Natural);
+ -- Set digits of absolute value of T, which is zero or negative. We work
+ -- with the negative of the value so that the largest negative number is
+ -- not a special case.
+
-------------------
-- Image_Integer --
-------------------
@@ -53,6 +61,26 @@ package body System.Img_Int is
Set_Image_Integer (V, S, P);
end Image_Integer;
+ ----------------
+ -- Set_Digits --
+ ----------------
+
+ procedure Set_Digits
+ (T : Integer;
+ S : in out String;
+ P : in out Natural)
+ is
+ begin
+ if T <= -10 then
+ Set_Digits (T / 10, S, P);
+ P := P + 1;
+ S (P) := Character'Val (48 - (T rem 10));
+ else
+ P := P + 1;
+ S (P) := Character'Val (48 - T);
+ end if;
+ end Set_Digits;
+
-----------------------
-- Set_Image_Integer --
-----------------------
@@ -62,36 +90,13 @@ package body System.Img_Int is
S : in out String;
P : in out Natural)
is
- procedure Set_Digits (T : Integer);
- -- Set digits of absolute value of T, which is zero or negative. We work
- -- with the negative of the value so that the largest negative number is
- -- not a special case.
-
- ----------------
- -- Set_Digits --
- ----------------
-
- procedure Set_Digits (T : Integer) is
- begin
- if T <= -10 then
- Set_Digits (T / 10);
- P := P + 1;
- S (P) := Character'Val (48 - (T rem 10));
- else
- P := P + 1;
- S (P) := Character'Val (48 - T);
- end if;
- end Set_Digits;
-
- -- Start of processing for Set_Image_Integer
-
begin
if V >= 0 then
- Set_Digits (-V);
+ Set_Digits (-V, S, P);
else
P := P + 1;
S (P) := '-';
- Set_Digits (V);
+ Set_Digits (V, S, P);
end if;
end Set_Image_Integer;
diff --git a/gcc/ada/s-imglli.adb b/gcc/ada/s-imglli.adb
index 05154fadc9..6c4a78356b 100644
--- a/gcc/ada/s-imglli.adb
+++ b/gcc/ada/s-imglli.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -31,6 +31,14 @@
package body System.Img_LLI is
+ procedure Set_Digits
+ (T : Long_Long_Integer;
+ S : in out String;
+ P : in out Natural);
+ -- Set digits of absolute value of T, which is zero or negative. We work
+ -- with the negative of the value so that the largest negative number is
+ -- not a special case.
+
-----------------------------
-- Image_Long_Long_Integer --
-----------------------------
@@ -53,45 +61,41 @@ package body System.Img_LLI is
Set_Image_Long_Long_Integer (V, S, P);
end Image_Long_Long_Integer;
- ------------------------------
- -- Set_Image_Long_Long_Integer --
- -----------------------------
+ ----------------
+ -- Set_Digits --
+ ----------------
- procedure Set_Image_Long_Long_Integer
- (V : Long_Long_Integer;
+ procedure Set_Digits
+ (T : Long_Long_Integer;
S : in out String;
P : in out Natural)
is
- procedure Set_Digits (T : Long_Long_Integer);
- -- Set digits of absolute value of T, which is zero or negative. We work
- -- with the negative of the value so that the largest negative number is
- -- not a special case.
-
- ----------------
- -- Set_Digits --
- ----------------
-
- procedure Set_Digits (T : Long_Long_Integer) is
- begin
- if T <= -10 then
- Set_Digits (T / 10);
- P := P + 1;
- S (P) := Character'Val (48 - (T rem 10));
- else
- P := P + 1;
- S (P) := Character'Val (48 - T);
- end if;
- end Set_Digits;
+ begin
+ if T <= -10 then
+ Set_Digits (T / 10, S, P);
+ P := P + 1;
+ S (P) := Character'Val (48 - (T rem 10));
+ else
+ P := P + 1;
+ S (P) := Character'Val (48 - T);
+ end if;
+ end Set_Digits;
- -- Start of processing for Set_Image_Long_Long_Integer
+ ---------------------------------
+ -- Set_Image_Long_Long_Integer --
+ --------------------------------
+ procedure Set_Image_Long_Long_Integer
+ (V : Long_Long_Integer;
+ S : in out String;
+ P : in out Natural) is
begin
if V >= 0 then
- Set_Digits (-V);
+ Set_Digits (-V, S, P);
else
P := P + 1;
S (P) := '-';
- Set_Digits (V);
+ Set_Digits (V, S, P);
end if;
end Set_Image_Long_Long_Integer;
diff --git a/gcc/ada/s-imgllu.adb b/gcc/ada/s-imgllu.adb
index d1e9dd4146..a70908a28c 100644
--- a/gcc/ada/s-imgllu.adb
+++ b/gcc/ada/s-imgllu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -58,30 +58,16 @@ package body System.Img_LLU is
S : in out String;
P : in out Natural)
is
- procedure Set_Digits (T : Long_Long_Unsigned);
- -- Set digits of absolute value of T
-
- ----------------
- -- Set_Digits --
- ----------------
-
- procedure Set_Digits (T : Long_Long_Unsigned) is
- begin
- if T >= 10 then
- Set_Digits (T / 10);
- P := P + 1;
- S (P) := Character'Val (48 + (T rem 10));
-
- else
- P := P + 1;
- S (P) := Character'Val (48 + T);
- end if;
- end Set_Digits;
-
- -- Start of processing for Set_Image_Long_Long_Unsigned
-
begin
- Set_Digits (V);
+ if V >= 10 then
+ Set_Image_Long_Long_Unsigned (V / 10, S, P);
+ P := P + 1;
+ S (P) := Character'Val (48 + (V rem 10));
+
+ else
+ P := P + 1;
+ S (P) := Character'Val (48 + V);
+ end if;
end Set_Image_Long_Long_Unsigned;
end System.Img_LLU;
diff --git a/gcc/ada/s-imgrea.adb b/gcc/ada/s-imgrea.adb
index 3847c54d23..62ec93ad50 100644
--- a/gcc/ada/s-imgrea.adb
+++ b/gcc/ada/s-imgrea.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
diff --git a/gcc/ada/s-imguns.adb b/gcc/ada/s-imguns.adb
index a2cce144c3..c466db3f67 100644
--- a/gcc/ada/s-imguns.adb
+++ b/gcc/ada/s-imguns.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -58,30 +58,16 @@ package body System.Img_Uns is
S : in out String;
P : in out Natural)
is
- procedure Set_Digits (T : Unsigned);
- -- Set decimal digits of value of T
-
- ----------------
- -- Set_Digits --
- ----------------
-
- procedure Set_Digits (T : Unsigned) is
- begin
- if T >= 10 then
- Set_Digits (T / 10);
- P := P + 1;
- S (P) := Character'Val (48 + (T rem 10));
-
- else
- P := P + 1;
- S (P) := Character'Val (48 + T);
- end if;
- end Set_Digits;
-
- -- Start of processing for Set_Image_Unsigned
-
begin
- Set_Digits (V);
+ if V >= 10 then
+ Set_Image_Unsigned (V / 10, S, P);
+ P := P + 1;
+ S (P) := Character'Val (48 + (V rem 10));
+
+ else
+ P := P + 1;
+ S (P) := Character'Val (48 + V);
+ end if;
end Set_Image_Unsigned;
end System.Img_Uns;
diff --git a/gcc/ada/s-interr-hwint.adb b/gcc/ada/s-interr-vxworks.adb
index 8e2950f30f..32fba6008a 100644
--- a/gcc/ada/s-interr-hwint.adb
+++ b/gcc/ada/s-interr-vxworks.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -196,6 +196,22 @@ package body System.Interrupts is
-- be connected but disconnection is not possible on VxWorks. Therefore
-- we ensure Notify_Installed is connected at most once.
+ type Interrupt_Connector is access function
+ (Vector : Interrupt_Vector;
+ Handler : Interrupt_Handler;
+ Parameter : System.Address := System.Null_Address) return int;
+ -- Profile must match VxWorks intConnect()
+
+ Interrupt_Connect : Interrupt_Connector :=
+ System.OS_Interface.Interrupt_Connect'Access;
+ pragma Export (C, Interrupt_Connect, "__gnat_user_int_connect");
+ -- Allow user alternatives to the OS implementation of
+ -- System.OS_Interface.Interrupt_Connect. This allows the user to
+ -- associate a handler with an interrupt source when an alternate routine
+ -- is needed to do so. The association is performed in
+ -- Interfaces.VxWorks.Interrupt_Connections. Defaults to the standard OS
+ -- connection routine.
+
-----------------------
-- Local Subprograms --
-----------------------
@@ -505,11 +521,12 @@ package body System.Interrupts is
-- Only install umbrella handler when no Ada handler has already been
-- installed. Note that the interrupt number is passed as a parameter
-- when an interrupt occurs, so the umbrella handler has a different
- -- wrapper generated by intConnect for each interrupt number.
+ -- wrapper generated by the connector routine for each interrupt
+ -- number.
if not Handler_Installed (Interrupt) then
Status :=
- Interrupt_Connect (Vec, Handler, System.Address (Interrupt));
+ Interrupt_Connect.all (Vec, Handler, System.Address (Interrupt));
pragma Assert (Status = 0);
Handler_Installed (Interrupt) := True;
diff --git a/gcc/ada/s-interr.adb b/gcc/ada/s-interr.adb
index 3c988af5a0..a88b643784 100644
--- a/gcc/ada/s-interr.adb
+++ b/gcc/ada/s-interr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -761,8 +761,8 @@ package body System.Interrupts is
Server := Server_ID (Interrupt);
case Server.Common.State is
- when Interrupt_Server_Idle_Sleep |
- Interrupt_Server_Blocked_Interrupt_Sleep
+ when Interrupt_Server_Blocked_Interrupt_Sleep
+ | Interrupt_Server_Idle_Sleep
=>
POP.Wakeup (Server, Server.Common.State);
@@ -1119,8 +1119,8 @@ package body System.Interrupts is
if User_Handler (Interrupt).H /= null
or else User_Entry (Interrupt).T /= Null_Task
then
- -- This is the case where the Server_Task is
- -- waiting on "sigwait." Wake it up by sending an
+ -- This is the case where the Server_Task
+ -- is waiting on"sigwait." Wake it up by sending an
-- Abort_Task_Interrupt so that the Server_Task waits
-- on Cond.
diff --git a/gcc/ada/s-intman-android.adb b/gcc/ada/s-intman-android.adb
index 30a980e3e3..6c8f0fbe1d 100644
--- a/gcc/ada/s-intman-android.adb
+++ b/gcc/ada/s-intman-android.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2016, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -111,21 +111,15 @@ package body System.Interrupt_Management is
pragma Unreferenced (ucontext);
begin
-
-- Check that treatment of exception propagation here is consistent with
-- treatment of the abort signal in System.Task_Primitives.Operations.
case signo is
- when SIGFPE =>
- raise Constraint_Error;
- when SIGILL =>
- raise Program_Error;
- when SIGSEGV =>
- raise Storage_Error;
- when SIGBUS =>
- raise Storage_Error;
- when others =>
- null;
+ when SIGFPE => raise Constraint_Error;
+ when SIGILL => raise Program_Error;
+ when SIGSEGV => raise Storage_Error;
+ when SIGBUS => raise Storage_Error;
+ when others => null;
end case;
end Map_Signal;
@@ -239,7 +233,7 @@ package body System.Interrupt_Management is
-- Add signals that map to Ada exceptions to the mask
for J in Exception_Interrupts'Range loop
- if State (Exception_Interrupts (J)) /= Default then
+ if State (Exception_Interrupts (J)) /= Default then
Result :=
sigaddset
(Signal_Mask'Access, Signal (Exception_Interrupts (J)));
diff --git a/gcc/ada/s-intman-posix.adb b/gcc/ada/s-intman-posix.adb
index cbe0ea877a..92e7ab156b 100644
--- a/gcc/ada/s-intman-posix.adb
+++ b/gcc/ada/s-intman-posix.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -131,16 +131,11 @@ package body System.Interrupt_Management is
-- treatment of the abort signal in System.Task_Primitives.Operations.
case signo is
- when SIGFPE =>
- raise Constraint_Error;
- when SIGILL =>
- raise Program_Error;
- when SIGSEGV =>
- raise Storage_Error;
- when SIGBUS =>
- raise Storage_Error;
- when others =>
- null;
+ when SIGFPE => raise Constraint_Error;
+ when SIGILL => raise Program_Error;
+ when SIGSEGV => raise Storage_Error;
+ when SIGBUS => raise Storage_Error;
+ when others => null;
end case;
end Notify_Exception;
@@ -202,7 +197,7 @@ package body System.Interrupt_Management is
-- Add signals that map to Ada exceptions to the mask
for J in Exception_Interrupts'Range loop
- if State (Exception_Interrupts (J)) /= Default then
+ if State (Exception_Interrupts (J)) /= Default then
Result :=
sigaddset (Signal_Mask'Access, Signal (Exception_Interrupts (J)));
pragma Assert (Result = 0);
diff --git a/gcc/ada/s-intman-solaris.adb b/gcc/ada/s-intman-solaris.adb
index 170cd82f8d..03366b9018 100644
--- a/gcc/ada/s-intman-solaris.adb
+++ b/gcc/ada/s-intman-solaris.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -92,8 +92,8 @@ package body System.Interrupt_Management is
pragma Unreferenced (info);
begin
- -- Perform the necessary context adjustments prior to a raise
- -- from a signal handler.
+ -- Perform the necessary context adjustments prior to a raise from a
+ -- signal handler.
Adjust_Context_For_Raise (signo, context.all'Address);
@@ -101,16 +101,11 @@ package body System.Interrupt_Management is
-- treatment of the abort signal in System.Task_Primitives.Operations.
case signo is
- when SIGFPE =>
- raise Constraint_Error;
- when SIGILL =>
- raise Program_Error;
- when SIGSEGV =>
- raise Storage_Error;
- when SIGBUS =>
- raise Storage_Error;
- when others =>
- null;
+ when SIGFPE => raise Constraint_Error;
+ when SIGILL => raise Program_Error;
+ when SIGSEGV => raise Storage_Error;
+ when SIGBUS => raise Storage_Error;
+ when others => null;
end case;
end Notify_Exception;
diff --git a/gcc/ada/s-io.adb b/gcc/ada/s-io.adb
index 4925471ff9..d8fd5f51c4 100644
--- a/gcc/ada/s-io.adb
+++ b/gcc/ada/s-io.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -59,10 +59,8 @@ package body System.IO is
begin
case Current_Out is
- when Stdout =>
- Put_Int (X);
- when Stderr =>
- Put_Int_Err (X);
+ when Stdout => Put_Int (X);
+ when Stderr => Put_Int_Err (X);
end case;
end Put;
@@ -75,10 +73,8 @@ package body System.IO is
begin
case Current_Out is
- when Stdout =>
- Put_Char (C);
- when Stderr =>
- Put_Char_Stderr (C);
+ when Stdout => Put_Char (C);
+ when Stderr => Put_Char_Stderr (C);
end case;
end Put;
diff --git a/gcc/ada/s-linux-mipsel.ads b/gcc/ada/s-linux-mips.ads
index 17a3375ccc..6ec4a8b757 100644
--- a/gcc/ada/s-linux-mipsel.ads
+++ b/gcc/ada/s-linux-mips.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2017, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,7 +26,7 @@
-- --
------------------------------------------------------------------------------
--- This is the mipsel version of this package
+-- This is the MIPS version of this package
-- This package encapsulates cpu specific differences between implementations
-- of GNU/Linux, in order to share s-osinte-linux.ads.
@@ -43,6 +43,7 @@ package System.Linux is
-- Time --
----------
+ subtype int is Interfaces.C.int;
subtype long is Interfaces.C.long;
subtype suseconds_t is Interfaces.C.long;
subtype time_t is Interfaces.C.long;
@@ -69,7 +70,7 @@ package System.Linux is
EINVAL : constant := 22;
ENOMEM : constant := 12;
EPERM : constant := 1;
- ETIMEDOUT : constant := 110;
+ ETIMEDOUT : constant := 145;
-------------
-- Signals --
@@ -82,45 +83,52 @@ package System.Linux is
SIGTRAP : constant := 5; -- trace trap (not reset)
SIGIOT : constant := 6; -- IOT instruction
SIGABRT : constant := 6; -- used by abort, replace SIGIOT in the future
+ SIGEMT : constant := 7; -- EMT
SIGFPE : constant := 8; -- floating point exception
SIGKILL : constant := 9; -- kill (cannot be caught or ignored)
- SIGBUS : constant := 7; -- bus error
+ SIGBUS : constant := 10; -- bus error
SIGSEGV : constant := 11; -- segmentation violation
+ SIGSYS : constant := 12; -- bad system call
SIGPIPE : constant := 13; -- write on a pipe with no one to read it
SIGALRM : constant := 14; -- alarm clock
SIGTERM : constant := 15; -- software termination signal from kill
- SIGUSR1 : constant := 10; -- user defined signal 1
- SIGUSR2 : constant := 12; -- user defined signal 2
- SIGCLD : constant := 17; -- alias for SIGCHLD
- SIGCHLD : constant := 17; -- child status change
- SIGPWR : constant := 30; -- power-fail restart
- SIGWINCH : constant := 28; -- window size change
- SIGURG : constant := 23; -- urgent condition on IO channel
- SIGPOLL : constant := 29; -- pollable event occurred
- SIGIO : constant := 29; -- I/O now possible (4.2 BSD)
- SIGLOST : constant := 29; -- File lock lost
- SIGSTOP : constant := 19; -- stop (cannot be caught or ignored)
- SIGTSTP : constant := 20; -- user stop requested from tty
- SIGCONT : constant := 18; -- stopped process has been continued
- SIGTTIN : constant := 21; -- background tty read attempted
- SIGTTOU : constant := 22; -- background tty write attempted
- SIGVTALRM : constant := 26; -- virtual timer expired
- SIGPROF : constant := 27; -- profiling timer expired
- SIGXCPU : constant := 24; -- CPU time limit exceeded
- SIGXFSZ : constant := 25; -- filesize limit exceeded
- SIGUNUSED : constant := 31; -- unused signal (GNU/Linux)
- SIGSTKFLT : constant := 16; -- coprocessor stack fault (Linux)
+ SIGUSR1 : constant := 16; -- user defined signal 1
+ SIGUSR2 : constant := 17; -- user defined signal 2
+ SIGCLD : constant := 18; -- alias for SIGCHLD
+ SIGCHLD : constant := 18; -- child status change
+ SIGPWR : constant := 19; -- power-fail restart
+ SIGWINCH : constant := 20; -- window size change
+ SIGURG : constant := 21; -- urgent condition on IO channel
+ SIGPOLL : constant := 22; -- pollable event occurred
+ SIGIO : constant := 22; -- I/O now possible (4.2 BSD)
+ SIGSTOP : constant := 23; -- stop (cannot be caught or ignored)
+ SIGTSTP : constant := 24; -- user stop requested from tty
+ SIGCONT : constant := 25; -- stopped process has been continued
+ SIGTTIN : constant := 26; -- background tty read attempted
+ SIGTTOU : constant := 27; -- background tty write attempted
+ SIGVTALRM : constant := 28; -- virtual timer expired
+ SIGPROF : constant := 29; -- profiling timer expired
+ SIGXCPU : constant := 30; -- CPU time limit exceeded
+ SIGXFSZ : constant := 31; -- filesize limit exceeded
+
SIGLTHRRES : constant := 32; -- GNU/LinuxThreads restart signal
SIGLTHRCAN : constant := 33; -- GNU/LinuxThreads cancel signal
SIGLTHRDBG : constant := 34; -- GNU/LinuxThreads debugger signal
+ -- These don't exist for Linux/MIPS. The constants are present
+ -- so that we can continue to use a-intnam-linux.ads.
+ SIGLOST : constant := 0; -- File lock lost
+ SIGSTKFLT : constant := 0; -- coprocessor stack fault (Linux)
+ SIGUNUSED : constant := 0; -- unused signal (GNU/Linux)
+
-- struct_sigaction offsets
- sa_handler_pos : constant := Standard'Address_Size / 8;
- sa_mask_pos : constant := 2 * Standard'Address_Size / 8;
+ sa_handler_pos : constant := int'Size / 8;
+ sa_mask_pos : constant := int'Size / 8 +
+ Standard'Address_Size / 8;
sa_flags_pos : constant := 0;
- SA_SIGINFO : constant := 16#04#;
+ SA_SIGINFO : constant := 16#08#;
SA_ONSTACK : constant := 16#08000000#;
end System.Linux;
diff --git a/gcc/ada/s-maccod.ads b/gcc/ada/s-maccod.ads
index a95e319cb9..353cb0586e 100644
--- a/gcc/ada/s-maccod.ads
+++ b/gcc/ada/s-maccod.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -34,6 +34,7 @@
-- for full details.
package System.Machine_Code is
+ pragma No_Elaboration_Code_All;
pragma Pure;
-- All identifiers in this unit are implementation defined
diff --git a/gcc/ada/s-memory.adb b/gcc/ada/s-memory.adb
index b7d37d2688..f419b4716e 100644
--- a/gcc/ada/s-memory.adb
+++ b/gcc/ada/s-memory.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -43,18 +43,16 @@
pragma Compiler_Unit_Warning;
-with Ada.Exceptions;
-with System.Soft_Links;
-with System.Parameters;
with System.CRTL;
+with System.Parameters;
+with System.Soft_Links;
package body System.Memory is
- use Ada.Exceptions;
use System.Soft_Links;
function c_malloc (Size : System.CRTL.size_t) return System.Address
- renames System.CRTL.malloc;
+ renames System.CRTL.malloc;
procedure c_free (Ptr : System.Address)
renames System.CRTL.free;
@@ -68,33 +66,48 @@ package body System.Memory is
-----------
function Alloc (Size : size_t) return System.Address is
- Result : System.Address;
- Actual_Size : size_t := Size;
-
+ Result : System.Address;
begin
- if Size = size_t'Last then
- Raise_Exception (Storage_Error'Identity, "object too large");
- end if;
+ -- A previous version moved the check for size_t'Last below, into the
+ -- "if Result = System.Null_Address...". So malloc(size_t'Last) should
+ -- return Null_Address, and then we can check for that special value.
+ -- However, that doesn't work on VxWorks, because malloc(size_t'Last)
+ -- prints an unwanted warning message before returning Null_Address.
- -- Change size from zero to non-zero. We still want a proper pointer
- -- for the zero case because pointers to zero length objects have to
- -- be distinct, but we can't just go ahead and allocate zero bytes,
- -- since some malloc's return zero for a zero argument.
-
- if Size = 0 then
- Actual_Size := 1;
+ if Size = size_t'Last then
+ raise Storage_Error with "object too large";
end if;
if Parameters.No_Abort then
- Result := c_malloc (System.CRTL.size_t (Actual_Size));
+ Result := c_malloc (System.CRTL.size_t (Size));
else
Abort_Defer.all;
- Result := c_malloc (System.CRTL.size_t (Actual_Size));
+ Result := c_malloc (System.CRTL.size_t (Size));
Abort_Undefer.all;
end if;
if Result = System.Null_Address then
- Raise_Exception (Storage_Error'Identity, "heap exhausted");
+
+ -- If Size = 0, we can't allocate 0 bytes, because then two different
+ -- allocators, one of which has Size = 0, could return pointers that
+ -- compare equal, which is wrong. (Nonnull pointers compare equal if
+ -- and only if they designate the same object, and two different
+ -- allocators allocate two different objects).
+
+ -- malloc(0) is defined to allocate a non-zero-sized object (in which
+ -- case we won't get here, and all is well) or NULL, in which case we
+ -- get here. We also get here in case of error. So check for the
+ -- zero-size case, and allocate 1 byte. Otherwise, raise
+ -- Storage_Error.
+
+ -- We check for zero size here, rather than at the start, for
+ -- efficiency.
+
+ if Size = 0 then
+ return Alloc (1);
+ end if;
+
+ raise Storage_Error with "heap exhausted";
end if;
return Result;
@@ -125,23 +138,21 @@ package body System.Memory is
return System.Address
is
Result : System.Address;
- Actual_Size : constant size_t := Size;
-
begin
if Size = size_t'Last then
- Raise_Exception (Storage_Error'Identity, "object too large");
+ raise Storage_Error with "object too large";
end if;
if Parameters.No_Abort then
- Result := c_realloc (Ptr, System.CRTL.size_t (Actual_Size));
+ Result := c_realloc (Ptr, System.CRTL.size_t (Size));
else
Abort_Defer.all;
- Result := c_realloc (Ptr, System.CRTL.size_t (Actual_Size));
+ Result := c_realloc (Ptr, System.CRTL.size_t (Size));
Abort_Undefer.all;
end if;
if Result = System.Null_Address then
- Raise_Exception (Storage_Error'Identity, "heap exhausted");
+ raise Storage_Error with "heap exhausted";
end if;
return Result;
diff --git a/gcc/ada/s-memory.ads b/gcc/ada/s-memory.ads
index 87a129a690..a8c1251c00 100644
--- a/gcc/ada/s-memory.ads
+++ b/gcc/ada/s-memory.ads
@@ -56,10 +56,10 @@ package System.Memory is
-- memory. The implementation of this routine is guaranteed to be
-- task safe, and also aborts are deferred if necessary.
--
- -- If size_t is set to size_t'Last on entry, then a Storage_Error
+ -- If Size is set to size_t'Last on entry, then a Storage_Error
-- exception is raised with a message "object too large".
--
- -- If size_t is set to zero on entry, then a minimal (but non-zero)
+ -- If Size is set to zero on entry, then a minimal (but non-zero)
-- size block is allocated.
--
-- Note: this is roughly equivalent to the standard C malloc call
@@ -87,10 +87,10 @@ package System.Memory is
-- routine is guaranteed to be task safe, and also aborts are
-- deferred as necessary.
--
- -- If size_t is set to size_t'Last on entry, then a Storage_Error
+ -- If Size is set to size_t'Last on entry, then a Storage_Error
-- exception is raised with a message "object too large".
--
- -- If size_t is set to zero on entry, then a minimal (but non-zero)
+ -- If Size is set to zero on entry, then a minimal (but non-zero)
-- size block is allocated.
--
-- Note: this is roughly equivalent to the standard C realloc call
diff --git a/gcc/ada/s-mmap.adb b/gcc/ada/s-mmap.adb
new file mode 100644
index 0000000000..aee0ebeaad
--- /dev/null
+++ b/gcc/ada/s-mmap.adb
@@ -0,0 +1,576 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . M M A P --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2007-2016, AdaCore --
+-- --
+-- This library is free software; you can redistribute it and/or modify it --
+-- under terms of the GNU General Public License as published by the Free --
+-- Software Foundation; either version 3, or (at your option) any later --
+-- version. This library is distributed in the hope that it will be useful, --
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.IO_Exceptions;
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
+
+with System.Strings; use System.Strings;
+
+with System.Mmap.OS_Interface; use System.Mmap.OS_Interface;
+
+package body System.Mmap is
+
+ type Mapped_File_Record is record
+ Current_Region : Mapped_Region;
+ -- The legacy API enables only one region to be mapped, directly
+ -- associated with the mapped file. This references this region.
+
+ File : System_File;
+ -- Underlying OS-level file
+ end record;
+
+ type Mapped_Region_Record is record
+ File : Mapped_File;
+ -- The file this region comes from. Be careful: for reading file, it is
+ -- valid to have it closed before one of its regions is free'd.
+
+ Write : Boolean;
+ -- Whether the file this region comes from is open for writing.
+
+ Data : Str_Access;
+ -- Unbounded access to the mapped content.
+
+ System_Offset : File_Size;
+ -- Position in the file of the first byte actually mapped in memory
+
+ User_Offset : File_Size;
+ -- Position in the file of the first byte requested by the user
+
+ System_Size : File_Size;
+ -- Size of the region actually mapped in memory
+
+ User_Size : File_Size;
+ -- Size of the region requested by the user
+
+ Mapped : Boolean;
+ -- Whether this region is actually memory mapped
+
+ Mutable : Boolean;
+ -- If the file is opened for reading, wheter this region is writable
+
+ Buffer : System.Strings.String_Access;
+ -- When this region is not actually memory mapped, contains the
+ -- requested bytes.
+
+ Mapping : System_Mapping;
+ -- Underlying OS-level data for the mapping, if any
+ end record;
+
+ Invalid_Mapped_Region_Record : constant Mapped_Region_Record :=
+ (null, False, null, 0, 0, 0, 0, False, False, null,
+ Invalid_System_Mapping);
+ Invalid_Mapped_File_Record : constant Mapped_File_Record :=
+ (Invalid_Mapped_Region, Invalid_System_File);
+
+ Empty_String : constant String := "";
+ -- Used to provide a valid empty Data for empty files, for instanc.
+
+ procedure Dispose is new Ada.Unchecked_Deallocation
+ (Mapped_File_Record, Mapped_File);
+ procedure Dispose is new Ada.Unchecked_Deallocation
+ (Mapped_Region_Record, Mapped_Region);
+
+ function Convert is new Ada.Unchecked_Conversion
+ (Standard.System.Address, Str_Access);
+
+ procedure Compute_Data (Region : Mapped_Region);
+ -- Fill the Data field according to system and user offsets. The region
+ -- must actually be mapped or bufferized.
+
+ procedure From_Disk (Region : Mapped_Region);
+ -- Read a region of some file from the disk
+
+ procedure To_Disk (Region : Mapped_Region);
+ -- Write the region of the file back to disk if necessary, and free memory
+
+ ----------------------------
+ -- Open_Read_No_Exception --
+ ----------------------------
+
+ function Open_Read_No_Exception
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return Mapped_File
+ is
+ File : constant System_File :=
+ Open_Read (Filename, Use_Mmap_If_Available);
+ begin
+ if File = Invalid_System_File then
+ return Invalid_Mapped_File;
+ end if;
+
+ return new Mapped_File_Record'
+ (Current_Region => Invalid_Mapped_Region,
+ File => File);
+ end Open_Read_No_Exception;
+
+ ---------------
+ -- Open_Read --
+ ---------------
+
+ function Open_Read
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return Mapped_File
+ is
+ Res : constant Mapped_File :=
+ Open_Read_No_Exception (Filename, Use_Mmap_If_Available);
+ begin
+ if Res = Invalid_Mapped_File then
+ raise Ada.IO_Exceptions.Name_Error
+ with "Cannot open " & Filename;
+ else
+ return Res;
+ end if;
+ end Open_Read;
+
+ ----------------
+ -- Open_Write --
+ ----------------
+
+ function Open_Write
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return Mapped_File
+ is
+ File : constant System_File :=
+ Open_Write (Filename, Use_Mmap_If_Available);
+ begin
+ if File = Invalid_System_File then
+ raise Ada.IO_Exceptions.Name_Error
+ with "Cannot open " & Filename;
+ else
+ return new Mapped_File_Record'
+ (Current_Region => Invalid_Mapped_Region,
+ File => File);
+ end if;
+ end Open_Write;
+
+ -----------
+ -- Close --
+ -----------
+
+ procedure Close (File : in out Mapped_File) is
+ begin
+ -- Closing a closed file is allowed and should do nothing
+
+ if File = Invalid_Mapped_File then
+ return;
+ end if;
+
+ if File.Current_Region /= null then
+ Free (File.Current_Region);
+ end if;
+
+ if File.File /= Invalid_System_File then
+ Close (File.File);
+ end if;
+
+ Dispose (File);
+ end Close;
+
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free (Region : in out Mapped_Region) is
+ Ignored : Integer;
+ pragma Unreferenced (Ignored);
+ begin
+ -- Freeing an already free'd file is allowed and should do nothing
+
+ if Region = Invalid_Mapped_Region then
+ return;
+ end if;
+
+ if Region.Mapping /= Invalid_System_Mapping then
+ Dispose_Mapping (Region.Mapping);
+ end if;
+ To_Disk (Region);
+ Dispose (Region);
+ end Free;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (File : Mapped_File;
+ Region : in out Mapped_Region;
+ Offset : File_Size := 0;
+ Length : File_Size := 0;
+ Mutable : Boolean := False)
+ is
+ File_Length : constant File_Size := Mmap.Length (File);
+
+ Req_Offset : constant File_Size := Offset;
+ Req_Length : File_Size := Length;
+ -- Offset and Length of the region to map, used to adjust mapping
+ -- bounds, reflecting what the user will see.
+
+ Region_Allocated : Boolean := False;
+ begin
+ -- If this region comes from another file, or simply if the file is
+ -- writeable, we cannot re-use this mapping: free it first.
+
+ if Region /= Invalid_Mapped_Region
+ and then
+ (Region.File /= File or else File.File.Write)
+ then
+ Free (Region);
+ end if;
+
+ if Region = Invalid_Mapped_Region then
+ Region := new Mapped_Region_Record'(Invalid_Mapped_Region_Record);
+ Region_Allocated := True;
+ end if;
+
+ Region.File := File;
+
+ if Req_Offset >= File_Length then
+ -- If the requested offset goes beyond file size, map nothing
+
+ Req_Length := 0;
+
+ elsif Length = 0
+ or else
+ Length > File_Length - Req_Offset
+ then
+ -- If Length is 0 or goes beyond file size, map till end of file
+
+ Req_Length := File_Length - Req_Offset;
+
+ else
+ Req_Length := Length;
+ end if;
+
+ -- Past this point, the offset/length the user will see is fixed. On the
+ -- other hand, the system offset/length is either already defined, from
+ -- a previous mapping, or it is set to 0. In the latter case, the next
+ -- step will set them according to the mapping.
+
+ Region.User_Offset := Req_Offset;
+ Region.User_Size := Req_Length;
+
+ -- If the requested region is inside an already mapped region, adjust
+ -- user-requested data and do nothing else.
+
+ if (File.File.Write or else Region.Mutable = Mutable)
+ and then
+ Req_Offset >= Region.System_Offset
+ and then
+ (Req_Offset + Req_Length
+ <= Region.System_Offset + Region.System_Size)
+ then
+ Region.User_Offset := Req_Offset;
+ Compute_Data (Region);
+ return;
+
+ elsif Region.Buffer /= null then
+ -- Otherwise, as we are not going to re-use the buffer, free it
+
+ System.Strings.Free (Region.Buffer);
+ Region.Buffer := null;
+
+ elsif Region.Mapping /= Invalid_System_Mapping then
+ -- Otherwise, there is a memory mapping that we need to unmap.
+ Dispose_Mapping (Region.Mapping);
+ end if;
+
+ -- mmap() will sometimes return NULL when the file exists but is empty,
+ -- which is not what we want, so in the case of a zero length file we
+ -- fall back to read(2)/write(2)-based mode.
+
+ if File_Length > 0 and then File.File.Mapped then
+
+ Region.System_Offset := Req_Offset;
+ Region.System_Size := Req_Length;
+ Create_Mapping
+ (File.File,
+ Region.System_Offset, Region.System_Size,
+ Mutable,
+ Region.Mapping);
+ Region.Mapped := True;
+ Region.Mutable := Mutable;
+
+ else
+ -- There is no alignment requirement when manually reading the file.
+
+ Region.System_Offset := Req_Offset;
+ Region.System_Size := Req_Length;
+ Region.Mapped := False;
+ Region.Mutable := True;
+ From_Disk (Region);
+ end if;
+
+ Region.Write := File.File.Write;
+ Compute_Data (Region);
+
+ exception
+ when others =>
+ -- Before propagating any exception, free any region we allocated
+ -- here.
+
+ if Region_Allocated then
+ Dispose (Region);
+ end if;
+ raise;
+ end Read;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (File : Mapped_File;
+ Offset : File_Size := 0;
+ Length : File_Size := 0;
+ Mutable : Boolean := False)
+ is
+ begin
+ Read (File, File.Current_Region, Offset, Length, Mutable);
+ end Read;
+
+ ----------
+ -- Read --
+ ----------
+
+ function Read
+ (File : Mapped_File;
+ Offset : File_Size := 0;
+ Length : File_Size := 0;
+ Mutable : Boolean := False) return Mapped_Region
+ is
+ Region : Mapped_Region := Invalid_Mapped_Region;
+ begin
+ Read (File, Region, Offset, Length, Mutable);
+ return Region;
+ end Read;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length (File : Mapped_File) return File_Size is
+ begin
+ return File.File.Length;
+ end Length;
+
+ ------------
+ -- Offset --
+ ------------
+
+ function Offset (Region : Mapped_Region) return File_Size is
+ begin
+ return Region.User_Offset;
+ end Offset;
+
+ ------------
+ -- Offset --
+ ------------
+
+ function Offset (File : Mapped_File) return File_Size is
+ begin
+ return Offset (File.Current_Region);
+ end Offset;
+
+ ----------
+ -- Last --
+ ----------
+
+ function Last (Region : Mapped_Region) return Integer is
+ begin
+ return Integer (Region.User_Size);
+ end Last;
+
+ ----------
+ -- Last --
+ ----------
+
+ function Last (File : Mapped_File) return Integer is
+ begin
+ return Last (File.Current_Region);
+ end Last;
+
+ -------------------
+ -- To_Str_Access --
+ -------------------
+
+ function To_Str_Access
+ (Str : System.Strings.String_Access) return Str_Access is
+ begin
+ if Str = null then
+ return null;
+ else
+ return Convert (Str.all'Address);
+ end if;
+ end To_Str_Access;
+
+ ----------
+ -- Data --
+ ----------
+
+ function Data (Region : Mapped_Region) return Str_Access is
+ begin
+ return Region.Data;
+ end Data;
+
+ ----------
+ -- Data --
+ ----------
+
+ function Data (File : Mapped_File) return Str_Access is
+ begin
+ return Data (File.Current_Region);
+ end Data;
+
+ ----------------
+ -- Is_Mutable --
+ ----------------
+
+ function Is_Mutable (Region : Mapped_Region) return Boolean is
+ begin
+ return Region.Mutable or Region.Write;
+ end Is_Mutable;
+
+ ----------------
+ -- Is_Mmapped --
+ ----------------
+
+ function Is_Mmapped (File : Mapped_File) return Boolean is
+ begin
+ return File.File.Mapped;
+ end Is_Mmapped;
+
+ -------------------
+ -- Get_Page_Size --
+ -------------------
+
+ function Get_Page_Size return Integer is
+ Result : constant File_Size := Get_Page_Size;
+ begin
+ return Integer (Result);
+ end Get_Page_Size;
+
+ ---------------------
+ -- Read_Whole_File --
+ ---------------------
+
+ function Read_Whole_File
+ (Filename : String;
+ Empty_If_Not_Found : Boolean := False)
+ return System.Strings.String_Access
+ is
+ File : Mapped_File := Open_Read (Filename);
+ Region : Mapped_Region renames File.Current_Region;
+ Result : String_Access;
+ begin
+ Read (File);
+
+ if Region.Data /= null then
+ Result := new String'(String
+ (Region.Data (1 .. Last (Region))));
+
+ elsif Region.Buffer /= null then
+ Result := Region.Buffer;
+ Region.Buffer := null; -- So that it is not deallocated
+ end if;
+
+ Close (File);
+
+ return Result;
+
+ exception
+ when Ada.IO_Exceptions.Name_Error =>
+ if Empty_If_Not_Found then
+ return new String'("");
+ else
+ return null;
+ end if;
+
+ when others =>
+ Close (File);
+ return null;
+ end Read_Whole_File;
+
+ ---------------
+ -- From_Disk --
+ ---------------
+
+ procedure From_Disk (Region : Mapped_Region) is
+ begin
+ pragma Assert (Region.File.all /= Invalid_Mapped_File_Record);
+ pragma Assert (Region.Buffer = null);
+
+ Region.Buffer := Read_From_Disk
+ (Region.File.File, Region.User_Offset, Region.User_Size);
+ Region.Mapped := False;
+ end From_Disk;
+
+ -------------
+ -- To_Disk --
+ -------------
+
+ procedure To_Disk (Region : Mapped_Region) is
+ begin
+ if Region.Write and then Region.Buffer /= null then
+ pragma Assert (Region.File.all /= Invalid_Mapped_File_Record);
+ Write_To_Disk
+ (Region.File.File,
+ Region.User_Offset, Region.User_Size,
+ Region.Buffer);
+ end if;
+
+ System.Strings.Free (Region.Buffer);
+ Region.Buffer := null;
+ end To_Disk;
+
+ ------------------
+ -- Compute_Data --
+ ------------------
+
+ procedure Compute_Data (Region : Mapped_Region) is
+ Base_Data : Str_Access;
+ -- Address of the first byte actually mapped in memory
+
+ Data_Shift : constant Integer :=
+ Integer (Region.User_Offset - Region.System_Offset);
+ begin
+ if Region.User_Size = 0 then
+ Region.Data := Convert (Empty_String'Address);
+ return;
+ elsif Region.Mapped then
+ Base_Data := Convert (Region.Mapping.Address);
+ else
+ Base_Data := Convert (Region.Buffer.all'Address);
+ end if;
+ Region.Data := Convert (Base_Data (Data_Shift + 1)'Address);
+ end Compute_Data;
+
+end System.Mmap;
diff --git a/gcc/ada/s-mmap.ads b/gcc/ada/s-mmap.ads
new file mode 100644
index 0000000000..00b080b02d
--- /dev/null
+++ b/gcc/ada/s-mmap.ads
@@ -0,0 +1,281 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . M M A P --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2007-2016, AdaCore --
+-- --
+-- This library is free software; you can redistribute it and/or modify it --
+-- under terms of the GNU General Public License as published by the Free --
+-- Software Foundation; either version 3, or (at your option) any later --
+-- version. This library is distributed in the hope that it will be useful, --
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- This package provides memory mapping of files. Depending on your operating
+-- system, this might provide a more efficient method for accessing the
+-- contents of files.
+-- A description of memory-mapping is available on the sqlite page, at:
+-- http://www.sqlite.org/mmap.html
+--
+-- The traditional method for reading a file is to allocate a buffer in the
+-- application address space, then open the file and copy its contents. When
+-- memory mapping is available though, the application asks the operating
+-- system to return a pointer to the requested page, if possible. If the
+-- requested page has been or can be mapped into the application address
+-- space, the system returns a pointer to that page for the application to
+-- use without having to copy anything. Skipping the copy step is what makes
+-- memory mapped I/O faster.
+--
+-- When memory mapping is not available, this package automatically falls
+-- back to the traditional copy method.
+--
+-- Example of use for this package, when reading a file that can be fully
+-- mapped
+--
+-- declare
+-- File : Mapped_File;
+-- Str : Str_Access;
+-- begin
+-- File := Open_Read ("/tmp/file_on_disk");
+-- Read (File); -- read the whole file
+-- Str := Data (File);
+-- for S in 1 .. Last (File) loop
+-- Put (Str (S));
+-- end loop;
+-- Close (File);
+-- end;
+--
+-- When the file is big, or you only want to access part of it at a given
+-- time, you can use the following type of code.
+
+-- declare
+-- File : Mapped_File;
+-- Str : Str_Access;
+-- Offs : File_Size := 0;
+-- Page : constant Integer := Get_Page_Size;
+-- begin
+-- File := Open_Read ("/tmp/file_on_disk");
+-- while Offs < Length (File) loop
+-- Read (File, Offs, Length => Long_Integer (Page) * 4);
+-- Str := Data (File);
+--
+-- -- Print characters for this chunk:
+-- for S in Integer (Offs - Offset (File)) + 1 .. Last (File) loop
+-- Put (Str (S));
+-- end loop;
+--
+-- -- Since we are reading multiples of Get_Page_Size, we can simplify
+-- -- with
+-- -- for S in 1 .. Last (File) loop ...
+--
+-- Offs := Offs + Long_Integer (Last (File));
+-- end loop;
+
+with Interfaces.C;
+
+with System.Strings;
+
+package System.Mmap is
+
+ type Mapped_File is private;
+ -- File to be mapped in memory.
+
+ -- This package will use the fastest possible algorithm to load the
+ -- file in memory. On systems that support it, the file is not really
+ -- loaded in memory. Instead, a call to the mmap() system call (or
+ -- CreateFileMapping()) will keep the file on disk, but make it
+ -- accessible as if it was in memory.
+
+ -- When the system does not support it, the file is actually loaded in
+ -- memory through calls to read(), and written back with write() when you
+ -- close it. This is of course much slower.
+
+ -- Legacy: each mapped file has a "default" mapped region in it.
+
+ type Mapped_Region is private;
+ -- A representation of part of a file in memory. Actual reading/writing
+ -- is done through a mapped region. After being returned by Read, a mapped
+ -- region must be free'd when done. If the original Mapped_File was open
+ -- for reading, it can be closed before the mapped region is free'd.
+
+ Invalid_Mapped_File : constant Mapped_File;
+ Invalid_Mapped_Region : constant Mapped_Region;
+
+ type Unconstrained_String is new String (Positive);
+ type Str_Access is access all Unconstrained_String;
+ pragma No_Strict_Aliasing (Str_Access);
+
+ type File_Size is new Interfaces.C.size_t;
+
+ function To_Str_Access
+ (Str : System.Strings.String_Access) return Str_Access;
+ -- Convert Str. The returned value points to the same memory block, but no
+ -- longer includes the bounds, which you need to manage yourself
+
+ function Open_Read
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return Mapped_File;
+ -- Open a file for reading. The same file can be shared by multiple
+ -- processes, that will see each others's changes as they occur.
+ -- Any attempt to write the data might result in a segmentation fault,
+ -- depending on how the file is open.
+ -- Name_Error is raised if the file does not exist.
+ -- Filename should be compatible with the filesystem.
+
+ function Open_Read_No_Exception
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return Mapped_File;
+ -- Like Open_Read but return Invalid_Mapped_File in case of error
+
+ function Open_Write
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return Mapped_File;
+ -- Open a file for writing.
+ -- You cannot change the length of the file.
+ -- Name_Error is raised if the file does not exist
+ -- Filename should be compatible with the filesystem.
+
+ procedure Close (File : in out Mapped_File);
+ -- Close the file, and unmap the memory that is used for the region
+ -- contained in File. If the system does not support the unmmap() system
+ -- call or equivalent, or these were not available for the file itself,
+ -- then the file is written back to the disk if it was opened for writing.
+
+ procedure Free (Region : in out Mapped_Region);
+ -- Unmap the memory that is used for this region and deallocate the region
+
+ procedure Read
+ (File : Mapped_File;
+ Region : in out Mapped_Region;
+ Offset : File_Size := 0;
+ Length : File_Size := 0;
+ Mutable : Boolean := False);
+ -- Read a specific part of File and set Region to the corresponding mapped
+ -- region, or re-use it if possible.
+ -- Offset is the number of bytes since the beginning of the file at which
+ -- we should start reading. Length is the number of bytes that should be
+ -- read. If set to 0, as much of the file as possible is read (presumably
+ -- the whole file unless you are reading a _huge_ file).
+ -- Note that no (un)mapping is is done if that part of the file is already
+ -- available through Region.
+ -- If the file was opened for writing, any modification you do to the
+ -- data stored in File will be stored on disk (either immediately when the
+ -- file is opened through a mmap() system call, or when the file is closed
+ -- otherwise).
+ -- Mutable is processed only for reading files. If set to True, the
+ -- data can be modified, even through it will not be carried through the
+ -- underlying file, nor it is guaranteed to be carried through remapping.
+ -- This function takes care of page size alignment issues. The accessors
+ -- below only expose the region that has been requested by this call, even
+ -- if more bytes were actually mapped by this function.
+ -- TODO??? Enable to have a private copy for readable files
+
+ function Read
+ (File : Mapped_File;
+ Offset : File_Size := 0;
+ Length : File_Size := 0;
+ Mutable : Boolean := False) return Mapped_Region;
+ -- Likewise, return a new mapped region
+
+ procedure Read
+ (File : Mapped_File;
+ Offset : File_Size := 0;
+ Length : File_Size := 0;
+ Mutable : Boolean := False);
+ -- Likewise, use the legacy "default" region in File
+
+ function Length (File : Mapped_File) return File_Size;
+ -- Size of the file on the disk
+
+ function Offset (Region : Mapped_Region) return File_Size;
+ -- Return the offset, in the physical file on disk, corresponding to the
+ -- requested mapped region. The first byte in the file has offest 0.
+
+ function Offset (File : Mapped_File) return File_Size;
+ -- Likewise for the region contained in File
+
+ function Last (Region : Mapped_Region) return Integer;
+ -- Return the number of requested bytes mapped in this region. It is
+ -- erroneous to access Data for indices outside 1 .. Last (Region).
+ -- Such accesses may cause Storage_Error to be raised.
+
+ function Last (File : Mapped_File) return Integer;
+ -- Return the number of requested bytes mapped in the region contained in
+ -- File. It is erroneous to access Data for indices outside of 1 .. Last
+ -- (File); such accesses may cause Storage_Error to be raised.
+
+ function Data (Region : Mapped_Region) return Str_Access;
+ -- The data mapped in Region as requested. The result is an unconstrained
+ -- string, so you cannot use the usual 'First and 'Last attributes.
+ -- Instead, these are respectively 1 and Size.
+
+ function Data (File : Mapped_File) return Str_Access;
+ -- Likewise for the region contained in File
+
+ function Is_Mutable (Region : Mapped_Region) return Boolean;
+ -- Return whether it is safe to change bytes in Data (Region). This is true
+ -- for regions from writeable files, for regions mapped with the "Mutable"
+ -- flag set, and for regions that are copied in a buffer. Note that it is
+ -- not specified whether empty regions are mutable or not, since there is
+ -- no byte no modify.
+
+ function Is_Mmapped (File : Mapped_File) return Boolean;
+ -- Whether regions for this file are opened through an mmap() system call
+ -- or equivalent. This is in general irrelevant to your application, unless
+ -- the file can be accessed by multiple concurrent processes or tasks. In
+ -- such a case, and if the file is indeed mmap-ed, then the various parts
+ -- of the file can be written simulatenously, and thus you cannot ensure
+ -- the integrity of the file. If the file is not mmapped, the latest
+ -- process to Close it overwrite what other processes have done.
+
+ function Get_Page_Size return Integer;
+ -- Returns the number of bytes in a page. Once a file is mapped from the
+ -- disk, its offset and Length should be multiples of this page size (which
+ -- is ensured by this package in any case). Knowing this page size allows
+ -- you to map as much memory as possible at once, thus potentially reducing
+ -- the number of system calls to read the file by chunks.
+
+ function Read_Whole_File
+ (Filename : String;
+ Empty_If_Not_Found : Boolean := False)
+ return System.Strings.String_Access;
+ -- Returns the whole contents of the file.
+ -- The returned string must be freed by the user.
+ -- This is a convenience function, which is of course slower than the ones
+ -- above since we also need to allocate some memory, actually read the file
+ -- and copy the bytes.
+ -- If the file does not exist, null is returned. However, if
+ -- Empty_If_Not_Found is True, then the empty string is returned instead.
+ -- Filename should be compatible with the filesystem.
+
+private
+ pragma Inline (Data, Length, Last, Offset, Is_Mmapped, To_Str_Access);
+
+ type Mapped_File_Record;
+ type Mapped_File is access Mapped_File_Record;
+
+ type Mapped_Region_Record;
+ type Mapped_Region is access Mapped_Region_Record;
+
+ Invalid_Mapped_File : constant Mapped_File := null;
+ Invalid_Mapped_Region : constant Mapped_Region := null;
+
+end System.Mmap;
diff --git a/gcc/ada/s-mmauni-long.ads b/gcc/ada/s-mmauni-long.ads
new file mode 100644
index 0000000000..f7fa0bda6f
--- /dev/null
+++ b/gcc/ada/s-mmauni-long.ads
@@ -0,0 +1,69 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . M M A P . U N I X --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2007-2016, AdaCore --
+-- --
+-- This library is free software; you can redistribute it and/or modify it --
+-- under terms of the GNU General Public License as published by the Free --
+-- Software Foundation; either version 3, or (at your option) any later --
+-- version. This library is distributed in the hope that it will be useful, --
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- Declaration of off_t/mmap/munmap. This particular implementation
+-- supposes off_t is long.
+
+with System.OS_Lib;
+with Interfaces.C;
+
+package System.Mmap.Unix is
+
+ type Mmap_Prot is new Interfaces.C.int;
+-- PROT_NONE : constant Mmap_Prot := 16#00#;
+-- PROT_EXEC : constant Mmap_Prot := 16#04#;
+ PROT_READ : constant Mmap_Prot := 16#01#;
+ PROT_WRITE : constant Mmap_Prot := 16#02#;
+
+ type Mmap_Flags is new Interfaces.C.int;
+-- MAP_NONE : constant Mmap_Flags := 16#00#;
+-- MAP_FIXED : constant Mmap_Flags := 16#10#;
+ MAP_SHARED : constant Mmap_Flags := 16#01#;
+ MAP_PRIVATE : constant Mmap_Flags := 16#02#;
+
+ type off_t is new Long_Integer;
+
+ function Mmap (Start : Address := Null_Address;
+ Length : Interfaces.C.size_t;
+ Prot : Mmap_Prot := PROT_READ;
+ Flags : Mmap_Flags := MAP_PRIVATE;
+ Fd : System.OS_Lib.File_Descriptor;
+ Offset : off_t) return Address;
+ pragma Import (C, Mmap, "mmap");
+
+ function Munmap (Start : Address;
+ Length : Interfaces.C.size_t) return Integer;
+ pragma Import (C, Munmap, "munmap");
+
+ function Is_Mapping_Available return Boolean is (True);
+ -- Wheter memory mapping is actually available on this system. It is an
+ -- error to use Create_Mapping and Dispose_Mapping if this is False.
+end System.Mmap.Unix;
diff --git a/gcc/ada/s-mmosin-mingw.adb b/gcc/ada/s-mmosin-mingw.adb
new file mode 100644
index 0000000000..b850630d53
--- /dev/null
+++ b/gcc/ada/s-mmosin-mingw.adb
@@ -0,0 +1,345 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . M M A P . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2007-2016, AdaCore --
+-- --
+-- This library is free software; you can redistribute it and/or modify it --
+-- under terms of the GNU General Public License as published by the Free --
+-- Software Foundation; either version 3, or (at your option) any later --
+-- version. This library is distributed in the hope that it will be useful, --
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.IO_Exceptions;
+with System.Strings; use System.Strings;
+
+with System.OS_Lib;
+pragma Unreferenced (System.OS_Lib);
+-- Only used to generate same runtime dependencies and same binder file on
+-- GNU/Linux and Windows.
+
+package body System.Mmap.OS_Interface is
+
+ use Win;
+
+ function Align
+ (Addr : File_Size) return File_Size;
+ -- Align some offset/length to the lowest page boundary
+
+ function Open_Common
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean;
+ Write : Boolean) return System_File;
+
+ function From_UTF8 (Path : String) return Wide_String;
+ -- Convert from UTF-8 to Wide_String
+
+ ---------------
+ -- From_UTF8 --
+ ---------------
+
+ function From_UTF8 (Path : String) return Wide_String is
+ function MultiByteToWideChar
+ (Codepage : Interfaces.C.unsigned;
+ Flags : Interfaces.C.unsigned;
+ Mbstr : Address;
+ Mb : Natural;
+ Wcstr : Address;
+ Wc : Natural) return Integer;
+ pragma Import (Stdcall, MultiByteToWideChar, "MultiByteToWideChar");
+
+ Current_Codepage : Interfaces.C.unsigned;
+ pragma Import (C, Current_Codepage, "__gnat_current_codepage");
+
+ Len : Natural;
+ begin
+ -- Compute length of the result
+ Len := MultiByteToWideChar
+ (Current_Codepage, 0, Path'Address, Path'Length, Null_Address, 0);
+ if Len = 0 then
+ raise Constraint_Error;
+ end if;
+
+ declare
+ -- Declare result
+ Res : Wide_String (1 .. Len);
+ begin
+ -- And compute it
+ Len := MultiByteToWideChar
+ (Current_Codepage, 0,
+ Path'Address, Path'Length,
+ Res'Address, Len);
+ if Len = 0 then
+ raise Constraint_Error;
+ end if;
+ return Res;
+ end;
+ end From_UTF8;
+
+ -----------------
+ -- Open_Common --
+ -----------------
+
+ function Open_Common
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean;
+ Write : Boolean) return System_File
+ is
+ dwDesiredAccess, dwShareMode : DWORD;
+ PageFlags : DWORD;
+
+ W_Filename : constant Wide_String :=
+ From_UTF8 (Filename) & Wide_Character'Val (0);
+ File_Handle, Mapping_Handle : HANDLE;
+
+ SizeH : aliased DWORD;
+ Size : File_Size;
+ begin
+ if Write then
+ dwDesiredAccess := GENERIC_READ + GENERIC_WRITE;
+ dwShareMode := 0;
+ PageFlags := Win.PAGE_READWRITE;
+ else
+ dwDesiredAccess := GENERIC_READ;
+ dwShareMode := Win.FILE_SHARE_READ;
+ PageFlags := Win.PAGE_READONLY;
+ end if;
+
+ -- Actually open the file
+
+ File_Handle := CreateFile
+ (W_Filename'Address, dwDesiredAccess, dwShareMode,
+ null, OPEN_EXISTING, Win.FILE_ATTRIBUTE_NORMAL, 0);
+
+ if File_Handle = Win.INVALID_HANDLE_VALUE then
+ return Invalid_System_File;
+ end if;
+
+ -- Compute its size
+
+ Size := File_Size (Win.GetFileSize (File_Handle, SizeH'Access));
+
+ if Size = Win.INVALID_FILE_SIZE then
+ return Invalid_System_File;
+ end if;
+
+ if SizeH /= 0 and then File_Size'Size > 32 then
+ Size := Size + (File_Size (SizeH) * 2 ** 32);
+ end if;
+
+ -- Then create a mapping object, if needed. On Win32, file memory
+ -- mapping is always available.
+
+ if Use_Mmap_If_Available then
+ Mapping_Handle :=
+ Win.CreateFileMapping
+ (File_Handle, null, PageFlags,
+ 0, DWORD (Size), Standard.System.Null_Address);
+ else
+ Mapping_Handle := Win.INVALID_HANDLE_VALUE;
+ end if;
+
+ return
+ (Handle => File_Handle,
+ Mapped => Use_Mmap_If_Available,
+ Mapping_Handle => Mapping_Handle,
+ Write => Write,
+ Length => Size);
+ end Open_Common;
+
+ ---------------
+ -- Open_Read --
+ ---------------
+
+ function Open_Read
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return System_File is
+ begin
+ return Open_Common (Filename, Use_Mmap_If_Available, False);
+ end Open_Read;
+
+ ----------------
+ -- Open_Write --
+ ----------------
+
+ function Open_Write
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return System_File is
+ begin
+ return Open_Common (Filename, Use_Mmap_If_Available, True);
+ end Open_Write;
+
+ -----------
+ -- Close --
+ -----------
+
+ procedure Close (File : in out System_File) is
+ Ignored : BOOL;
+ pragma Unreferenced (Ignored);
+ begin
+ Ignored := CloseHandle (File.Mapping_Handle);
+ Ignored := CloseHandle (File.Handle);
+ File.Handle := Win.INVALID_HANDLE_VALUE;
+ File.Mapping_Handle := Win.INVALID_HANDLE_VALUE;
+ end Close;
+
+ --------------------
+ -- Read_From_Disk --
+ --------------------
+
+ function Read_From_Disk
+ (File : System_File;
+ Offset, Length : File_Size) return System.Strings.String_Access
+ is
+ Buffer : String_Access := new String (1 .. Integer (Length));
+
+ Pos : DWORD;
+ NbRead : aliased DWORD;
+ pragma Unreferenced (Pos);
+ begin
+ Pos := Win.SetFilePointer
+ (File.Handle, LONG (Offset), null, Win.FILE_BEGIN);
+
+ if Win.ReadFile
+ (File.Handle, Buffer.all'Address,
+ DWORD (Length), NbRead'Unchecked_Access, null) = Win.FALSE
+ then
+ System.Strings.Free (Buffer);
+ raise Ada.IO_Exceptions.Device_Error;
+ end if;
+ return Buffer;
+ end Read_From_Disk;
+
+ -------------------
+ -- Write_To_Disk --
+ -------------------
+
+ procedure Write_To_Disk
+ (File : System_File;
+ Offset, Length : File_Size;
+ Buffer : System.Strings.String_Access)
+ is
+ Pos : DWORD;
+ NbWritten : aliased DWORD;
+ pragma Unreferenced (Pos);
+ begin
+ pragma Assert (File.Write);
+ Pos := Win.SetFilePointer
+ (File.Handle, LONG (Offset), null, Win.FILE_BEGIN);
+
+ if Win.WriteFile
+ (File.Handle, Buffer.all'Address,
+ DWORD (Length), NbWritten'Unchecked_Access, null) = Win.FALSE
+ then
+ raise Ada.IO_Exceptions.Device_Error;
+ end if;
+ end Write_To_Disk;
+
+ --------------------
+ -- Create_Mapping --
+ --------------------
+
+ procedure Create_Mapping
+ (File : System_File;
+ Offset, Length : in out File_Size;
+ Mutable : Boolean;
+ Mapping : out System_Mapping)
+ is
+ Flags : DWORD;
+ begin
+ if File.Write then
+ Flags := Win.FILE_MAP_WRITE;
+ elsif Mutable then
+ Flags := Win.FILE_MAP_COPY;
+ else
+ Flags := Win.FILE_MAP_READ;
+ end if;
+
+ -- Adjust offset and mapping length to account for the required
+ -- alignment of offset on page boundary.
+
+ declare
+ Queried_Offset : constant File_Size := Offset;
+ begin
+ Offset := Align (Offset);
+
+ -- First extend the length to compensate the offset shift, then align
+ -- it on the upper page boundary, so that the whole queried area is
+ -- covered.
+
+ Length := Length + Queried_Offset - Offset;
+ Length := Align (Length + Get_Page_Size - 1);
+
+ -- But do not exceed the length of the file
+ if Offset + Length > File.Length then
+ Length := File.Length - Offset;
+ end if;
+ end;
+
+ if Length > File_Size (Integer'Last) then
+ raise Ada.IO_Exceptions.Device_Error;
+ else
+ Mapping := Invalid_System_Mapping;
+ Mapping.Address :=
+ Win.MapViewOfFile
+ (File.Mapping_Handle, Flags,
+ 0, DWORD (Offset), SIZE_T (Length));
+ Mapping.Length := Length;
+ end if;
+ end Create_Mapping;
+
+ ---------------------
+ -- Dispose_Mapping --
+ ---------------------
+
+ procedure Dispose_Mapping
+ (Mapping : in out System_Mapping)
+ is
+ Ignored : BOOL;
+ pragma Unreferenced (Ignored);
+ begin
+ Ignored := Win.UnmapViewOfFile (Mapping.Address);
+ Mapping := Invalid_System_Mapping;
+ end Dispose_Mapping;
+
+ -------------------
+ -- Get_Page_Size --
+ -------------------
+
+ function Get_Page_Size return File_Size is
+ SystemInfo : aliased SYSTEM_INFO;
+ begin
+ GetSystemInfo (SystemInfo'Unchecked_Access);
+ return File_Size (SystemInfo.dwAllocationGranularity);
+ end Get_Page_Size;
+
+ -----------
+ -- Align --
+ -----------
+
+ function Align
+ (Addr : File_Size) return File_Size is
+ begin
+ return Addr - Addr mod Get_Page_Size;
+ end Align;
+
+end System.Mmap.OS_Interface;
diff --git a/gcc/ada/s-mmosin-mingw.ads b/gcc/ada/s-mmosin-mingw.ads
new file mode 100644
index 0000000000..ad296c1c5d
--- /dev/null
+++ b/gcc/ada/s-mmosin-mingw.ads
@@ -0,0 +1,235 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . M M A P . O S _ I N T E R F A C E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2007-2016, AdaCore --
+-- --
+-- This library is free software; you can redistribute it and/or modify it --
+-- under terms of the GNU General Public License as published by the Free --
+-- Software Foundation; either version 3, or (at your option) any later --
+-- version. This library is distributed in the hope that it will be useful, --
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+-- OS pecularities abstraction package for Win32 systems.
+
+package System.Mmap.OS_Interface is
+
+ -- The Win package contains copy of definition found in recent System.Win32
+ -- unit provided with the GNAT compiler. The copy is needed to be able to
+ -- compile this unit with older compilers. Note that this internal Win
+ -- package can be removed when GNAT 6.1.0 is not supported anymore.
+
+ package Win is
+
+ subtype PVOID is Standard.System.Address;
+
+ type HANDLE is new Interfaces.C.ptrdiff_t;
+
+ type WORD is new Interfaces.C.unsigned_short;
+ type DWORD is new Interfaces.C.unsigned_long;
+ type LONG is new Interfaces.C.long;
+ type SIZE_T is new Interfaces.C.size_t;
+
+ type BOOL is new Interfaces.C.int;
+ for BOOL'Size use Interfaces.C.int'Size;
+
+ FALSE : constant := 0;
+
+ GENERIC_READ : constant := 16#80000000#;
+ GENERIC_WRITE : constant := 16#40000000#;
+ OPEN_EXISTING : constant := 3;
+
+ type OVERLAPPED is record
+ Internal : DWORD;
+ InternalHigh : DWORD;
+ Offset : DWORD;
+ OffsetHigh : DWORD;
+ hEvent : HANDLE;
+ end record;
+
+ type SECURITY_ATTRIBUTES is record
+ nLength : DWORD;
+ pSecurityDescriptor : PVOID;
+ bInheritHandle : BOOL;
+ end record;
+
+ type SYSTEM_INFO is record
+ dwOemId : DWORD;
+ dwPageSize : DWORD;
+ lpMinimumApplicationAddress : PVOID;
+ lpMaximumApplicationAddress : PVOID;
+ dwActiveProcessorMask : PVOID;
+ dwNumberOfProcessors : DWORD;
+ dwProcessorType : DWORD;
+ dwAllocationGranularity : DWORD;
+ wProcessorLevel : WORD;
+ wProcessorRevision : WORD;
+ end record;
+ type LP_SYSTEM_INFO is access all SYSTEM_INFO;
+
+ INVALID_HANDLE_VALUE : constant HANDLE := -1;
+ FILE_BEGIN : constant := 0;
+ FILE_SHARE_READ : constant := 16#00000001#;
+ FILE_ATTRIBUTE_NORMAL : constant := 16#00000080#;
+ FILE_MAP_COPY : constant := 1;
+ FILE_MAP_READ : constant := 4;
+ FILE_MAP_WRITE : constant := 2;
+ PAGE_READONLY : constant := 16#0002#;
+ PAGE_READWRITE : constant := 16#0004#;
+ INVALID_FILE_SIZE : constant := 16#FFFFFFFF#;
+
+ function CreateFile
+ (lpFileName : Standard.System.Address;
+ dwDesiredAccess : DWORD;
+ dwShareMode : DWORD;
+ lpSecurityAttributes : access SECURITY_ATTRIBUTES;
+ dwCreationDisposition : DWORD;
+ dwFlagsAndAttributes : DWORD;
+ hTemplateFile : HANDLE) return HANDLE;
+ pragma Import (Stdcall, CreateFile, "CreateFileW");
+
+ function WriteFile
+ (hFile : HANDLE;
+ lpBuffer : Standard.System.Address;
+ nNumberOfBytesToWrite : DWORD;
+ lpNumberOfBytesWritten : access DWORD;
+ lpOverlapped : access OVERLAPPED) return BOOL;
+ pragma Import (Stdcall, WriteFile, "WriteFile");
+
+ function ReadFile
+ (hFile : HANDLE;
+ lpBuffer : Standard.System.Address;
+ nNumberOfBytesToRead : DWORD;
+ lpNumberOfBytesRead : access DWORD;
+ lpOverlapped : access OVERLAPPED) return BOOL;
+ pragma Import (Stdcall, ReadFile, "ReadFile");
+
+ function CloseHandle (hObject : HANDLE) return BOOL;
+ pragma Import (Stdcall, CloseHandle, "CloseHandle");
+
+ function GetFileSize
+ (hFile : HANDLE; lpFileSizeHigh : access DWORD) return DWORD;
+ pragma Import (Stdcall, GetFileSize, "GetFileSize");
+
+ function SetFilePointer
+ (hFile : HANDLE;
+ lDistanceToMove : LONG;
+ lpDistanceToMoveHigh : access LONG;
+ dwMoveMethod : DWORD) return DWORD;
+ pragma Import (Stdcall, SetFilePointer, "SetFilePointer");
+
+ function CreateFileMapping
+ (hFile : HANDLE;
+ lpSecurityAttributes : access SECURITY_ATTRIBUTES;
+ flProtect : DWORD;
+ dwMaximumSizeHigh : DWORD;
+ dwMaximumSizeLow : DWORD;
+ lpName : Standard.System.Address) return HANDLE;
+ pragma Import (Stdcall, CreateFileMapping, "CreateFileMappingW");
+
+ function MapViewOfFile
+ (hFileMappingObject : HANDLE;
+ dwDesiredAccess : DWORD;
+ dwFileOffsetHigh : DWORD;
+ dwFileOffsetLow : DWORD;
+ dwNumberOfBytesToMap : SIZE_T) return Standard.System.Address;
+ pragma Import (Stdcall, MapViewOfFile, "MapViewOfFile");
+
+ function UnmapViewOfFile
+ (lpBaseAddress : Standard.System.Address) return BOOL;
+ pragma Import (Stdcall, UnmapViewOfFile, "UnmapViewOfFile");
+
+ procedure GetSystemInfo (lpSystemInfo : LP_SYSTEM_INFO);
+ pragma Import (Stdcall, GetSystemInfo, "GetSystemInfo");
+
+ end Win;
+
+ type System_File is record
+ Handle : Win.HANDLE;
+
+ Mapped : Boolean;
+ -- Whether mapping is requested by the user and available on the system
+
+ Mapping_Handle : Win.HANDLE;
+
+ Write : Boolean;
+ -- Whether this file can be written to
+
+ Length : File_Size;
+ -- Length of the file. Used to know what can be mapped in the file
+ end record;
+
+ type System_Mapping is record
+ Address : Standard.System.Address;
+ Length : File_Size;
+ end record;
+
+ Invalid_System_File : constant System_File :=
+ (Win.INVALID_HANDLE_VALUE, False, Win.INVALID_HANDLE_VALUE, False, 0);
+ Invalid_System_Mapping : constant System_Mapping :=
+ (Standard.System.Null_Address, 0);
+
+ function Open_Read
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return System_File;
+ -- Open a file for reading and return the corresponding System_File. Return
+ -- Invalid_System_File if unsuccessful.
+
+ function Open_Write
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return System_File;
+ -- Likewise for writing to a file
+
+ procedure Close (File : in out System_File);
+ -- Close a system file
+
+ function Read_From_Disk
+ (File : System_File;
+ Offset, Length : File_Size) return System.Strings.String_Access;
+ -- Read a fragment of a file. It is up to the caller to free the result
+ -- when done with it.
+
+ procedure Write_To_Disk
+ (File : System_File;
+ Offset, Length : File_Size;
+ Buffer : System.Strings.String_Access);
+ -- Write some content to a fragment of a file
+
+ procedure Create_Mapping
+ (File : System_File;
+ Offset, Length : in out File_Size;
+ Mutable : Boolean;
+ Mapping : out System_Mapping);
+ -- Create a memory mapping for the given File, for the area starting at
+ -- Offset and containing Length bytes. Store it to Mapping.
+ -- Note that Offset and Length may be modified according to the system
+ -- needs (for boudaries, for instance). The caller must cope with actually
+ -- wider mapped areas.
+
+ procedure Dispose_Mapping
+ (Mapping : in out System_Mapping);
+ -- Unmap a previously-created mapping
+
+ function Get_Page_Size return File_Size;
+ -- Return the number of bytes in a system page.
+
+end System.Mmap.OS_Interface;
diff --git a/gcc/ada/s-mmosin-unix.adb b/gcc/ada/s-mmosin-unix.adb
new file mode 100644
index 0000000000..634d980cb2
--- /dev/null
+++ b/gcc/ada/s-mmosin-unix.adb
@@ -0,0 +1,229 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . M M A P . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2007-2016, AdaCore --
+-- --
+-- This library is free software; you can redistribute it and/or modify it --
+-- under terms of the GNU General Public License as published by the Free --
+-- Software Foundation; either version 3, or (at your option) any later --
+-- version. This library is distributed in the hope that it will be useful, --
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.IO_Exceptions;
+with System; use System;
+
+with System.OS_Lib; use System.OS_Lib;
+with System.Mmap.Unix; use System.Mmap.Unix;
+
+package body System.Mmap.OS_Interface is
+
+ function Align
+ (Addr : File_Size) return File_Size;
+ -- Align some offset/length to the lowest page boundary
+
+ function Is_Mapping_Available return Boolean renames
+ System.Mmap.Unix.Is_Mapping_Available;
+ -- Wheter memory mapping is actually available on this system. It is an
+ -- error to use Create_Mapping and Dispose_Mapping if this is False.
+
+ ---------------
+ -- Open_Read --
+ ---------------
+
+ function Open_Read
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return System_File is
+ Fd : constant File_Descriptor :=
+ Open_Read (Filename, Binary);
+ begin
+ if Fd = Invalid_FD then
+ return Invalid_System_File;
+ end if;
+ return
+ (Fd => Fd,
+ Mapped => Use_Mmap_If_Available and then Is_Mapping_Available,
+ Write => False,
+ Length => File_Size (File_Length (Fd)));
+ end Open_Read;
+
+ ----------------
+ -- Open_Write --
+ ----------------
+
+ function Open_Write
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return System_File is
+ Fd : constant File_Descriptor :=
+ Open_Read_Write (Filename, Binary);
+ begin
+ if Fd = Invalid_FD then
+ return Invalid_System_File;
+ end if;
+ return
+ (Fd => Fd,
+ Mapped => Use_Mmap_If_Available and then Is_Mapping_Available,
+ Write => True,
+ Length => File_Size (File_Length (Fd)));
+ end Open_Write;
+
+ -----------
+ -- Close --
+ -----------
+
+ procedure Close (File : in out System_File) is
+ begin
+ Close (File.Fd);
+ File.Fd := Invalid_FD;
+ end Close;
+
+ --------------------
+ -- Read_From_Disk --
+ --------------------
+
+ function Read_From_Disk
+ (File : System_File;
+ Offset, Length : File_Size) return System.Strings.String_Access
+ is
+ Buffer : String_Access := new String (1 .. Integer (Length));
+ begin
+ -- ??? Lseek offset should be a size_t instead of a Long_Integer
+
+ Lseek (File.Fd, Long_Integer (Offset), Seek_Set);
+ if System.OS_Lib.Read (File.Fd, Buffer.all'Address, Integer (Length))
+ /= Integer (Length)
+ then
+ System.Strings.Free (Buffer);
+ raise Ada.IO_Exceptions.Device_Error;
+ end if;
+ return Buffer;
+ end Read_From_Disk;
+
+ -------------------
+ -- Write_To_Disk --
+ -------------------
+
+ procedure Write_To_Disk
+ (File : System_File;
+ Offset, Length : File_Size;
+ Buffer : System.Strings.String_Access) is
+ begin
+ pragma Assert (File.Write);
+ Lseek (File.Fd, Long_Integer (Offset), Seek_Set);
+ if System.OS_Lib.Write (File.Fd, Buffer.all'Address, Integer (Length))
+ /= Integer (Length)
+ then
+ raise Ada.IO_Exceptions.Device_Error;
+ end if;
+ end Write_To_Disk;
+
+ --------------------
+ -- Create_Mapping --
+ --------------------
+
+ procedure Create_Mapping
+ (File : System_File;
+ Offset, Length : in out File_Size;
+ Mutable : Boolean;
+ Mapping : out System_Mapping)
+ is
+ Prot : Mmap_Prot;
+ Flags : Mmap_Flags;
+ begin
+ if File.Write then
+ Prot := PROT_READ + PROT_WRITE;
+ Flags := MAP_SHARED;
+ else
+ Prot := PROT_READ;
+ if Mutable then
+ Prot := Prot + PROT_WRITE;
+ end if;
+ Flags := MAP_PRIVATE;
+ end if;
+
+ -- Adjust offset and mapping length to account for the required
+ -- alignment of offset on page boundary.
+
+ declare
+ Queried_Offset : constant File_Size := Offset;
+ begin
+ Offset := Align (Offset);
+
+ -- First extend the length to compensate the offset shift, then align
+ -- it on the upper page boundary, so that the whole queried area is
+ -- covered.
+
+ Length := Length + Queried_Offset - Offset;
+ Length := Align (Length + Get_Page_Size - 1);
+ end;
+
+ if Length > File_Size (Integer'Last) then
+ raise Ada.IO_Exceptions.Device_Error;
+ else
+ Mapping :=
+ (Address => System.Mmap.Unix.Mmap
+ (Offset => off_t (Offset),
+ Length => Interfaces.C.size_t (Length),
+ Prot => Prot,
+ Flags => Flags,
+ Fd => File.Fd),
+ Length => Length);
+ end if;
+ end Create_Mapping;
+
+ ---------------------
+ -- Dispose_Mapping --
+ ---------------------
+
+ procedure Dispose_Mapping
+ (Mapping : in out System_Mapping)
+ is
+ Ignored : Integer;
+ pragma Unreferenced (Ignored);
+ begin
+ Ignored := Munmap
+ (Mapping.Address, Interfaces.C.size_t (Mapping.Length));
+ Mapping := Invalid_System_Mapping;
+ end Dispose_Mapping;
+
+ -------------------
+ -- Get_Page_Size --
+ -------------------
+
+ function Get_Page_Size return File_Size is
+ function Internal return Integer;
+ pragma Import (C, Internal, "getpagesize");
+ begin
+ return File_Size (Internal);
+ end Get_Page_Size;
+
+ -----------
+ -- Align --
+ -----------
+
+ function Align
+ (Addr : File_Size) return File_Size is
+ begin
+ return Addr - Addr mod Get_Page_Size;
+ end Align;
+
+end System.Mmap.OS_Interface;
diff --git a/gcc/ada/s-mmosin-unix.ads b/gcc/ada/s-mmosin-unix.ads
new file mode 100644
index 0000000000..002bf77435
--- /dev/null
+++ b/gcc/ada/s-mmosin-unix.ads
@@ -0,0 +1,105 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . M M A P . O S _ I N T E R F A C E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2007-2016, AdaCore --
+-- --
+-- This library is free software; you can redistribute it and/or modify it --
+-- under terms of the GNU General Public License as published by the Free --
+-- Software Foundation; either version 3, or (at your option) any later --
+-- version. This library is distributed in the hope that it will be useful, --
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
+-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
+-- --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception, --
+-- version 3.1, as published by the Free Software Foundation. --
+-- --
+-- You should have received a copy of the GNU General Public License and --
+-- a copy of the GCC Runtime Library Exception along with this program; --
+-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
+-- <http://www.gnu.org/licenses/>. --
+-- --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
+-- --
+------------------------------------------------------------------------------
+
+with System.OS_Lib;
+
+-- OS pecularities abstraction package for Unix systems.
+
+package System.Mmap.OS_Interface is
+
+ type System_File is record
+ Fd : System.OS_Lib.File_Descriptor;
+
+ Mapped : Boolean;
+ -- Whether mapping is requested by the user and available on the system
+
+ Write : Boolean;
+ -- Whether this file can be written to
+
+ Length : File_Size;
+ -- Length of the file. Used to know what can be mapped in the file
+ end record;
+
+ type System_Mapping is record
+ Address : Standard.System.Address;
+ Length : File_Size;
+ end record;
+
+ Invalid_System_File : constant System_File :=
+ (System.OS_Lib.Invalid_FD, False, False, 0);
+ Invalid_System_Mapping : constant System_Mapping :=
+ (Standard.System.Null_Address, 0);
+
+ function Open_Read
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return System_File;
+ -- Open a file for reading and return the corresponding System_File. Return
+ -- Invalid_System_File if unsuccessful.
+
+ function Open_Write
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return System_File;
+ -- Likewise for writing to a file
+
+ procedure Close (File : in out System_File);
+ -- Close a system file
+
+ function Read_From_Disk
+ (File : System_File;
+ Offset, Length : File_Size) return System.Strings.String_Access;
+ -- Read a fragment of a file. It is up to the caller to free the result
+ -- when done with it.
+
+ procedure Write_To_Disk
+ (File : System_File;
+ Offset, Length : File_Size;
+ Buffer : System.Strings.String_Access);
+ -- Write some content to a fragment of a file
+
+ procedure Create_Mapping
+ (File : System_File;
+ Offset, Length : in out File_Size;
+ Mutable : Boolean;
+ Mapping : out System_Mapping);
+ -- Create a memory mapping for the given File, for the area starting at
+ -- Offset and containing Length bytes. Store it to Mapping.
+ -- Note that Offset and Length may be modified according to the system
+ -- needs (for boudaries, for instance). The caller must cope with actually
+ -- wider mapped areas.
+
+ procedure Dispose_Mapping
+ (Mapping : in out System_Mapping);
+ -- Unmap a previously-created mapping
+
+ function Get_Page_Size return File_Size;
+ -- Return the number of bytes in a system page.
+
+end System.Mmap.OS_Interface;
diff --git a/gcc/ada/s-os_lib.adb b/gcc/ada/s-os_lib.adb
index 15f1fa7572..36064e97bd 100644
--- a/gcc/ada/s-os_lib.adb
+++ b/gcc/ada/s-os_lib.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1995-2015, AdaCore --
+-- Copyright (C) 1995-2016, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -511,7 +511,6 @@ package body System.OS_Lib is
when None =>
null;
end case;
-
end Copy_To;
-- Start of processing for Copy_File
@@ -622,6 +621,7 @@ package body System.OS_Lib is
Ada_Pathname : String_Access :=
To_Path_String_Access
(Pathname, C_String_Length (Pathname));
+
begin
Copy_File (Ada_Name.all, Ada_Pathname.all, Success, Mode, Preserve);
Free (Ada_Name);
@@ -639,9 +639,10 @@ package body System.OS_Lib is
Copy_Timestamp : Boolean := True;
Copy_Permissions : Boolean := True)
is
- F : aliased String (1 .. From'Length + 1);
+ F : aliased String (1 .. From'Length + 1);
+ T : aliased String (1 .. To'Length + 1);
+
Mode : Integer;
- T : aliased String (1 .. To'Length + 1);
begin
if Copy_Timestamp then
@@ -713,6 +714,7 @@ package body System.OS_Lib is
Ada_Dest : String_Access :=
To_Path_String_Access
(Dest, C_String_Length (Dest));
+
begin
Copy_Time_Stamps (Ada_Source.all, Ada_Dest.all, Success);
Free (Ada_Source);
@@ -1495,24 +1497,40 @@ package body System.OS_Lib is
return Is_Directory (F_Name'Address);
end Is_Directory;
- ----------------------
- -- Is_Readable_File --
- ----------------------
+ -----------------------------
+ -- Is_Read_Accessible_File --
+ -----------------------------
+
+ function Is_Read_Accessible_File (Name : String) return Boolean is
+ function Is_Read_Accessible_File (Name : Address) return Integer;
+ pragma Import
+ (C, Is_Read_Accessible_File, "__gnat_is_read_accessible_file");
+ F_Name : String (1 .. Name'Length + 1);
+
+ begin
+ F_Name (1 .. Name'Length) := Name;
+ F_Name (F_Name'Last) := ASCII.NUL;
+ return Is_Read_Accessible_File (F_Name'Address) /= 0;
+ end Is_Read_Accessible_File;
- function Is_Readable_File (Name : C_File_Name) return Boolean is
+ ----------------------------
+ -- Is_Owner_Readable_File --
+ ----------------------------
+
+ function Is_Owner_Readable_File (Name : C_File_Name) return Boolean is
function Is_Readable_File (Name : Address) return Integer;
pragma Import (C, Is_Readable_File, "__gnat_is_readable_file");
begin
return Is_Readable_File (Name) /= 0;
- end Is_Readable_File;
+ end Is_Owner_Readable_File;
- function Is_Readable_File (Name : String) return Boolean is
+ function Is_Owner_Readable_File (Name : String) return Boolean is
F_Name : String (1 .. Name'Length + 1);
begin
F_Name (1 .. Name'Length) := Name;
F_Name (F_Name'Last) := ASCII.NUL;
- return Is_Readable_File (F_Name'Address);
- end Is_Readable_File;
+ return Is_Owner_Readable_File (F_Name'Address);
+ end Is_Owner_Readable_File;
------------------------
-- Is_Executable_File --
@@ -1571,24 +1589,40 @@ package body System.OS_Lib is
return Is_Symbolic_Link (F_Name'Address);
end Is_Symbolic_Link;
- ----------------------
- -- Is_Writable_File --
- ----------------------
+ ------------------------------
+ -- Is_Write_Accessible_File --
+ ------------------------------
- function Is_Writable_File (Name : C_File_Name) return Boolean is
+ function Is_Write_Accessible_File (Name : String) return Boolean is
+ function Is_Write_Accessible_File (Name : Address) return Integer;
+ pragma Import
+ (C, Is_Write_Accessible_File, "__gnat_is_write_accessible_file");
+ F_Name : String (1 .. Name'Length + 1);
+
+ begin
+ F_Name (1 .. Name'Length) := Name;
+ F_Name (F_Name'Last) := ASCII.NUL;
+ return Is_Write_Accessible_File (F_Name'Address) /= 0;
+ end Is_Write_Accessible_File;
+
+ ----------------------------
+ -- Is_Owner_Writable_File --
+ ----------------------------
+
+ function Is_Owner_Writable_File (Name : C_File_Name) return Boolean is
function Is_Writable_File (Name : Address) return Integer;
pragma Import (C, Is_Writable_File, "__gnat_is_writable_file");
begin
return Is_Writable_File (Name) /= 0;
- end Is_Writable_File;
+ end Is_Owner_Writable_File;
- function Is_Writable_File (Name : String) return Boolean is
+ function Is_Owner_Writable_File (Name : String) return Boolean is
F_Name : String (1 .. Name'Length + 1);
begin
F_Name (1 .. Name'Length) := Name;
F_Name (F_Name'Last) := ASCII.NUL;
- return Is_Writable_File (F_Name'Address);
- end Is_Writable_File;
+ return Is_Owner_Writable_File (F_Name'Address);
+ end Is_Owner_Writable_File;
----------
-- Kill --
@@ -1819,8 +1853,8 @@ package body System.OS_Lib is
else
Result :=
- Non_Blocking_Spawn
- (Program_Name, Args, Output_File_Descriptor, Err_To_Out);
+ Non_Blocking_Spawn
+ (Program_Name, Args, Output_File_Descriptor, Err_To_Out);
-- Close the file just created for the output, as the file descriptor
-- cannot be used anywhere, being a local value. It is safe to do
@@ -1848,6 +1882,8 @@ package body System.OS_Lib is
Saved_Error : File_Descriptor;
Saved_Output : File_Descriptor;
+ Dummy_Status : Boolean;
+
begin
-- Do not attempt to spawn if the output files could not be created
@@ -1863,6 +1899,17 @@ package body System.OS_Lib is
Saved_Error := Dup (Standerr);
Dup2 (Stderr_FD, Standerr);
+ Set_Close_On_Exec (Saved_Output, True, Dummy_Status);
+ Set_Close_On_Exec (Saved_Error, True, Dummy_Status);
+
+ -- Close the files just created for the output, as the file descriptors
+ -- cannot be used anywhere, being local values. It is safe to do that,
+ -- as the file descriptors have been duplicated to form standard output
+ -- and standard error of the spawned process.
+
+ Close (Stdout_FD);
+ Close (Stderr_FD);
+
-- Spawn the program
Result := Non_Blocking_Spawn (Program_Name, Args);
@@ -2013,7 +2060,7 @@ package body System.OS_Lib is
function Readlink
(Path : System.Address;
Buf : System.Address;
- Bufsiz : Integer) return Integer;
+ Bufsiz : size_t) return Integer;
pragma Import (C, Readlink, "__gnat_readlink");
function To_Canonical_File_Spec
@@ -2585,6 +2632,7 @@ package body System.OS_Lib is
function rename (From, To : Address) return Integer;
pragma Import (C, rename, "__gnat_rename");
R : Integer;
+
begin
R := rename (Old_Name, New_Name);
Success := (R = 0);
@@ -2597,6 +2645,7 @@ package body System.OS_Lib is
is
C_Old_Name : String (1 .. Old_Name'Length + 1);
C_New_Name : String (1 .. New_Name'Length + 1);
+
begin
C_Old_Name (1 .. Old_Name'Length) := Old_Name;
C_Old_Name (C_Old_Name'Last) := ASCII.NUL;
@@ -2630,6 +2679,7 @@ package body System.OS_Lib is
procedure C_Set_Executable (Name : C_File_Name; Mode : Integer);
pragma Import (C, C_Set_Executable, "__gnat_set_executable");
C_Name : aliased String (Name'First .. Name'Last + 1);
+
begin
C_Name (Name'Range) := Name;
C_Name (C_Name'Last) := ASCII.NUL;
@@ -2644,6 +2694,7 @@ package body System.OS_Lib is
procedure C_Set_File_Time (Name : C_File_Name; Time : OS_Time);
pragma Import (C, C_Set_File_Time, "__gnat_set_file_time_name");
C_Name : aliased String (Name'First .. Name'Last + 1);
+
begin
C_Name (Name'Range) := Name;
C_Name (C_Name'Last) := ASCII.NUL;
@@ -2658,6 +2709,7 @@ package body System.OS_Lib is
procedure C_Set_Non_Readable (Name : C_File_Name);
pragma Import (C, C_Set_Non_Readable, "__gnat_set_non_readable");
C_Name : aliased String (Name'First .. Name'Last + 1);
+
begin
C_Name (Name'Range) := Name;
C_Name (C_Name'Last) := ASCII.NUL;
@@ -2672,6 +2724,7 @@ package body System.OS_Lib is
procedure C_Set_Non_Writable (Name : C_File_Name);
pragma Import (C, C_Set_Non_Writable, "__gnat_set_non_writable");
C_Name : aliased String (Name'First .. Name'Last + 1);
+
begin
C_Name (Name'Range) := Name;
C_Name (C_Name'Last) := ASCII.NUL;
@@ -2686,6 +2739,7 @@ package body System.OS_Lib is
procedure C_Set_Readable (Name : C_File_Name);
pragma Import (C, C_Set_Readable, "__gnat_set_readable");
C_Name : aliased String (Name'First .. Name'Last + 1);
+
begin
C_Name (Name'Range) := Name;
C_Name (C_Name'Last) := ASCII.NUL;
@@ -2700,6 +2754,7 @@ package body System.OS_Lib is
procedure C_Set_Writable (Name : C_File_Name);
pragma Import (C, C_Set_Writable, "__gnat_set_writable");
C_Name : aliased String (Name'First .. Name'Last + 1);
+
begin
C_Name (Name'Range) := Name;
C_Name (C_Name'Last) := ASCII.NUL;
@@ -2846,8 +2901,8 @@ package body System.OS_Lib is
type Chars is array (Positive range <>) of aliased Character;
type Char_Ptr is access constant Character;
- Command_Len : constant Positive := Program_Name'Length + 1 +
- Args_Length (Args);
+ Command_Len : constant Positive :=
+ Program_Name'Length + 1 + Args_Length (Args);
Command_Last : Natural := 0;
Command : aliased Chars (1 .. Command_Len);
-- Command contains all characters of the Program_Name and Args, all
diff --git a/gcc/ada/s-os_lib.ads b/gcc/ada/s-os_lib.ads
index 985f492ebe..21f9ec5556 100644
--- a/gcc/ada/s-os_lib.ads
+++ b/gcc/ada/s-os_lib.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1995-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -375,7 +375,7 @@ package System.OS_Lib is
function File_Time_Stamp (Name : String) return OS_Time;
-- Given the name of a file or directory, Name, obtains and returns the
-- time stamp. This function can be used for an unopened file. Returns
- -- Invalid_Time is Name doesn't correspond to an existing file.
+ -- Invalid_Time if Name doesn't correspond to an existing file.
function File_Time_Stamp (FD : File_Descriptor) return OS_Time;
-- Get time stamp of file from file descriptor FD Returns Invalid_Time is
@@ -425,7 +425,7 @@ package System.OS_Lib is
-- not actually be readable due to some other process having exclusive
-- access.
- function Is_Readable_File (Name : String) return Boolean;
+ function Is_Owner_Readable_File (Name : String) return Boolean;
-- Determines if the given string, Name, is the name of an existing file
-- that is readable. Returns True if so, False otherwise. Note that this
-- function simply interrogates the file attributes (e.g. using the C
@@ -449,14 +449,30 @@ package System.OS_Lib is
-- contains the name of the file to which it is linked. Symbolic links may
-- span file systems and may refer to directories.
- function Is_Writable_File (Name : String) return Boolean;
+ function Is_Owner_Writable_File (Name : String) return Boolean;
-- Determines if the given string, Name, is the name of an existing file
-- that is writable. Returns True if so, False otherwise. Note that this
-- function simply interrogates the file attributes (e.g. using the C
-- function stat), so it does not indicate a situation in which a file may
- -- not actually be writeable due to some other process having exclusive
+ -- not actually be writable due to some other process having exclusive
-- access.
+ function Is_Read_Accessible_File (Name : String) return Boolean;
+ -- Determines if the given string, Name, is the name of an existing file
+ -- that is readable. Returns True if so, False otherwise.
+
+ function Is_Write_Accessible_File (Name : String) return Boolean;
+ -- Determines if the given string, Name, is the name of an existing file
+ -- that is writable. Returns True if so, False otherwise.
+
+ function Is_Readable_File (Name : String) return Boolean
+ renames Is_Read_Accessible_File;
+ function Is_Writable_File (Name : String) return Boolean
+ renames Is_Write_Accessible_File;
+ -- These subprograms provided for backward compatibility and should not be
+ -- used. Use Is_Owner_Readable_File/Is_Owner_Writable_File or
+ -- Is_Read_Accessible_File/Is_Write_Accessible_File instead.
+
function Locate_Exec_On_Path (Exec_Name : String) return String_Access;
-- Try to locate an executable whose name is given by Exec_Name in the
-- directories listed in the environment Path. If the Exec_Name does not
@@ -646,8 +662,6 @@ package System.OS_Lib is
-- This subtype is used to document that a parameter is the address of a
-- null-terminated string containing the name of a file.
- -- All the following functions need comments ???
-
procedure Copy_File
(Name : C_File_Name;
Pathname : C_File_Name;
@@ -671,14 +685,13 @@ package System.OS_Lib is
procedure Delete_File (Name : C_File_Name; Success : out Boolean);
function File_Time_Stamp (Name : C_File_Name) return OS_Time;
- -- Returns Invalid_Time is Name doesn't correspond to an existing file
function Is_Directory (Name : C_File_Name) return Boolean;
function Is_Executable_File (Name : C_File_Name) return Boolean;
- function Is_Readable_File (Name : C_File_Name) return Boolean;
+ function Is_Owner_Readable_File (Name : C_File_Name) return Boolean;
function Is_Regular_File (Name : C_File_Name) return Boolean;
function Is_Symbolic_Link (Name : C_File_Name) return Boolean;
- function Is_Writable_File (Name : C_File_Name) return Boolean;
+ function Is_Owner_Writable_File (Name : C_File_Name) return Boolean;
function Locate_Regular_File
(File_Name : C_File_Name;
@@ -723,6 +736,10 @@ package System.OS_Lib is
Invalid_Pid : constant Process_Id;
-- A special value used to indicate errors, as described below
+ function Current_Process_Id return Process_Id;
+ -- Returns the current process id or Invalid_Pid if not supported by the
+ -- runtime.
+
function Argument_String_To_List
(Arg_String : String) return Argument_List_Access;
-- Take a string that is a program and its arguments and parse it into an
@@ -1060,6 +1077,7 @@ private
pragma Import (C, Path_Separator, "__gnat_path_separator");
pragma Import (C, Directory_Separator, "__gnat_dir_separator");
pragma Import (C, Current_Time, "__gnat_current_time");
+ pragma Import (C, Current_Process_Id, "__gnat_current_process_id");
type OS_Time is
range -(2 ** (Standard'Address_Size - Integer'(1))) ..
diff --git a/gcc/ada/s-oscons-tmplt.c b/gcc/ada/s-oscons-tmplt.c
index d1b522d670..26140170f4 100644
--- a/gcc/ada/s-oscons-tmplt.c
+++ b/gcc/ada/s-oscons-tmplt.c
@@ -7,7 +7,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2000-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2000-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1264,6 +1264,11 @@ CND(SO_RCVTIMEO, "Reception timeout")
#endif
CND(SO_ERROR, "Get/clear error status")
+#ifndef SO_BUSY_POLL
+# define SO_BUSY_POLL -1
+#endif
+CND(SO_BUSY_POLL, "Busy polling")
+
#ifndef IP_MULTICAST_IF
# define IP_MULTICAST_IF -1
#endif
diff --git a/gcc/ada/s-osinte-darwin.adb b/gcc/ada/s-osinte-darwin.adb
index 315f796f6f..4998e8359a 100644
--- a/gcc/ada/s-osinte-darwin.adb
+++ b/gcc/ada/s-osinte-darwin.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2015, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -172,17 +172,6 @@ package body System.OS_Interface is
return 0;
end sched_yield;
- --------------
- -- lwp_self --
- --------------
-
- function lwp_self return Address is
- function pthread_mach_thread_np (thread : pthread_t) return Address;
- pragma Import (C, pthread_mach_thread_np, "pthread_mach_thread_np");
- begin
- return pthread_mach_thread_np (pthread_self);
- end lwp_self;
-
------------------
-- pthread_init --
------------------
diff --git a/gcc/ada/s-osinte-darwin.ads b/gcc/ada/s-osinte-darwin.ads
index 0dbbdfe059..946373c2f2 100644
--- a/gcc/ada/s-osinte-darwin.ads
+++ b/gcc/ada/s-osinte-darwin.ads
@@ -228,6 +228,7 @@ package System.OS_Interface is
---------
function lwp_self return System.Address;
+ pragma Import (C, lwp_self, "__gnat_lwp_self");
-- Return the mach thread bound to the current thread. The value is not
-- used by the run-time library but made available to debuggers.
diff --git a/gcc/ada/s-osinte-linux.ads b/gcc/ada/s-osinte-linux.ads
index 2bcf56e500..b0ba229639 100644
--- a/gcc/ada/s-osinte-linux.ads
+++ b/gcc/ada/s-osinte-linux.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -182,7 +182,7 @@ package System.OS_Interface is
type struct_sigaction is record
sa_handler : System.Address;
sa_mask : sigset_t;
- sa_flags : Interfaces.C.unsigned_long;
+ sa_flags : int;
sa_restorer : System.Address;
end record;
pragma Convention (C, struct_sigaction);
@@ -270,6 +270,7 @@ package System.OS_Interface is
pragma Import (C, getpid, "getpid");
PR_SET_NAME : constant := 15;
+ PR_GET_NAME : constant := 16;
function prctl
(option : int;
@@ -606,8 +607,7 @@ private
for struct_sigaction use record
sa_handler at Linux.sa_handler_pos range 0 .. Standard'Address_Size - 1;
sa_mask at Linux.sa_mask_pos range 0 .. 1023;
- sa_flags at Linux.sa_flags_pos
- range 0 .. Interfaces.C.unsigned_long'Size - 1;
+ sa_flags at Linux.sa_flags_pos range 0 .. int'Size - 1;
end record;
-- We intentionally leave sa_restorer unspecified and let the compiler
-- append it after the last field, so disable corresponding warning.
diff --git a/gcc/ada/s-osinte-vxworks.ads b/gcc/ada/s-osinte-vxworks.ads
index ba76dcdf34..10152343a6 100644
--- a/gcc/ada/s-osinte-vxworks.ads
+++ b/gcc/ada/s-osinte-vxworks.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- --
-- Copyright (C) 1991-1994, Florida State University --
--- Copyright (C) 1995-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1995-2016, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -83,6 +83,8 @@ package System.OS_Interface is
type HW_Interrupt is new int range 0 .. Max_HW_Interrupt;
Max_Interrupt : constant := Max_HW_Interrupt;
+ subtype Interrupt_Range is Natural range 0 .. Max_HW_Interrupt;
+ -- For s-interr
-- Signals common to Vxworks 5.x and 6.x
@@ -284,7 +286,7 @@ package System.OS_Interface is
OK : constant STATUS := 0;
ERROR : constant STATUS := Interfaces.C.int (-1);
- function taskIdVerify (tid : t_id) return STATUS;
+ function taskIdVerify (tid : t_id) return STATUS;
pragma Import (C, taskIdVerify, "taskIdVerify");
function taskIdSelf return t_id;
diff --git a/gcc/ada/s-osprim-mingw.adb b/gcc/ada/s-osprim-mingw.adb
index 9f7af90c52..6d4f2bf242 100644
--- a/gcc/ada/s-osprim-mingw.adb
+++ b/gcc/ada/s-osprim-mingw.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2016, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -329,7 +329,6 @@ package body System.OS_Primitives is
-----------------
procedure Timed_Delay (Time : Duration; Mode : Integer) is
-
function Mode_Clock return Duration;
pragma Inline (Mode_Clock);
-- Return the current clock value using either the monotonic clock or
@@ -342,10 +341,8 @@ package body System.OS_Primitives is
function Mode_Clock return Duration is
begin
case Mode is
- when Absolute_RT =>
- return Monotonic_Clock;
- when others =>
- return Clock;
+ when Absolute_RT => return Monotonic_Clock;
+ when others => return Clock;
end case;
end Mode_Clock;
diff --git a/gcc/ada/s-parame-ae653.ads b/gcc/ada/s-parame-ae653.ads
index d833e58654..4969ad39eb 100644
--- a/gcc/ada/s-parame-ae653.ads
+++ b/gcc/ada/s-parame-ae653.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -70,7 +70,7 @@ package System.Parameters is
-- The special value of minus one indicates that the secondary
-- stack is to be allocated from the heap instead.
- Sec_Stack_Percentage : constant Percentage := 50;
+ Sec_Stack_Percentage : constant Percentage := 25;
-- This constant defines the handling of the secondary stack
Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic;
diff --git a/gcc/ada/s-poosiz.adb b/gcc/ada/s-poosiz.adb
index 683f32e315..da3a0c5594 100644
--- a/gcc/ada/s-poosiz.adb
+++ b/gcc/ada/s-poosiz.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -148,7 +148,7 @@ package body System.Pool_Size is
-- Initialize --
----------------
- procedure Initialize (Pool : in out Stack_Bounded_Pool) is
+ procedure Initialize (Pool : in out Stack_Bounded_Pool) is
-- Define the appropriate alignment for allocations. This is the
-- maximum of the requested alignment, and the alignment required
@@ -180,7 +180,7 @@ package body System.Pool_Size is
-- Storage_Size --
------------------
- function Storage_Size
+ function Storage_Size
(Pool : Stack_Bounded_Pool) return SSE.Storage_Count
is
begin
diff --git a/gcc/ada/s-rannum.adb b/gcc/ada/s-rannum.adb
index acebbaf8a6..c024249ad0 100644
--- a/gcc/ada/s-rannum.adb
+++ b/gcc/ada/s-rannum.adb
@@ -208,7 +208,7 @@ is
G.I := I;
Y := Y xor Shift_Right (Y, U);
- Y := Y xor (Shift_Left (Y, S) and B_Mask);
+ Y := Y xor (Shift_Left (Y, S) and B_Mask);
Y := Y xor (Shift_Left (Y, T) and C_Mask);
Y := Y xor Shift_Right (Y, L);
diff --git a/gcc/ada/s-regexp.adb b/gcc/ada/s-regexp.adb
index 6a445340b1..8324504168 100644
--- a/gcc/ada/s-regexp.adb
+++ b/gcc/ada/s-regexp.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2015, AdaCore --
+-- Copyright (C) 1999-2016, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -551,7 +551,7 @@ package body System.Regexp is
("Incorrect character ']' in regular expression", J);
when '\' =>
- if J < S'Last then
+ if J < S'Last then
J := J + 1;
Add_In_Map (S (J));
@@ -970,7 +970,10 @@ package body System.Regexp is
End_State := Current_State;
end if;
- when '*' | '+' | '?' | Close_Paren | Close_Bracket =>
+ when Close_Bracket
+ | Close_Paren
+ | '*' | '+' | '?'
+ =>
Raise_Exception
("Incorrect character in regular expression :", J);
@@ -1020,7 +1023,6 @@ package body System.Regexp is
End_State := Current_State;
end if;
-
end case;
if Start_State = 0 then
@@ -1159,7 +1161,6 @@ package body System.Regexp is
J := Start_Index;
while J <= End_Index loop
case S (J) is
-
when Open_Bracket =>
Current_State := Current_State + 1;
@@ -1344,7 +1345,6 @@ package body System.Regexp is
end if;
End_State := Current_State;
-
end case;
if Start_State = 0 then
diff --git a/gcc/ada/s-regpat.adb b/gcc/ada/s-regpat.adb
index 4127ec9952..f27639b978 100644
--- a/gcc/ada/s-regpat.adb
+++ b/gcc/ada/s-regpat.adb
@@ -7,7 +7,7 @@
-- B o d y --
-- --
-- Copyright (C) 1986 by University of Toronto. --
--- Copyright (C) 1999-2015, AdaCore --
+-- Copyright (C) 1999-2016, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -2614,15 +2614,34 @@ package body System.Regpat is
exit State_Machine when Input_Pos /= BOL_Pos;
when EOL =>
- exit State_Machine when Input_Pos <= Data'Last
- and then ((Self.Flags and Multiple_Lines) = 0
- or else Data (Input_Pos) /= ASCII.LF);
+
+ -- A combination of MEOL and SEOL
+
+ if (Self.Flags and Multiple_Lines) = 0 then
+
+ -- Single line mode
+
+ exit State_Machine when Input_Pos <= Data'Last;
+
+ elsif Input_Pos <= Last_In_Data then
+ exit State_Machine when Data (Input_Pos) /= ASCII.LF;
+ else
+ exit State_Machine when Last_In_Data /= Data'Last;
+ end if;
when MEOL =>
- exit State_Machine when Input_Pos <= Data'Last
- and then Data (Input_Pos) /= ASCII.LF;
+ if Input_Pos <= Last_In_Data then
+ exit State_Machine when Data (Input_Pos) /= ASCII.LF;
+ else
+ exit State_Machine when Last_In_Data /= Data'Last;
+ end if;
when SEOL =>
+
+ -- If there is a character before Data'Last (even if
+ -- Last_In_Data stops before then), we can't have the
+ -- end of the line.
+
exit State_Machine when Input_Pos <= Data'Last;
when BOUND | NBOUND =>
diff --git a/gcc/ada/s-rident.ads b/gcc/ada/s-rident.ads
index f8ecb67430..3228bacaac 100644
--- a/gcc/ada/s-rident.ads
+++ b/gcc/ada/s-rident.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -121,7 +121,6 @@ package System.Rident is
No_Implicit_Heap_Allocations, -- (RM D.8(8), H.4(3))
No_Implicit_Task_Allocations, -- GNAT
No_Implicit_Protected_Object_Allocations, -- GNAT
- No_Implicit_Loops, -- GNAT
No_Initialize_Scalars, -- GNAT
No_Local_Allocators, -- (RM H.4(8))
No_Local_Timing_Events, -- (RM D.7(10.2/2))
@@ -179,6 +178,7 @@ package System.Rident is
No_Implementation_Restrictions, -- GNAT
No_Implementation_Units, -- Ada 2012 AI-242
No_Implicit_Aliasing, -- GNAT
+ No_Implicit_Loops, -- GNAT
No_Elaboration_Code, -- GNAT
No_Obsolescent_Features, -- Ada 2005 AI-368
No_Wide_Characters, -- GNAT
@@ -378,15 +378,19 @@ package System.Rident is
type Profile_Name is
(No_Profile,
No_Implementation_Extensions,
+ Restricted_Tasking,
+ Restricted,
Ravenscar,
- GNAT_Extended_Ravenscar,
- Restricted);
+ GNAT_Extended_Ravenscar);
-- Names of recognized profiles. No_Profile is used to indicate that a
-- restriction came from pragma Restrictions[_Warning], as opposed to
- -- pragma Profile[_Warning].
+ -- pragma Profile[_Warning]. Restricted_Tasking is a non-user profile that
+ -- contaings the minimal set of restrictions to trigger the user of the
+ -- restricted tasking runtime. Restricted is the corresponding user profile
+ -- that also restrict protected types.
subtype Profile_Name_Actual is Profile_Name
- range No_Implementation_Extensions .. Restricted;
+ range No_Implementation_Extensions .. GNAT_Extended_Ravenscar;
-- Actual used profile names
type Profile_Data is record
@@ -422,6 +426,37 @@ package System.Rident is
Value =>
(others => 0)),
+ -- Restricted_Tasking Profile
+
+ Restricted_Tasking =>
+
+ -- Restrictions for Restricted_Tasking profile
+
+ (Set =>
+ (No_Abort_Statements => True,
+ No_Asynchronous_Control => True,
+ No_Dynamic_Attachment => True,
+ No_Dynamic_Priorities => True,
+ No_Local_Protected_Objects => True,
+ No_Protected_Type_Allocators => True,
+ No_Requeue_Statements => True,
+ No_Task_Allocators => True,
+ No_Task_Attributes_Package => True,
+ No_Task_Hierarchy => True,
+ No_Terminate_Alternatives => True,
+ Max_Asynchronous_Select_Nesting => True,
+ Max_Select_Alternatives => True,
+ Max_Task_Entries => True,
+ others => False),
+
+ -- Value settings for Restricted_Tasking profile
+
+ Value =>
+ (Max_Asynchronous_Select_Nesting => 0,
+ Max_Select_Alternatives => 0,
+ Max_Task_Entries => 0,
+ others => 0)),
+
-- Restricted Profile
Restricted =>
@@ -519,7 +554,6 @@ package System.Rident is
No_Asynchronous_Control => True,
No_Dynamic_Attachment => True,
No_Dynamic_Priorities => True,
- No_Entry_Queue => True,
No_Local_Protected_Objects => True,
No_Protected_Type_Allocators => True,
No_Requeue_Statements => True,
@@ -528,18 +562,15 @@ package System.Rident is
No_Task_Hierarchy => True,
No_Terminate_Alternatives => True,
Max_Asynchronous_Select_Nesting => True,
- Max_Protected_Entries => True,
Max_Select_Alternatives => True,
Max_Task_Entries => True,
-- plus these additional restrictions:
- No_Calendar => True,
No_Implicit_Task_Allocations => True,
No_Implicit_Protected_Object_Allocations
=> True,
No_Local_Timing_Events => True,
- No_Relative_Delay => True,
No_Select_Statements => True,
No_Specific_Termination_Handlers => True,
No_Task_Termination => True,
@@ -550,7 +581,6 @@ package System.Rident is
Value =>
(Max_Asynchronous_Select_Nesting => 0,
- Max_Protected_Entries => 1,
Max_Select_Alternatives => 0,
Max_Task_Entries => 0,
others => 0)));
diff --git a/gcc/ada/s-secsta.adb b/gcc/ada/s-secsta.adb
index f8142fbe52..b55556f73e 100644
--- a/gcc/ada/s-secsta.adb
+++ b/gcc/ada/s-secsta.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -80,20 +80,20 @@ package body System.Secondary_Stack is
-- | | First (101)
-- +------------------+
-- +----------> | | |
- -- | +----------+-------+
+ -- | +--------- | ------+
+ -- | ^ |
-- | | |
- -- | ^ V
- -- | | |
- -- | +-------+----------+
+ -- | | V
+ -- | +------ | ---------+
-- | | | |
-- | +------------------+
-- | | | Last (100)
-- | | C |
-- | | H |
- -- +-----------------+ | +-------->| U |
- -- | Current_Chunk -|--+ | | N |
- -- +-----------------+ | | K |
- -- | Top -|-----+ | | First (1)
+ -- +-----------------+ | +------->| U |
+ -- | Current_Chunk ----+ | | N |
+ -- +-----------------+ | | K |
+ -- | Top --------+ | | First (1)
-- +-----------------+ +------------------+
-- | Default_Size | | Prev |
-- +-----------------+ +------------------+
@@ -170,6 +170,15 @@ package body System.Secondary_Stack is
Ada.Unchecked_Conversion (Address, Fixed_Stack_Ptr);
-- Convert from address stored in task data structures
+ ----------------------------------
+ -- Minimum_Secondary_Stack_Size --
+ ----------------------------------
+
+ function Minimum_Secondary_Stack_Size return Natural is
+ begin
+ return Dummy_Fixed_Stack.Mem'Position;
+ end Minimum_Secondary_Stack_Size;
+
--------------
-- Allocate --
--------------
@@ -178,10 +187,10 @@ package body System.Secondary_Stack is
(Addr : out Address;
Storage_Size : SSE.Storage_Count)
is
- Max_Align : constant SS_Ptr := SS_Ptr (Standard'Maximum_Alignment);
- Max_Size : constant SS_Ptr :=
- ((SS_Ptr (Storage_Size) + Max_Align - 1) / Max_Align)
- * Max_Align;
+ Max_Align : constant SS_Ptr := SS_Ptr (Standard'Maximum_Alignment);
+ Max_Size : constant SS_Ptr :=
+ ((SS_Ptr (Storage_Size) + Max_Align - 1) / Max_Align) *
+ Max_Align;
begin
-- Case of fixed allocation secondary stack
@@ -227,7 +236,7 @@ package body System.Secondary_Stack is
Chunk := Stack.Current_Chunk;
-- The Current_Chunk may not be the good one if a lot of release
- -- operations have taken place. So go down the stack if necessary
+ -- operations have taken place. Go down the stack if necessary.
while Chunk.First > Stack.Top loop
Chunk := Chunk.Prev;
@@ -250,8 +259,8 @@ package body System.Secondary_Stack is
Free (To_Be_Released_Chunk);
end if;
- -- Create new chunk of default size unless it is not
- -- sufficient to satisfy the current request.
+ -- Create new chunk of default size unless it is not sufficient
+ -- to satisfy the current request.
elsif SSE.Storage_Count (Max_Size) <= Stack.Default_Size then
Chunk.Next :=
@@ -261,7 +270,7 @@ package body System.Secondary_Stack is
Chunk.Next.Prev := Chunk;
- -- Otherwise create new chunk of requested size
+ -- Otherwise create new chunk of requested size
else
Chunk.Next :=
@@ -366,7 +375,7 @@ package body System.Secondary_Stack is
Put_Line (
" Current allocated space : "
- & SS_Ptr'Image (Fixed_Stack.Top - 1)
+ & SS_Ptr'Image (Fixed_Stack.Top)
& " bytes");
end;
@@ -432,7 +441,7 @@ package body System.Secondary_Stack is
Fixed_Stack.Top := 0;
Fixed_Stack.Max := 0;
- if Size < Dummy_Fixed_Stack.Mem'Position then
+ if Size <= Dummy_Fixed_Stack.Mem'Position then
Fixed_Stack.Last := 0;
else
Fixed_Stack.Last :=
@@ -500,8 +509,8 @@ package body System.Secondary_Stack is
Chunk : aliased Chunk_Id (1, Static_Secondary_Stack_Size);
for Chunk'Alignment use Standard'Maximum_Alignment;
- -- Default chunk used, unless gnatbind -D is specified with a value
- -- greater than Static_Secondary_Stack_Size
+ -- Default chunk used, unless gnatbind -D is specified with a value greater
+ -- than Static_Secondary_Stack_Size.
begin
declare
diff --git a/gcc/ada/s-secsta.ads b/gcc/ada/s-secsta.ads
index a1685e0219..c5a0eadf29 100644
--- a/gcc/ada/s-secsta.ads
+++ b/gcc/ada/s-secsta.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -42,6 +42,10 @@ package System.Secondary_Stack is
-- which causes the binder to generate an appropriate assignment in the
-- binder generated file.
+ function Minimum_Secondary_Stack_Size return Natural;
+ -- The minimum size of the secondary stack so that the internal
+ -- requirements of the stack are met.
+
procedure SS_Init
(Stk : in out Address;
Size : Natural := Default_Secondary_Stack_Size);
diff --git a/gcc/ada/s-soflin.adb b/gcc/ada/s-soflin.adb
index 2d98f309e5..d1c10a0c67 100644
--- a/gcc/ada/s-soflin.adb
+++ b/gcc/ada/s-soflin.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -51,7 +51,7 @@ package body System.Soft_Links is
-- Needed for Vx6Cert (Vx653mc) GOS cert and ravenscar-cert runtimes,
-- VxMILS cert, ravenscar-cert and full runtimes, Vx 5 default runtime
- Stack_Limit : aliased System.Address;
+ Stack_Limit : aliased System.Address := System.Null_Address;
pragma Export (C, Stack_Limit, "__gnat_stack_limit");
diff --git a/gcc/ada/s-stposu.adb b/gcc/ada/s-stposu.adb
index c7d2819ca9..d017ce3686 100644
--- a/gcc/ada/s-stposu.adb
+++ b/gcc/ada/s-stposu.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -123,9 +123,6 @@ package body System.Storage_Pools.Subpools is
N_Size : Storage_Count;
Subpool : Subpool_Handle := null;
- Allocation_Locked : Boolean;
- -- This flag stores the state of the associated collection
-
Header_And_Padding : Storage_Offset;
-- This offset includes the size of a FM_Node plus any additional
-- padding due to a larger alignment.
@@ -170,25 +167,25 @@ package body System.Storage_Pools.Subpools is
else
-- If the master is missing, then the expansion of the access type
- -- failed to create one. This is a serious error.
+ -- failed to create one. This is a compiler bug.
- if Context_Master = null then
- raise Program_Error
- with "missing master in pool allocation";
+ pragma Assert
+ (Context_Master /= null, "missing master in pool allocation");
-- If a subpool is present, then this is the result of erroneous
-- allocator expansion. This is not a serious error, but it should
-- still be detected.
- elsif Context_Subpool /= null then
+ if Context_Subpool /= null then
raise Program_Error
with "subpool not required in pool allocation";
+ end if;
-- If the allocation is intended to be on a subpool, but the access
-- type's pool does not support subpools, then this is the result of
- -- erroneous end-user code.
+ -- incorrect end-user code.
- elsif On_Subpool then
+ if On_Subpool then
raise Program_Error
with "pool of access type does not support subpools";
end if;
@@ -209,26 +206,22 @@ package body System.Storage_Pools.Subpools is
-- Write - finalization
Lock_Task.all;
- Allocation_Locked := Finalization_Started (Master.all);
- Unlock_Task.all;
-- Do not allow the allocation of controlled objects while the
-- associated master is being finalized.
- if Allocation_Locked then
+ if Finalization_Started (Master.all) then
raise Program_Error with "allocation after finalization started";
end if;
-- Check whether primitive Finalize_Address is available. If it is
-- not, then either the expansion of the designated type failed or
- -- the expansion of the allocator failed. This is a serious error.
+ -- the expansion of the allocator failed. This is a compiler bug.
- if Fin_Address = null then
- raise Program_Error
- with "primitive Finalize_Address not available";
- end if;
+ pragma Assert
+ (Fin_Address /= null, "primitive Finalize_Address not available");
- -- The size must acount for the hidden header preceding the object.
+ -- The size must account for the hidden header preceding the object.
-- Account for possible padding space before the header due to a
-- larger alignment.
@@ -262,7 +255,8 @@ package body System.Storage_Pools.Subpools is
-- Step 4: Attachment
if Is_Controlled then
- Lock_Task.all;
+
+ -- Note that we already did "Lock_Task.all;" in Step 2 above
-- Map the allocated memory into a FM_Node record. This converts the
-- top of the allocated bits into a list header. If there is padding
@@ -280,8 +274,8 @@ package body System.Storage_Pools.Subpools is
-- | |
-- +- Header_And_Padding --+
- N_Ptr := Address_To_FM_Node_Ptr
- (N_Addr + Header_And_Padding - Header_Size);
+ N_Ptr :=
+ Address_To_FM_Node_Ptr (N_Addr + Header_And_Padding - Header_Size);
-- Prepend the allocated object to the finalization master
@@ -334,6 +328,18 @@ package body System.Storage_Pools.Subpools is
else
Addr := N_Addr;
end if;
+
+ exception
+ when others =>
+
+ -- Unlock the task in case the allocation step failed and reraise the
+ -- exception.
+
+ if Is_Controlled then
+ Unlock_Task.all;
+ end if;
+
+ raise;
end Allocate_Any_Controlled;
------------
@@ -384,59 +390,69 @@ package body System.Storage_Pools.Subpools is
if Is_Controlled then
Lock_Task.all;
- -- Destroy the relation pair object - Finalize_Address since it is no
- -- longer needed.
+ begin
+ -- Destroy the relation pair object - Finalize_Address since it is
+ -- no longer needed.
- if Finalize_Address_Table_In_Use then
+ if Finalize_Address_Table_In_Use then
- -- Synchronization:
- -- Read - finalization
- -- Write - allocation, deallocation
+ -- Synchronization:
+ -- Read - finalization
+ -- Write - allocation, deallocation
- Delete_Finalize_Address_Unprotected (Addr);
- end if;
+ Delete_Finalize_Address_Unprotected (Addr);
+ end if;
- -- Account for possible padding space before the header due to a
- -- larger alignment.
+ -- Account for possible padding space before the header due to a
+ -- larger alignment.
- Header_And_Padding := Header_Size_With_Padding (Alignment);
+ Header_And_Padding := Header_Size_With_Padding (Alignment);
- -- N_Addr N_Ptr Addr (from input)
- -- | | |
- -- V V V
- -- +-------+---------------+----------------------+
- -- |Padding| Header | Object |
- -- +-------+---------------+----------------------+
- -- ^ ^ ^
- -- | +- Header_Size -+
- -- | |
- -- +- Header_And_Padding --+
+ -- N_Addr N_Ptr Addr (from input)
+ -- | | |
+ -- V V V
+ -- +-------+---------------+----------------------+
+ -- |Padding| Header | Object |
+ -- +-------+---------------+----------------------+
+ -- ^ ^ ^
+ -- | +- Header_Size -+
+ -- | |
+ -- +- Header_And_Padding --+
- -- Convert the bits preceding the object into a list header
+ -- Convert the bits preceding the object into a list header
- N_Ptr := Address_To_FM_Node_Ptr (Addr - Header_Size);
+ N_Ptr := Address_To_FM_Node_Ptr (Addr - Header_Size);
- -- Detach the object from the related finalization master. This
- -- action does not need to know the prior context used during
- -- allocation.
+ -- Detach the object from the related finalization master. This
+ -- action does not need to know the prior context used during
+ -- allocation.
- -- Synchronization:
- -- Write - allocation, deallocation, finalization
+ -- Synchronization:
+ -- Write - allocation, deallocation, finalization
- Detach_Unprotected (N_Ptr);
+ Detach_Unprotected (N_Ptr);
- -- Move the address from the object to the beginning of the list
- -- header.
+ -- Move the address from the object to the beginning of the list
+ -- header.
- N_Addr := Addr - Header_And_Padding;
+ N_Addr := Addr - Header_And_Padding;
- -- The size of the deallocated object must include the size of the
- -- hidden list header.
+ -- The size of the deallocated object must include the size of the
+ -- hidden list header.
- N_Size := Storage_Size + Header_And_Padding;
+ N_Size := Storage_Size + Header_And_Padding;
- Unlock_Task.all;
+ Unlock_Task.all;
+ exception
+ when others =>
+
+ -- Unlock the task in case the computations performed above
+ -- fail for some reason.
+
+ Unlock_Task.all;
+ raise;
+ end;
else
N_Addr := Addr;
N_Size := Storage_Size;
diff --git a/gcc/ada/s-stratt-xdr.adb b/gcc/ada/s-stratt-xdr.adb
index ae4c9b37e7..1c5d3cf62d 100644
--- a/gcc/ada/s-stratt-xdr.adb
+++ b/gcc/ada/s-stratt-xdr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2016, Free Software Foundation, Inc. --
-- --
-- GARLIC is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -33,6 +33,11 @@
-- standard. It is especially useful for exchanging streams between two
-- different systems with different basic type representations and endianness.
+pragma Warnings (Off, "*not allowed in compiler unit");
+-- This body is used only when rebuilding the runtime library, not when
+-- building the compiler, so it's OK to depend on features that would
+-- otherwise break bootstrap (e.g. IF-expressions).
+
with Ada.IO_Exceptions;
with Ada.Streams; use Ada.Streams;
with Ada.Unchecked_Conversion;
diff --git a/gcc/ada/s-strhas.adb b/gcc/ada/s-strhas.adb
index 6b7b9fea2a..9ab5b6e423 100644
--- a/gcc/ada/s-strhas.adb
+++ b/gcc/ada/s-strhas.adb
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -33,8 +33,9 @@ pragma Compiler_Unit_Warning;
package body System.String_Hash is
- -- Compute a hash value for a key. The approach here is follows the
- -- algorithm used in GNU Awk and the ndbm substitute SDBM by Ozan Yigit.
+ -- Compute a hash value for a key. The approach here follows the algorithm
+ -- introduced in the ndbm substitute SDBM by Ozan Yigit and then reused in
+ -- GNU Awk (where they are implemented as a Duff's device).
----------
-- Hash --
diff --git a/gcc/ada/s-taprob.ads b/gcc/ada/s-taprob.ads
index fa2a99fa79..98bc4b2b36 100644
--- a/gcc/ada/s-taprob.ads
+++ b/gcc/ada/s-taprob.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -152,9 +152,8 @@ package System.Tasking.Protected_Objects is
Action : Entry_Action_Pointer;
end record;
-- The compiler-generated code passes objects of this type to the GNARL
- -- to allow it to access the executable code of an entry body.
-
- type Entry_Body_Access is access all Entry_Body;
+ -- to allow it to access the executable code of an entry body and its
+ -- barrier.
type Protection is limited private;
-- This type contains the GNARL state of a protected object. The
diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb
index 2aad75ebea..ad603d8e58 100644
--- a/gcc/ada/s-taprop-linux.adb
+++ b/gcc/ada/s-taprop-linux.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -45,7 +45,6 @@ with System.Tasking.Debug;
with System.Interrupt_Management;
with System.OS_Constants;
with System.OS_Primitives;
-with System.Stack_Checking.Operations;
with System.Multiprocessors;
with System.Soft_Links;
@@ -58,7 +57,6 @@ package body System.Task_Primitives.Operations is
package OSC renames System.OS_Constants;
package SSL renames System.Soft_Links;
- package SC renames System.Stack_Checking.Operations;
use System.Tasking.Debug;
use System.Tasking;
@@ -757,14 +755,55 @@ package body System.Task_Primitives.Operations is
Self_ID.Common.LL.Thread := pthread_self;
Self_ID.Common.LL.LWP := lwp_self;
- if Self_ID.Common.Task_Image_Len > 0 then
+ -- Set thread name to ease debugging. If the name of the task is
+ -- "foreign thread" (as set by Register_Foreign_Thread) retrieve
+ -- the name of the thread and update the name of the task instead.
+
+ if Self_ID.Common.Task_Image_Len = 14
+ and then Self_ID.Common.Task_Image (1 .. 14) = "foreign thread"
+ then
+ declare
+ Thread_Name : String (1 .. 16);
+ -- PR_GET_NAME returns a string of up to 16 bytes
+
+ Len : Natural := 0;
+ -- Length of the task name contained in Task_Name
+
+ Result : int;
+ -- Result from the prctl call
+ begin
+ Result := prctl (PR_GET_NAME, unsigned_long (Thread_Name'Address));
+ pragma Assert (Result = 0);
+
+ -- Find the length of the given name
+
+ for J in Thread_Name'Range loop
+ if Thread_Name (J) /= ASCII.NUL then
+ Len := Len + 1;
+ else
+ exit;
+ end if;
+ end loop;
+
+ -- Cover the odd situtation if someone decides to change
+ -- Parameters.Max_Task_Image_Length to less than 16 characters
+
+ if Len > Parameters.Max_Task_Image_Length then
+ Len := Parameters.Max_Task_Image_Length;
+ end if;
+
+ -- Copy the name of the thread to the task's ATCB
+
+ Self_ID.Common.Task_Image (1 .. Len) := Thread_Name (1 .. Len);
+ Self_ID.Common.Task_Image_Len := Len;
+ end;
+
+ elsif Self_ID.Common.Task_Image_Len > 0 then
declare
Task_Name : String (1 .. Parameters.Max_Task_Image_Length + 1);
Result : int;
begin
- -- Set thread name to ease debugging
-
Task_Name (1 .. Self_ID.Common.Task_Image_Len) :=
Self_ID.Common.Task_Image (1 .. Self_ID.Common.Task_Image_Len);
Task_Name (Self_ID.Common.Task_Image_Len + 1) := ASCII.NUL;
@@ -1048,8 +1087,6 @@ package body System.Task_Primitives.Operations is
Known_Tasks (T.Known_Tasks_Index) := null;
end if;
- SC.Invalidate_Stack_Cache (T.Common.Compiler_Data.Pri_Stack_Info'Access);
-
ATCB_Allocation.Free_ATCB (T);
end Finalize_TCB;
diff --git a/gcc/ada/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb
index c945e1dfcc..aba2367310 100644
--- a/gcc/ada/s-taprop-mingw.adb
+++ b/gcc/ada/s-taprop-mingw.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -157,11 +157,19 @@ package body System.Task_Primitives.Operations is
package body Specific is
+ -------------------
+ -- Is_Valid_Task --
+ -------------------
+
function Is_Valid_Task return Boolean is
begin
return TlsGetValue (TlsIndex) /= System.Null_Address;
end Is_Valid_Task;
+ ---------
+ -- Set --
+ ---------
+
procedure Set (Self_Id : Task_Id) is
Succeeded : BOOL;
begin
@@ -761,13 +769,9 @@ package body System.Task_Primitives.Operations is
-- 1) from System.Task_Primitives.Operations.Initialize
-- 2) from System.Tasking.Stages.Task_Wrapper
- -- The thread initialisation has to be done only for the first case
-
- -- This is because the GetCurrentThread NT call does not return the real
- -- thread handler but only a "pseudo" one. It is not possible to release
- -- the thread handle and free the system resources from this "pseudo"
- -- handle. So we really want to keep the real thread handle set in
- -- System.Task_Primitives.Operations.Create_Task during thread creation.
+ -- The pseudo handle (LL.Thread) need not be closed when it is no
+ -- longer needed. Calling the CloseHandle function with this handle
+ -- has no effect.
procedure Enter_Task (Self_ID : Task_Id) is
procedure Get_Stack_Bounds (Base : Address; Limit : Address);
@@ -787,6 +791,7 @@ package body System.Task_Primitives.Operations is
raise Invalid_CPU_Number;
end if;
+ Self_ID.Common.LL.Thread := GetCurrentThread;
Self_ID.Common.LL.Thread_Id := GetCurrentThreadId;
Get_Stack_Bounds
@@ -887,8 +892,8 @@ package body System.Task_Primitives.Operations is
DWORD (Stack_Size),
Entry_Point,
pTaskParameter,
- DWORD (Create_Suspended) or
- DWORD (Stack_Size_Param_Is_A_Reservation),
+ DWORD (Create_Suspended)
+ or DWORD (Stack_Size_Param_Is_A_Reservation),
TaskId'Unchecked_Access);
else
hTask := CreateThread
diff --git a/gcc/ada/s-tarest.adb b/gcc/ada/s-tarest.adb
index 5d44196216..936e5fe16e 100644
--- a/gcc/ada/s-tarest.adb
+++ b/gcc/ada/s-tarest.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2016, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -116,16 +116,17 @@ package body System.Tasking.Restricted.Stages is
-- This should only be called by the Task_Wrapper procedure.
procedure Create_Restricted_Task
- (Priority : Integer;
- Stack_Address : System.Address;
- Size : System.Parameters.Size_Type;
- Task_Info : System.Task_Info.Task_Info_Type;
- CPU : Integer;
- State : Task_Procedure_Access;
- Discriminants : System.Address;
- Elaborated : Access_Boolean;
- Task_Image : String;
- Created_Task : Task_Id);
+ (Priority : Integer;
+ Stack_Address : System.Address;
+ Size : System.Parameters.Size_Type;
+ Secondary_Stack_Size : System.Parameters.Size_Type;
+ Task_Info : System.Task_Info.Task_Info_Type;
+ CPU : Integer;
+ State : Task_Procedure_Access;
+ Discriminants : System.Address;
+ Elaborated : Access_Boolean;
+ Task_Image : String;
+ Created_Task : Task_Id);
-- Code shared between Create_Restricted_Task (the concurrent version) and
-- Create_Restricted_Task_Sequential. See comment of the former in the
-- specification of this package.
@@ -205,11 +206,43 @@ package body System.Tasking.Restricted.Stages is
--
-- DO NOT delete ID. As noted, it is needed on some targets.
- use type SSE.Storage_Offset;
+ function Secondary_Stack_Size return Storage_Elements.Storage_Offset;
+ -- Returns the size of the secondary stack for the task. For fixed
+ -- secondary stacks, the function will return the ATCB field
+ -- Secondary_Stack_Size if it is not set to Unspecified_Size,
+ -- otherwise a percentage of the stack is reserved using the
+ -- System.Parameters.Sec_Stack_Percentage property.
- Secondary_Stack : aliased SSE.Storage_Array
- (1 .. Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size *
- SSE.Storage_Offset (Parameters.Sec_Stack_Percentage) / 100);
+ -- Dynamic secondary stacks are allocated in System.Soft_Links.
+ -- Create_TSD and thus the function returns 0 to suppress the
+ -- creation of the fixed secondary stack in the primary stack.
+
+ --------------------------
+ -- Secondary_Stack_Size --
+ --------------------------
+
+ function Secondary_Stack_Size return Storage_Elements.Storage_Offset is
+ use System.Storage_Elements;
+ use System.Secondary_Stack;
+
+ begin
+ if Parameters.Sec_Stack_Dynamic then
+ return 0;
+
+ elsif Self_ID.Common.Secondary_Stack_Size = Unspecified_Size then
+ return (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size
+ * SSE.Storage_Offset (Sec_Stack_Percentage) / 100);
+ else
+ -- Use the size specified by aspect Secondary_Stack_Size padded
+ -- by the amount of space used by the stack data structure.
+
+ return Storage_Offset (Self_ID.Common.Secondary_Stack_Size) +
+ Storage_Offset (Minimum_Secondary_Stack_Size);
+ end if;
+ end Secondary_Stack_Size;
+
+ Secondary_Stack : aliased Storage_Elements.Storage_Array
+ (1 .. Secondary_Stack_Size);
for Secondary_Stack'Alignment use Standard'Maximum_Alignment;
-- This is the secondary stack data. Note that it is critical that this
-- have maximum alignment, since any kind of data can be allocated here.
@@ -234,6 +267,8 @@ package body System.Tasking.Restricted.Stages is
-- execution of its task body, then EO will contain the associated
-- exception occurrence. Otherwise, it will contain Null_Occurrence.
+ -- Start of processing for Task_Wrapper
+
begin
if not Parameters.Sec_Stack_Dynamic then
Self_ID.Common.Compiler_Data.Sec_Stack_Addr :=
@@ -241,8 +276,8 @@ package body System.Tasking.Restricted.Stages is
SST.SS_Init (Secondary_Stack_Address, Integer (Secondary_Stack'Last));
end if;
- -- Initialize low-level TCB components, that
- -- cannot be initialized by the creator.
+ -- Initialize low-level TCB components, that cannot be initialized by
+ -- the creator.
Enter_Task (Self_ID);
@@ -505,16 +540,17 @@ package body System.Tasking.Restricted.Stages is
----------------------------
procedure Create_Restricted_Task
- (Priority : Integer;
- Stack_Address : System.Address;
- Size : System.Parameters.Size_Type;
- Task_Info : System.Task_Info.Task_Info_Type;
- CPU : Integer;
- State : Task_Procedure_Access;
- Discriminants : System.Address;
- Elaborated : Access_Boolean;
- Task_Image : String;
- Created_Task : Task_Id)
+ (Priority : Integer;
+ Stack_Address : System.Address;
+ Size : System.Parameters.Size_Type;
+ Secondary_Stack_Size : System.Parameters.Size_Type;
+ Task_Info : System.Task_Info.Task_Info_Type;
+ CPU : Integer;
+ State : Task_Procedure_Access;
+ Discriminants : System.Address;
+ Elaborated : Access_Boolean;
+ Task_Image : String;
+ Created_Task : Task_Id)
is
Self_ID : constant Task_Id := STPO.Self;
Base_Priority : System.Any_Priority;
@@ -573,7 +609,8 @@ package body System.Tasking.Restricted.Stages is
Initialize_ATCB
(Self_ID, State, Discriminants, Self_ID, Elaborated, Base_Priority,
- Base_CPU, null, Task_Info, Size, Created_Task, Success);
+ Base_CPU, null, Task_Info, Size, Secondary_Stack_Size,
+ Created_Task, Success);
-- If we do our job right then there should never be any failures, which
-- was probably said about the Titanic; so just to be safe, let's retain
@@ -610,17 +647,18 @@ package body System.Tasking.Restricted.Stages is
end Create_Restricted_Task;
procedure Create_Restricted_Task
- (Priority : Integer;
- Stack_Address : System.Address;
- Size : System.Parameters.Size_Type;
- Task_Info : System.Task_Info.Task_Info_Type;
- CPU : Integer;
- State : Task_Procedure_Access;
- Discriminants : System.Address;
- Elaborated : Access_Boolean;
- Chain : in out Activation_Chain;
- Task_Image : String;
- Created_Task : Task_Id)
+ (Priority : Integer;
+ Stack_Address : System.Address;
+ Size : System.Parameters.Size_Type;
+ Secondary_Stack_Size : System.Parameters.Size_Type;
+ Task_Info : System.Task_Info.Task_Info_Type;
+ CPU : Integer;
+ State : Task_Procedure_Access;
+ Discriminants : System.Address;
+ Elaborated : Access_Boolean;
+ Chain : in out Activation_Chain;
+ Task_Image : String;
+ Created_Task : Task_Id)
is
begin
if Partition_Elaboration_Policy = 'S' then
@@ -631,13 +669,15 @@ package body System.Tasking.Restricted.Stages is
-- sequential, activation must be deferred.
Create_Restricted_Task_Sequential
- (Priority, Stack_Address, Size, Task_Info, CPU, State,
- Discriminants, Elaborated, Task_Image, Created_Task);
+ (Priority, Stack_Address, Size, Secondary_Stack_Size,
+ Task_Info, CPU, State, Discriminants, Elaborated,
+ Task_Image, Created_Task);
else
Create_Restricted_Task
- (Priority, Stack_Address, Size, Task_Info, CPU, State,
- Discriminants, Elaborated, Task_Image, Created_Task);
+ (Priority, Stack_Address, Size, Secondary_Stack_Size,
+ Task_Info, CPU, State, Discriminants, Elaborated,
+ Task_Image, Created_Task);
-- Append this task to the activation chain
@@ -651,18 +691,20 @@ package body System.Tasking.Restricted.Stages is
---------------------------------------
procedure Create_Restricted_Task_Sequential
- (Priority : Integer;
- Stack_Address : System.Address;
- Size : System.Parameters.Size_Type;
- Task_Info : System.Task_Info.Task_Info_Type;
- CPU : Integer;
- State : Task_Procedure_Access;
- Discriminants : System.Address;
- Elaborated : Access_Boolean;
- Task_Image : String;
- Created_Task : Task_Id) is
+ (Priority : Integer;
+ Stack_Address : System.Address;
+ Size : System.Parameters.Size_Type;
+ Secondary_Stack_Size : System.Parameters.Size_Type;
+ Task_Info : System.Task_Info.Task_Info_Type;
+ CPU : Integer;
+ State : Task_Procedure_Access;
+ Discriminants : System.Address;
+ Elaborated : Access_Boolean;
+ Task_Image : String;
+ Created_Task : Task_Id) is
begin
- Create_Restricted_Task (Priority, Stack_Address, Size, Task_Info,
+ Create_Restricted_Task (Priority, Stack_Address, Size,
+ Secondary_Stack_Size, Task_Info,
CPU, State, Discriminants, Elaborated,
Task_Image, Created_Task);
diff --git a/gcc/ada/s-tarest.ads b/gcc/ada/s-tarest.ads
index 90c1f2cc13..6a53289144 100644
--- a/gcc/ada/s-tarest.ads
+++ b/gcc/ada/s-tarest.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -128,17 +128,18 @@ package System.Tasking.Restricted.Stages is
-- by the binder generated code, before calling elaboration code.
procedure Create_Restricted_Task
- (Priority : Integer;
- Stack_Address : System.Address;
- Size : System.Parameters.Size_Type;
- Task_Info : System.Task_Info.Task_Info_Type;
- CPU : Integer;
- State : Task_Procedure_Access;
- Discriminants : System.Address;
- Elaborated : Access_Boolean;
- Chain : in out Activation_Chain;
- Task_Image : String;
- Created_Task : Task_Id);
+ (Priority : Integer;
+ Stack_Address : System.Address;
+ Size : System.Parameters.Size_Type;
+ Secondary_Stack_Size : System.Parameters.Size_Type;
+ Task_Info : System.Task_Info.Task_Info_Type;
+ CPU : Integer;
+ State : Task_Procedure_Access;
+ Discriminants : System.Address;
+ Elaborated : Access_Boolean;
+ Chain : in out Activation_Chain;
+ Task_Image : String;
+ Created_Task : Task_Id);
-- Compiler interface only. Do not call from within the RTS.
-- This must be called to create a new task, when the partition
-- elaboration policy is not specified (or is concurrent).
@@ -153,6 +154,8 @@ package System.Tasking.Restricted.Stages is
--
-- Size is the stack size of the task to create
--
+ -- Secondary_Stack_Size is the secondary stack size of the task to create
+ --
-- Task_Info is the task info associated with the created task, or
-- Unspecified_Task_Info if none.
--
@@ -182,16 +185,17 @@ package System.Tasking.Restricted.Stages is
-- This procedure can raise Storage_Error if the task creation fails
procedure Create_Restricted_Task_Sequential
- (Priority : Integer;
- Stack_Address : System.Address;
- Size : System.Parameters.Size_Type;
- Task_Info : System.Task_Info.Task_Info_Type;
- CPU : Integer;
- State : Task_Procedure_Access;
- Discriminants : System.Address;
- Elaborated : Access_Boolean;
- Task_Image : String;
- Created_Task : Task_Id);
+ (Priority : Integer;
+ Stack_Address : System.Address;
+ Size : System.Parameters.Size_Type;
+ Secondary_Stack_Size : System.Parameters.Size_Type;
+ Task_Info : System.Task_Info.Task_Info_Type;
+ CPU : Integer;
+ State : Task_Procedure_Access;
+ Discriminants : System.Address;
+ Elaborated : Access_Boolean;
+ Task_Image : String;
+ Created_Task : Task_Id);
-- Compiler interface only. Do not call from within the RTS.
-- This must be called to create a new task, when the sequential partition
-- elaboration policy is used.
diff --git a/gcc/ada/s-tasini.adb b/gcc/ada/s-tasini.adb
index dddad762e3..48444431c5 100644
--- a/gcc/ada/s-tasini.adb
+++ b/gcc/ada/s-tasini.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -434,12 +434,15 @@ package body System.Tasking.Initialization is
begin
if not T.Aborting and then T /= Self_ID then
case T.Common.State is
- when Unactivated | Terminated =>
+ when Terminated
+ | Unactivated
+ =>
pragma Assert (False);
null;
- when Activating | Runnable =>
-
+ when Activating
+ | Runnable
+ =>
-- This is needed to cancel an asynchronous protected entry
-- call during a requeue with abort.
@@ -449,15 +452,18 @@ package body System.Tasking.Initialization is
when Interrupt_Server_Blocked_On_Event_Flag =>
null;
- when Delay_Sleep |
- Async_Select_Sleep |
- Interrupt_Server_Idle_Sleep |
- Interrupt_Server_Blocked_Interrupt_Sleep |
- Timer_Server_Sleep |
- AST_Server_Sleep =>
+ when AST_Server_Sleep
+ | Async_Select_Sleep
+ | Delay_Sleep
+ | Interrupt_Server_Blocked_Interrupt_Sleep
+ | Interrupt_Server_Idle_Sleep
+ | Timer_Server_Sleep
+ =>
Wakeup (T, T.Common.State);
- when Acceptor_Sleep | Acceptor_Delay_Sleep =>
+ when Acceptor_Delay_Sleep
+ | Acceptor_Sleep
+ =>
T.Open_Accepts := null;
Wakeup (T, T.Common.State);
@@ -466,10 +472,11 @@ package body System.Tasking.Initialization is
(T.ATC_Nesting_Level).Cancellation_Attempted := True;
Wakeup (T, T.Common.State);
- when Activator_Sleep |
- Master_Completion_Sleep |
- Master_Phase_2_Sleep |
- Asynchronous_Hold =>
+ when Activator_Sleep
+ | Asynchronous_Hold
+ | Master_Completion_Sleep
+ | Master_Phase_2_Sleep
+ =>
null;
end case;
end if;
diff --git a/gcc/ada/s-taskin.adb b/gcc/ada/s-taskin.adb
index 1c18a89d43..bddbe115b8 100644
--- a/gcc/ada/s-taskin.adb
+++ b/gcc/ada/s-taskin.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -86,18 +86,19 @@ package body System.Tasking is
---------------------
procedure Initialize_ATCB
- (Self_ID : Task_Id;
- Task_Entry_Point : Task_Procedure_Access;
- Task_Arg : System.Address;
- Parent : Task_Id;
- Elaborated : Access_Boolean;
- Base_Priority : System.Any_Priority;
- Base_CPU : System.Multiprocessors.CPU_Range;
- Domain : Dispatching_Domain_Access;
- Task_Info : System.Task_Info.Task_Info_Type;
- Stack_Size : System.Parameters.Size_Type;
- T : Task_Id;
- Success : out Boolean)
+ (Self_ID : Task_Id;
+ Task_Entry_Point : Task_Procedure_Access;
+ Task_Arg : System.Address;
+ Parent : Task_Id;
+ Elaborated : Access_Boolean;
+ Base_Priority : System.Any_Priority;
+ Base_CPU : System.Multiprocessors.CPU_Range;
+ Domain : Dispatching_Domain_Access;
+ Task_Info : System.Task_Info.Task_Info_Type;
+ Stack_Size : System.Parameters.Size_Type;
+ Secondary_Stack_Size : System.Parameters.Size_Type;
+ T : Task_Id;
+ Success : out Boolean)
is
begin
T.Common.State := Unactivated;
@@ -146,6 +147,7 @@ package body System.Tasking is
T.Common.Specific_Handler := null;
T.Common.Debug_Events := (others => False);
T.Common.Task_Image_Len := 0;
+ T.Common.Secondary_Stack_Size := Secondary_Stack_Size;
if T.Common.Parent = null then
@@ -232,18 +234,19 @@ package body System.Tasking is
T := STPO.New_ATCB (0);
Initialize_ATCB
- (Self_ID => null,
- Task_Entry_Point => null,
- Task_Arg => Null_Address,
- Parent => Null_Task,
- Elaborated => null,
- Base_Priority => Base_Priority,
- Base_CPU => Base_CPU,
- Domain => System_Domain,
- Task_Info => Task_Info.Unspecified_Task_Info,
- Stack_Size => 0,
- T => T,
- Success => Success);
+ (Self_ID => null,
+ Task_Entry_Point => null,
+ Task_Arg => Null_Address,
+ Parent => Null_Task,
+ Elaborated => null,
+ Base_Priority => Base_Priority,
+ Base_CPU => Base_CPU,
+ Domain => System_Domain,
+ Task_Info => Task_Info.Unspecified_Task_Info,
+ Stack_Size => 0,
+ Secondary_Stack_Size => Parameters.Unspecified_Size,
+ T => T,
+ Success => Success);
pragma Assert (Success);
STPO.Initialize (T);
@@ -272,17 +275,4 @@ package body System.Tasking is
T.Entry_Calls (1).Self := T;
end Initialize;
-
- ---------------------
- -- Set_Entry_Names --
- ---------------------
-
- procedure Set_Entry_Names
- (Self_Id : Task_Id;
- Names : Task_Entry_Names_Access)
- is
- begin
- Self_Id.Entry_Names := Names;
- end Set_Entry_Names;
-
end System.Tasking;
diff --git a/gcc/ada/s-taskin.ads b/gcc/ada/s-taskin.ads
index 539d08854f..a0b5879048 100644
--- a/gcc/ada/s-taskin.ads
+++ b/gcc/ada/s-taskin.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -254,11 +254,6 @@ package System.Tasking is
type String_Access is access all String;
- type Task_Entry_Names_Array is
- array (Entry_Index range <>) of String_Access;
-
- type Task_Entry_Names_Access is access all Task_Entry_Names_Array;
-
----------------------------------
-- Entry_Call_Record definition --
----------------------------------
@@ -707,6 +702,13 @@ package System.Tasking is
-- need to do different things depending on the situation.
--
-- Protection: Self.L
+
+ Secondary_Stack_Size : System.Parameters.Size_Type;
+ -- Secondary_Stack_Size is the size of the secondary stack for the
+ -- task. Defined here since it is the responsibility of the task to
+ -- creates its own secondary stack.
+ --
+ -- Protected: Only accessed by Self
end record;
---------------------------------------
@@ -965,14 +967,6 @@ package System.Tasking is
-- associated with protected objects or task entries, and are protected
-- by the protected object lock or Acceptor.L, respectively.
- Entry_Names : Task_Entry_Names_Access := null;
- -- An array of string names which denotes entry [family member] names.
- -- The structure is indexed by task entry index and contains Entry_Num
- -- components.
- --
- -- Protection: The array is populated during task initialization, before
- -- the task has been activated. No protection is required in this case.
-
New_Base_Priority : System.Any_Priority;
-- New value for Base_Priority (for dynamic priorities package)
--
@@ -1169,18 +1163,19 @@ package System.Tasking is
-- System.Tasking.Initialization being present, as was done before.
procedure Initialize_ATCB
- (Self_ID : Task_Id;
- Task_Entry_Point : Task_Procedure_Access;
- Task_Arg : System.Address;
- Parent : Task_Id;
- Elaborated : Access_Boolean;
- Base_Priority : System.Any_Priority;
- Base_CPU : System.Multiprocessors.CPU_Range;
- Domain : Dispatching_Domain_Access;
- Task_Info : System.Task_Info.Task_Info_Type;
- Stack_Size : System.Parameters.Size_Type;
- T : Task_Id;
- Success : out Boolean);
+ (Self_ID : Task_Id;
+ Task_Entry_Point : Task_Procedure_Access;
+ Task_Arg : System.Address;
+ Parent : Task_Id;
+ Elaborated : Access_Boolean;
+ Base_Priority : System.Any_Priority;
+ Base_CPU : System.Multiprocessors.CPU_Range;
+ Domain : Dispatching_Domain_Access;
+ Task_Info : System.Task_Info.Task_Info_Type;
+ Stack_Size : System.Parameters.Size_Type;
+ Secondary_Stack_Size : System.Parameters.Size_Type;
+ T : Task_Id;
+ Success : out Boolean);
-- Initialize fields of the TCB for task T, and link into global TCB
-- structures. Call this only with abort deferred and holding RTS_Lock.
-- Self_ID is the calling task (normally the activator of T). Success is
@@ -1202,10 +1197,4 @@ private
function Number_Of_Entries (Self_Id : Task_Id) return Entry_Index;
-- Given a task, return the number of entries it contains
-
- procedure Set_Entry_Names
- (Self_Id : Task_Id;
- Names : Task_Entry_Names_Access);
- -- Associate an array of strings denotinge entry [family] names with a task
-
end System.Tasking;
diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb
index 947e5aca99..7e0bdcb9e3 100644
--- a/gcc/ada/s-tassta.adb
+++ b/gcc/ada/s-tassta.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -50,11 +50,11 @@ with System.Tasking.Queuing;
with System.Tasking.Rendezvous;
with System.OS_Primitives;
with System.Secondary_Stack;
-with System.Storage_Elements;
with System.Restrictions;
with System.Standard_Library;
with System.Traces.Tasking;
with System.Stack_Usage;
+with System.Storage_Elements;
with System.Soft_Links;
-- These are procedure pointers to non-tasking routines that use task
@@ -472,20 +472,21 @@ package body System.Tasking.Stages is
-- called to create a new task.
procedure Create_Task
- (Priority : Integer;
- Size : System.Parameters.Size_Type;
- Task_Info : System.Task_Info.Task_Info_Type;
- CPU : Integer;
- Relative_Deadline : Ada.Real_Time.Time_Span;
- Domain : Dispatching_Domain_Access;
- Num_Entries : Task_Entry_Index;
- Master : Master_Level;
- State : Task_Procedure_Access;
- Discriminants : System.Address;
- Elaborated : Access_Boolean;
- Chain : in out Activation_Chain;
- Task_Image : String;
- Created_Task : out Task_Id)
+ (Priority : Integer;
+ Size : System.Parameters.Size_Type;
+ Secondary_Stack_Size : System.Parameters.Size_Type;
+ Task_Info : System.Task_Info.Task_Info_Type;
+ CPU : Integer;
+ Relative_Deadline : Ada.Real_Time.Time_Span;
+ Domain : Dispatching_Domain_Access;
+ Num_Entries : Task_Entry_Index;
+ Master : Master_Level;
+ State : Task_Procedure_Access;
+ Discriminants : System.Address;
+ Elaborated : Access_Boolean;
+ Chain : in out Activation_Chain;
+ Task_Image : String;
+ Created_Task : out Task_Id)
is
T, P : Task_Id;
Self_ID : constant Task_Id := STPO.Self;
@@ -611,7 +612,8 @@ package body System.Tasking.Stages is
end if;
Initialize_ATCB (Self_ID, State, Discriminants, P, Elaborated,
- Base_Priority, Base_CPU, Domain, Task_Info, Size, T, Success);
+ Base_Priority, Base_CPU, Domain, Task_Info, Size,
+ Secondary_Stack_Size, T, Success);
if not Success then
Free (T);
@@ -1037,12 +1039,43 @@ package body System.Tasking.Stages is
Use_Alternate_Stack : constant Boolean := Alternate_Stack_Size /= 0;
-- Whether to use above alternate signal stack for stack overflows
- Secondary_Stack_Size :
- constant SSE.Storage_Offset :=
- Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size *
- SSE.Storage_Offset (Parameters.Sec_Stack_Percentage) / 100;
+ function Secondary_Stack_Size return Storage_Elements.Storage_Offset;
+ -- Returns the size of the secondary stack for the task. For fixed
+ -- secondary stacks, the function will return the ATCB field
+ -- Secondary_Stack_Size if it is not set to Unspecified_Size,
+ -- otherwise a percentage of the stack is reserved using the
+ -- System.Parameters.Sec_Stack_Percentage property.
+
+ -- Dynamic secondary stacks are allocated in System.Soft_Links.
+ -- Create_TSD and thus the function returns 0 to suppress the
+ -- creation of the fixed secondary stack in the primary stack.
+
+ --------------------------
+ -- Secondary_Stack_Size --
+ --------------------------
- Secondary_Stack : aliased SSE.Storage_Array (1 .. Secondary_Stack_Size);
+ function Secondary_Stack_Size return Storage_Elements.Storage_Offset is
+ use System.Storage_Elements;
+ use System.Secondary_Stack;
+
+ begin
+ if Parameters.Sec_Stack_Dynamic then
+ return 0;
+
+ elsif Self_ID.Common.Secondary_Stack_Size = Unspecified_Size then
+ return (Self_ID.Common.Compiler_Data.Pri_Stack_Info.Size
+ * SSE.Storage_Offset (Sec_Stack_Percentage) / 100);
+ else
+ -- Use the size specified by aspect Secondary_Stack_Size padded
+ -- by the amount of space used by the stack data structure.
+
+ return Storage_Offset (Self_ID.Common.Secondary_Stack_Size) +
+ Storage_Offset (SST.Minimum_Secondary_Stack_Size);
+ end if;
+ end Secondary_Stack_Size;
+
+ Secondary_Stack : aliased Storage_Elements.Storage_Array
+ (1 .. Secondary_Stack_Size);
for Secondary_Stack'Alignment use Standard'Maximum_Alignment;
-- Actual area allocated for secondary stack. Note that it is critical
-- that this have maximum alignment, since any kind of data can be
@@ -1339,7 +1372,13 @@ package body System.Tasking.Stages is
if Self_ID.Common.Specific_Handler /= null then
TH := Self_ID.Common.Specific_Handler;
- else
+
+ -- Independent tasks should not call the Fall_Back_Handler (of the
+ -- environment task), because they are implementation artifacts that
+ -- should be invisible to Ada programs.
+
+ elsif Self_ID.Master_of_Task /= Independent_Task_Level then
+
-- Look for a fall-back handler following the master relationship
-- for the task. As specified in ARM C.7.3 par. 9/2, "the fall-back
-- handler applies only to the dependent tasks of the task". Hence,
diff --git a/gcc/ada/s-tassta.ads b/gcc/ada/s-tassta.ads
index e37fd59b66..1717d447eb 100644
--- a/gcc/ada/s-tassta.ads
+++ b/gcc/ada/s-tassta.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -167,26 +167,28 @@ package System.Tasking.Stages is
-- now in order to wake up the activator (the environment task).
procedure Create_Task
- (Priority : Integer;
- Size : System.Parameters.Size_Type;
- Task_Info : System.Task_Info.Task_Info_Type;
- CPU : Integer;
- Relative_Deadline : Ada.Real_Time.Time_Span;
- Domain : Dispatching_Domain_Access;
- Num_Entries : Task_Entry_Index;
- Master : Master_Level;
- State : Task_Procedure_Access;
- Discriminants : System.Address;
- Elaborated : Access_Boolean;
- Chain : in out Activation_Chain;
- Task_Image : String;
- Created_Task : out Task_Id);
+ (Priority : Integer;
+ Size : System.Parameters.Size_Type;
+ Secondary_Stack_Size : System.Parameters.Size_Type;
+ Task_Info : System.Task_Info.Task_Info_Type;
+ CPU : Integer;
+ Relative_Deadline : Ada.Real_Time.Time_Span;
+ Domain : Dispatching_Domain_Access;
+ Num_Entries : Task_Entry_Index;
+ Master : Master_Level;
+ State : Task_Procedure_Access;
+ Discriminants : System.Address;
+ Elaborated : Access_Boolean;
+ Chain : in out Activation_Chain;
+ Task_Image : String;
+ Created_Task : out Task_Id);
-- Compiler interface only. Do not call from within the RTS.
-- This must be called to create a new task.
--
-- Priority is the task's priority (assumed to be in range of type
-- System.Any_Priority)
-- Size is the stack size of the task to create
+ -- Secondary_Stack_Size is the secondary stack size of the task to create
-- Task_Info is the task info associated with the created task, or
-- Unspecified_Task_Info if none.
-- CPU is the task affinity. Passed as an Integer because the undefined
diff --git a/gcc/ada/s-tfsetr-default.adb b/gcc/ada/s-tfsetr-default.adb
index acddbefef0..754507130b 100644
--- a/gcc/ada/s-tfsetr-default.adb
+++ b/gcc/ada/s-tfsetr-default.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -81,10 +81,10 @@ procedure Send_Trace (Id : Trace_T; Info : String) is
-- We need comments here ???
case Param is
- when Name_Param =>
+ when Name_Param =>
Match ("/N:([\w]+)", Input, Matches);
- when Caller_Param =>
+ when Caller_Param =>
Match ("/C:([\w]+)", Input, Matches);
when Entry_Param =>
@@ -96,7 +96,7 @@ procedure Send_Trace (Id : Trace_T; Info : String) is
when Acceptor_Param =>
Match ("/A:([\w]+)", Input, Matches);
- when Parent_Param =>
+ when Parent_Param =>
Match ("/P:([\w]+)", Input, Matches);
when Number_Param =>
@@ -108,7 +108,10 @@ procedure Send_Trace (Id : Trace_T; Info : String) is
end if;
case Param is
- when Timeout_Param | Entry_Param | Number_Param =>
+ when Entry_Param
+ | Number_Param
+ | Timeout_Param
+ =>
return Input (Matches (2).First .. Matches (2).Last);
when others =>
diff --git a/gcc/ada/s-tfsetr-vxworks.adb b/gcc/ada/s-tfsetr-vxworks.adb
index ad7bf03629..cb57b5e00e 100644
--- a/gcc/ada/s-tfsetr-vxworks.adb
+++ b/gcc/ada/s-tfsetr-vxworks.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2009, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -98,7 +98,6 @@ begin
-- Unrecognized events are given the special Id_Event value 29999
when others => Id_Event := 29999;
-
end case;
Wv_Event (Id_Event, Info_Trace'Address, Max_Size);
diff --git a/gcc/ada/s-tpoben.adb b/gcc/ada/s-tpoben.adb
index 9131f8c07b..ddea94802b 100644
--- a/gcc/ada/s-tpoben.adb
+++ b/gcc/ada/s-tpoben.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2016, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -171,11 +171,12 @@ package body System.Tasking.Protected_Objects.Entries is
-----------------------------------
procedure Initialize_Protection_Entries
- (Object : Protection_Entries_Access;
- Ceiling_Priority : Integer;
- Compiler_Info : System.Address;
- Entry_Bodies : Protected_Entry_Body_Access;
- Find_Body_Index : Find_Body_Index_Access)
+ (Object : Protection_Entries_Access;
+ Ceiling_Priority : Integer;
+ Compiler_Info : System.Address;
+ Entry_Queue_Maxes : Protected_Entry_Queue_Max_Access;
+ Entry_Bodies : Protected_Entry_Body_Access;
+ Find_Body_Index : Find_Body_Index_Access)
is
Init_Priority : Integer := Ceiling_Priority;
Self_ID : constant Task_Id := STPO.Self;
@@ -205,14 +206,15 @@ package body System.Tasking.Protected_Objects.Entries is
Initialize_Lock (Init_Priority, Object.L'Access);
Initialization.Undefer_Abort_Nestable (Self_ID);
- Object.Ceiling := System.Any_Priority (Init_Priority);
- Object.New_Ceiling := System.Any_Priority (Init_Priority);
- Object.Owner := Null_Task;
- Object.Compiler_Info := Compiler_Info;
- Object.Pending_Action := False;
- Object.Call_In_Progress := null;
- Object.Entry_Bodies := Entry_Bodies;
- Object.Find_Body_Index := Find_Body_Index;
+ Object.Ceiling := System.Any_Priority (Init_Priority);
+ Object.New_Ceiling := System.Any_Priority (Init_Priority);
+ Object.Owner := Null_Task;
+ Object.Compiler_Info := Compiler_Info;
+ Object.Pending_Action := False;
+ Object.Call_In_Progress := null;
+ Object.Entry_Queue_Maxes := Entry_Queue_Maxes;
+ Object.Entry_Bodies := Entry_Bodies;
+ Object.Find_Body_Index := Find_Body_Index;
for E in Object.Entry_Queues'Range loop
Object.Entry_Queues (E).Head := null;
@@ -376,18 +378,6 @@ package body System.Tasking.Protected_Objects.Entries is
Object.New_Ceiling := Prio;
end Set_Ceiling;
- ---------------------
- -- Set_Entry_Names --
- ---------------------
-
- procedure Set_Entry_Names
- (Object : Protection_Entries_Access;
- Names : Protected_Entry_Names_Access)
- is
- begin
- Object.Entry_Names := Names;
- end Set_Entry_Names;
-
--------------------
-- Unlock_Entries --
--------------------
diff --git a/gcc/ada/s-tpoben.ads b/gcc/ada/s-tpoben.ads
index 8a91bbb03e..8f928204d6 100644
--- a/gcc/ada/s-tpoben.ads
+++ b/gcc/ada/s-tpoben.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -50,30 +50,31 @@ package System.Tasking.Protected_Objects.Entries is
subtype Positive_Protected_Entry_Index is
Protected_Entry_Index range 1 .. Protected_Entry_Index'Last;
+ -- Index of the entry (and in some cases of the queue)
type Find_Body_Index_Access is access
function
(O : System.Address;
E : Protected_Entry_Index)
return Protected_Entry_Index;
+ -- Convert a queue index to an entry index (an entry family has one entry
+ -- index for several queue indexes).
type Protected_Entry_Body_Array is
array (Positive_Protected_Entry_Index range <>) of Entry_Body;
-- Contains executable code for all entry bodies of a protected type
- type Protected_Entry_Body_Access is access all Protected_Entry_Body_Array;
+ type Protected_Entry_Body_Access is
+ access constant Protected_Entry_Body_Array;
type Protected_Entry_Queue_Array is
array (Protected_Entry_Index range <>) of Entry_Queue;
- -- The following declarations define an array that contains the string
- -- names of entries and entry family members, together with an associated
- -- access type.
+ type Protected_Entry_Queue_Max_Array is
+ array (Positive_Protected_Entry_Index range <>) of Natural;
- type Protected_Entry_Names_Array is
- array (Entry_Index range <>) of String_Access;
-
- type Protected_Entry_Names_Access is access all Protected_Entry_Names_Array;
+ type Protected_Entry_Queue_Max_Access is
+ access constant Protected_Entry_Queue_Max_Array;
-- The following type contains the GNARL state of a protected object.
-- The application-defined portion of the state (i.e. private objects)
@@ -142,12 +143,12 @@ package System.Tasking.Protected_Objects.Entries is
-- A function which maps the entry index in a call (which denotes the
-- queue of the proper entry) into the body of the entry.
- Entry_Queues : Protected_Entry_Queue_Array (1 .. Num_Entries);
+ Entry_Queue_Maxes : Protected_Entry_Queue_Max_Access;
+ -- Access to an array of naturals representing the max value for each
+ -- entry's queue length. A value of 0 signifies no max.
- Entry_Names : Protected_Entry_Names_Access := null;
- -- An array of string names which denotes entry [family member] names.
- -- The structure is indexed by protected entry index and contains Num_
- -- Entries components.
+ Entry_Queues : Protected_Entry_Queue_Array (1 .. Num_Entries);
+ -- Action and barrier subprograms for the protected type.
end record;
-- No default initial values for this type, since call records will need to
@@ -175,11 +176,12 @@ package System.Tasking.Protected_Objects.Entries is
-- System.Tasking.Protected_Objects.Initialize_Protection.
procedure Initialize_Protection_Entries
- (Object : Protection_Entries_Access;
- Ceiling_Priority : Integer;
- Compiler_Info : System.Address;
- Entry_Bodies : Protected_Entry_Body_Access;
- Find_Body_Index : Find_Body_Index_Access);
+ (Object : Protection_Entries_Access;
+ Ceiling_Priority : Integer;
+ Compiler_Info : System.Address;
+ Entry_Queue_Maxes : Protected_Entry_Queue_Max_Access;
+ Entry_Bodies : Protected_Entry_Body_Access;
+ Find_Body_Index : Find_Body_Index_Access);
-- Initialize the Object parameter so that it can be used by the runtime
-- to keep track of the runtime state of a protected object.
@@ -217,12 +219,6 @@ package System.Tasking.Protected_Objects.Entries is
Prio : System.Any_Priority);
-- Sets the new ceiling priority of the protected object
- procedure Set_Entry_Names
- (Object : Protection_Entries_Access;
- Names : Protected_Entry_Names_Access);
- -- Associate an array of string that denote entry [family] names with a
- -- protected object.
-
procedure Unlock_Entries (Object : Protection_Entries_Access);
-- Relinquish ownership of the lock for the object represented by the
-- Object parameter. If this ownership was for write access, or if it was
diff --git a/gcc/ada/s-tpobop.adb b/gcc/ada/s-tpobop.adb
index aaf18208e5..379ec41dfe 100644
--- a/gcc/ada/s-tpobop.adb
+++ b/gcc/ada/s-tpobop.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2016, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -292,17 +292,17 @@ package body System.Tasking.Protected_Objects.Operations is
is
E : constant Protected_Entry_Index :=
Protected_Entry_Index (Entry_Call.E);
+ Index : constant Protected_Entry_Index :=
+ Object.Find_Body_Index (Object.Compiler_Info, E);
Barrier_Value : Boolean;
-
+ Queue_Length : Natural;
begin
-- When the Action procedure for an entry body returns, it is either
-- completed (having called [Exceptional_]Complete_Entry_Body) or it
-- is queued, having executed a requeue statement.
Barrier_Value :=
- Object.Entry_Bodies (
- Object.Find_Body_Index (Object.Compiler_Info, E)).
- Barrier (Object.Compiler_Info, E);
+ Object.Entry_Bodies (Index).Barrier (Object.Compiler_Info, E);
if Barrier_Value then
@@ -316,8 +316,7 @@ package body System.Tasking.Protected_Objects.Operations is
pragma Debug
(Debug.Trace (Self_ID, "PODOQ: start entry body", 'P'));
- Object.Entry_Bodies (
- Object.Find_Body_Index (Object.Compiler_Info, E)).Action (
+ Object.Entry_Bodies (Index).Action (
Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E);
if Object.Call_In_Progress /= null then
@@ -345,32 +344,49 @@ package body System.Tasking.Protected_Objects.Operations is
elsif Entry_Call.Mode /= Conditional_Call
or else not Entry_Call.With_Abort
then
-
if Run_Time_Restrictions.Set (Max_Entry_Queue_Length)
- and then
- Run_Time_Restrictions.Value (Max_Entry_Queue_Length) <=
- Queuing.Count_Waiting (Object.Entry_Queues (E))
+ or else Object.Entry_Queue_Maxes /= null
then
- -- This violates the Max_Entry_Queue_Length restriction,
- -- raise Program_Error.
+ -- Need to check the queue length. Computing the length is an
+ -- unusual case and is slow (need to walk the queue).
+
+ Queue_Length := Queuing.Count_Waiting (Object.Entry_Queues (E));
+
+ if (Run_Time_Restrictions.Set (Max_Entry_Queue_Length)
+ and then Queue_Length >=
+ Run_Time_Restrictions.Value (Max_Entry_Queue_Length))
+ or else
+ (Object.Entry_Queue_Maxes /= null
+ and then Object.Entry_Queue_Maxes (Index) /= 0
+ and then Queue_Length >= Object.Entry_Queue_Maxes (Index))
+ then
+ -- This violates the Max_Entry_Queue_Length restriction or the
+ -- Max_Queue_Length bound, raise Program_Error.
- Entry_Call.Exception_To_Raise := Program_Error'Identity;
+ Entry_Call.Exception_To_Raise := Program_Error'Identity;
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
+ if Single_Lock then
+ STPO.Lock_RTS;
+ end if;
- STPO.Write_Lock (Entry_Call.Self);
- Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
- STPO.Unlock (Entry_Call.Self);
+ STPO.Write_Lock (Entry_Call.Self);
+ Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
+ STPO.Unlock (Entry_Call.Self);
- if Single_Lock then
- STPO.Unlock_RTS;
+ if Single_Lock then
+ STPO.Unlock_RTS;
+ end if;
+
+ return;
end if;
- else
- Queuing.Enqueue (Object.Entry_Queues (E), Entry_Call);
- Update_For_Queue_To_PO (Entry_Call, Entry_Call.With_Abort);
end if;
+
+ -- Do the work: queue the call
+
+ Queuing.Enqueue (Object.Entry_Queues (E), Entry_Call);
+ Update_For_Queue_To_PO (Entry_Call, Entry_Call.With_Abort);
+
+ return;
else
-- Conditional_Call and With_Abort
@@ -655,7 +671,9 @@ package body System.Tasking.Protected_Objects.Operations is
else
case Mode is
- when Simple_Call | Conditional_Call =>
+ when Conditional_Call
+ | Simple_Call
+ =>
if Single_Lock then
STPO.Lock_RTS;
Entry_Calls.Wait_For_Completion (Entry_Call);
@@ -669,7 +687,9 @@ package body System.Tasking.Protected_Objects.Operations is
Block.Cancelled := Entry_Call.State = Cancelled;
- when Asynchronous_Call | Timed_Call =>
+ when Asynchronous_Call
+ | Timed_Call
+ =>
pragma Assert (False);
null;
end case;
diff --git a/gcc/ada/s-tporft.adb b/gcc/ada/s-tporft.adb
index 32bb1f08db..2f22f8aaac 100644
--- a/gcc/ada/s-tporft.adb
+++ b/gcc/ada/s-tporft.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2002-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2002-2016, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -66,7 +66,7 @@ begin
(Self_Id, null, Null_Address, Null_Task,
Foreign_Task_Elaborated'Access,
System.Priority'First, System.Multiprocessors.Not_A_Specific_CPU, null,
- Task_Info.Unspecified_Task_Info, 0, Self_Id, Succeeded);
+ Task_Info.Unspecified_Task_Info, 0, 0, Self_Id, Succeeded);
Unlock_RTS;
pragma Assert (Succeeded);
diff --git a/gcc/ada/s-tposen.adb b/gcc/ada/s-tposen.adb
index 4487c5eee2..9bdf7f8223 100644
--- a/gcc/ada/s-tposen.adb
+++ b/gcc/ada/s-tposen.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2016, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -215,10 +215,10 @@ package body System.Tasking.Protected_Objects.Single_Entry is
---------------------------------
procedure Initialize_Protection_Entry
- (Object : Protection_Entry_Access;
- Ceiling_Priority : Integer;
- Compiler_Info : System.Address;
- Entry_Body : Entry_Body_Access)
+ (Object : Protection_Entry_Access;
+ Ceiling_Priority : Integer;
+ Compiler_Info : System.Address;
+ Entry_Body : Entry_Body_Access)
is
begin
Initialize_Protection (Object.Common'Access, Ceiling_Priority);
diff --git a/gcc/ada/s-tposen.ads b/gcc/ada/s-tposen.ads
index 3bb0aa8e6d..ea0513a179 100644
--- a/gcc/ada/s-tposen.ads
+++ b/gcc/ada/s-tposen.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -182,11 +182,14 @@ package System.Tasking.Protected_Objects.Single_Entry is
type Protection_Entry_Access is access all Protection_Entry;
+ type Entry_Body_Access is access constant Entry_Body;
+ -- Access to barrier and action function of an entry
+
procedure Initialize_Protection_Entry
- (Object : Protection_Entry_Access;
- Ceiling_Priority : Integer;
- Compiler_Info : System.Address;
- Entry_Body : Entry_Body_Access);
+ (Object : Protection_Entry_Access;
+ Ceiling_Priority : Integer;
+ Compiler_Info : System.Address;
+ Entry_Body : Entry_Body_Access);
-- Initialize the Object parameter so that it can be used by the run time
-- to keep track of the runtime state of a protected object.
diff --git a/gcc/ada/s-tratas-default.adb b/gcc/ada/s-tratas-default.adb
index 24f0d24818..9e45771bd0 100644
--- a/gcc/ada/s-tratas-default.adb
+++ b/gcc/ada/s-tratas-default.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
-- --
-- GNARL is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -62,7 +62,9 @@ package body System.Traces.Tasking is
begin
if Parameters.Runtime_Traces then
case Id is
- when M_RDV_Complete | PO_Done =>
+ when M_RDV_Complete
+ | PO_Done
+ =>
Trace_S (1 .. 3) := "/N:";
Trace_S (4 .. 3 + L0) := Task_S;
Trace_S (4 + L0 .. 6 + L0) := "/C:";
diff --git a/gcc/ada/s-unstyp.ads b/gcc/ada/s-unstyp.ads
index 9eefc15b59..f9ad3853a0 100644
--- a/gcc/ada/s-unstyp.ads
+++ b/gcc/ada/s-unstyp.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -39,6 +39,7 @@ pragma Compiler_Unit_Warning;
package System.Unsigned_Types is
pragma Pure;
+ pragma No_Elaboration_Code_All;
type Short_Short_Unsigned is mod 2 ** Short_Short_Integer'Size;
type Short_Unsigned is mod 2 ** Short_Integer'Size;
@@ -59,6 +60,7 @@ package System.Unsigned_Types is
type Packed_Bytes1 is array (Natural range <>) of aliased Packed_Byte;
for Packed_Bytes1'Alignment use 1;
for Packed_Bytes1'Component_Size use Packed_Byte'Size;
+ pragma Suppress_Initialization (Packed_Bytes1);
-- This is the type used to implement packed arrays where no alignment
-- is required. This includes the cases of 1,2,4 (where we use direct
-- masking operations), and all odd component sizes (where the clusters
@@ -67,6 +69,7 @@ package System.Unsigned_Types is
type Packed_Bytes2 is new Packed_Bytes1;
for Packed_Bytes2'Alignment use Integer'Min (2, Standard'Maximum_Alignment);
+ pragma Suppress_Initialization (Packed_Bytes2);
-- This is the type used to implement packed arrays where an alignment
-- of 2 (is possible) is helpful for maximum efficiency of the get and
-- set routines in the corresponding library unit. This is true of all
@@ -77,6 +80,7 @@ package System.Unsigned_Types is
type Packed_Bytes4 is new Packed_Bytes1;
for Packed_Bytes4'Alignment use Integer'Min (4, Standard'Maximum_Alignment);
+ pragma Suppress_Initialization (Packed_Bytes4);
-- This is the type used to implement packed arrays where an alignment
-- of 4 (if possible) is helpful for maximum efficiency of the get and
-- set routines in the corresponding library unit. This is true of all
diff --git a/gcc/ada/s-wchcnv.adb b/gcc/ada/s-wchcnv.adb
index 345af8f57d..7e2ab08e55 100644
--- a/gcc/ada/s-wchcnv.adb
+++ b/gcc/ada/s-wchcnv.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -97,7 +97,6 @@ package body System.WCh_Cnv is
begin
case EM is
-
when WCEM_Hex =>
if C /= ASCII.ESC then
return Character'Pos (C);
@@ -245,7 +244,6 @@ package body System.WCh_Cnv is
end if;
return UTF_32_Code (B1);
-
end case;
end Char_Sequence_To_UTF_32;
@@ -293,7 +291,6 @@ package body System.WCh_Cnv is
-- Processing depends on encoding mode
case EM is
-
when WCEM_Hex =>
if Val < 256 then
Out_Char (Character'Val (Val));
diff --git a/gcc/ada/scans.adb b/gcc/ada/scans.adb
index 121ab11a8f..a4df868467 100644
--- a/gcc/ada/scans.adb
+++ b/gcc/ada/scans.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -140,9 +140,32 @@ package body Scans is
-- Ada 2012 reserved words
Set_Reserved (Name_Some, Tok_Some);
-
end Initialize_Ada_Keywords;
+ ------------------
+ -- Keyword_Name --
+ ------------------
+
+ function Keyword_Name (Token : Token_Type) return Name_Id is
+ Tok : String := Token'Img;
+ pragma Assert (Tok (1 .. 4) = "TOK_");
+ Name : String renames Tok (5 .. Tok'Last);
+
+ begin
+ -- Convert to lower case. We don't want to add a dependence on a
+ -- general-purpose To_Lower routine, so we convert "by hand" here.
+ -- All keywords use 7-bit ASCII letters only, so this works.
+
+ for J in Name'Range loop
+ pragma Assert (Name (J) in 'A' .. 'Z');
+ Name (J) :=
+ Character'Val (Character'Pos (Name (J)) +
+ (Character'Pos ('a') - Character'Pos ('A')));
+ end loop;
+
+ return Name_Find (Name);
+ end Keyword_Name;
+
------------------------
-- Restore_Scan_State --
------------------------
diff --git a/gcc/ada/scans.ads b/gcc/ada/scans.ads
index 682bb6c72f..8ff3f9d0e2 100644
--- a/gcc/ada/scans.ads
+++ b/gcc/ada/scans.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -45,10 +45,6 @@ package Scans is
-- The class column in this table indicates the token classes which
-- apply to the token, as defined by subsequent subtype declarations.
- -- Note: Namet.Is_Keyword_Name depends on the fact that the first entry in
- -- this type declaration is *not* for a reserved word. For details on why
- -- there is this requirement, see Initialize_Ada_Keywords below.
-
type Token_Type is (
-- Token name Token type Class(es)
@@ -65,6 +61,8 @@ package Scans is
Tok_Identifier, -- identifier Name, Lit_Or_Name, Desig
+ Tok_At_Sign, -- @ AI12-0125-3 : target name
+
Tok_Double_Asterisk, -- **
Tok_Ampersand, -- & Binary_Addop
@@ -217,8 +215,10 @@ package Scans is
-- also when scanning project files (where it is needed because of ???)
Tok_Special,
- -- Used only in preprocessor scanning (to represent one of the
- -- characters '#', '$', '?', '@', '`', '\', '^', '~', or '_'. The
+ -- AI12-0125-03 : target name as abbreviation for LHS
+
+ -- Otherwise used only in preprocessor scanning (to represent one of
+ -- the characters '#', '$', '?', '@', '`', '\', '^', '~', or '_'. The
-- character value itself is stored in Scans.Special_Character.
Tok_SPARK_Hide,
@@ -228,6 +228,11 @@ package Scans is
-- No_Token is used for initializing Token values to indicate that
-- no value has been set yet.
+ function Keyword_Name (Token : Token_Type) return Name_Id;
+ -- Given a token that is a reserved word, return the corresponding Name_Id
+ -- in lower case. E.g. Keyword_Name (Tok_Begin) = Name_Find ("begin").
+ -- It is an error to pass any other kind of token.
+
-- Note: in the RM, operator symbol is a special case of string literal.
-- We distinguish at the lexical level in this compiler, since there are
-- many syntactic situations in which only an operator symbol is allowed.
@@ -268,12 +273,13 @@ package Scans is
-- of Pascal style not equal operator).
subtype Token_Class_Name is
- Token_Type range Tok_Char_Literal .. Tok_Identifier;
+ Token_Type range Tok_Char_Literal .. Tok_At_Sign;
-- First token of name (4.1),
-- (identifier, char literal, operator symbol)
+ -- Includes '@' after Ada2012 corrigendum.
subtype Token_Class_Desig is
- Token_Type range Tok_Operator_Symbol .. Tok_Identifier;
+ Token_Type range Tok_Operator_Symbol .. Tok_At_Sign;
-- Token which can be a Designator (identifier, operator symbol)
subtype Token_Class_Namext is
@@ -396,6 +402,11 @@ package Scans is
-- file being compiled. This CRC includes only program tokens, and
-- excludes comments.
+ Limited_Checksum : Word := 0;
+ -- Used to accumulate a CRC representing significant tokens in the
+ -- limited view of a package, i.e. visible type names and related
+ -- tagged indicators.
+
First_Non_Blank_Location : Source_Ptr := No_Location; -- init for -gnatVa
-- Location of first non-blank character on the line containing the
-- current token (i.e. the location of the character whose column number
@@ -460,8 +471,9 @@ package Scans is
-- Wide_Character).
Special_Character : Character;
+ -- AI12-0125-03 : '@' as target name is handled elsewhere.
-- Valid only when Token = Tok_Special. Returns one of the characters
- -- '#', '$', '?', '@', '`', '\', '^', '~', or '_'.
+ -- '#', '$', '?', '`', '\', '^', '~', or '_'.
--
-- Why only this set? What about wide characters???
diff --git a/gcc/ada/scil_ll.adb b/gcc/ada/scil_ll.adb
index 470ac98382..151fda3c99 100644
--- a/gcc/ada/scil_ll.adb
+++ b/gcc/ada/scil_ll.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2010-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,11 +29,10 @@
-- --
------------------------------------------------------------------------------
-with Alloc; use Alloc;
-with Atree; use Atree;
-with Opt; use Opt;
-with Sinfo; use Sinfo;
-with Table;
+with Atree; use Atree;
+with Opt; use Opt;
+with Sinfo; use Sinfo;
+with System.HTable; use System.HTable;
package body SCIL_LL is
@@ -41,32 +40,42 @@ package body SCIL_LL is
-- Copy the SCIL field from Source to Target (it is used as the argument
-- for a call to Set_Reporting_Proc in package atree).
- function SCIL_Nodes_Table_Size return Pos;
- -- Used to initialize the table of SCIL nodes because we do not want
- -- to consume memory for this table if it is not required.
-
- ----------------------------
- -- SCIL_Nodes_Table_Size --
- ----------------------------
-
- function SCIL_Nodes_Table_Size return Pos is
- begin
- if Generate_SCIL then
- return Alloc.Orig_Nodes_Initial;
- else
- return 1;
- end if;
- end SCIL_Nodes_Table_Size;
-
- package SCIL_Nodes is new Table.Table (
- Table_Component_Type => Node_Id,
- Table_Index_Type => Node_Id'Base,
- Table_Low_Bound => First_Node_Id,
- Table_Initial => SCIL_Nodes_Table_Size,
- Table_Increment => Alloc.Orig_Nodes_Increment,
- Table_Name => "SCIL_Nodes");
- -- This table records the value of attribute SCIL_Node of all the
- -- tree nodes.
+ type Header_Num is range 1 .. 4096;
+
+ function Hash (N : Node_Id) return Header_Num;
+ -- Hash function for Node_Ids
+
+ --------------------------
+ -- Internal Hash Tables --
+ --------------------------
+
+ package Contract_Only_Body_Flag is new Simple_HTable
+ (Header_Num => Header_Num,
+ Element => Boolean,
+ No_Element => False,
+ Key => Node_Id,
+ Hash => Hash,
+ Equal => "=");
+ -- This table records the value of flag Is_Contract_Only_Flag of tree nodes
+
+ package Contract_Only_Body_Nodes is new Simple_HTable
+ (Header_Num => Header_Num,
+ Element => Node_Id,
+ No_Element => Empty,
+ Key => Node_Id,
+ Hash => Hash,
+ Equal => "=");
+ -- This table records the value of attribute Contract_Only_Body of tree
+ -- nodes.
+
+ package SCIL_Nodes is new Simple_HTable
+ (Header_Num => Header_Num,
+ Element => Node_Id,
+ No_Element => Empty,
+ Key => Node_Id,
+ Hash => Hash,
+ Equal => "=");
+ -- This table records the value of attribute SCIL_Node of tree nodes
--------------------
-- Copy_SCIL_Node --
@@ -77,15 +86,20 @@ package body SCIL_LL is
Set_SCIL_Node (Target, Get_SCIL_Node (Source));
end Copy_SCIL_Node;
- ----------------
- -- Initialize --
- ----------------
+ ----------------------------
+ -- Get_Contract_Only_Body --
+ ----------------------------
- procedure Initialize is
+ function Get_Contract_Only_Body (N : Node_Id) return Node_Id is
begin
- SCIL_Nodes.Init;
- Set_Reporting_Proc (Copy_SCIL_Node'Access);
- end Initialize;
+ if CodePeer_Mode
+ and then Present (N)
+ then
+ return Contract_Only_Body_Nodes.Get (N);
+ else
+ return Empty;
+ end if;
+ end Get_Contract_Only_Body;
-------------------
-- Get_SCIL_Node --
@@ -96,12 +110,64 @@ package body SCIL_LL is
if Generate_SCIL
and then Present (N)
then
- return SCIL_Nodes.Table (N);
+ return SCIL_Nodes.Get (N);
else
return Empty;
end if;
end Get_SCIL_Node;
+ ----------
+ -- Hash --
+ ----------
+
+ function Hash (N : Node_Id) return Header_Num is
+ begin
+ return Header_Num (1 + N mod Node_Id (Header_Num'Last));
+ end Hash;
+
+ ----------------
+ -- Initialize --
+ ----------------
+
+ procedure Initialize is
+ begin
+ SCIL_Nodes.Reset;
+ Contract_Only_Body_Nodes.Reset;
+ Contract_Only_Body_Flag.Reset;
+ Set_Reporting_Proc (Copy_SCIL_Node'Access);
+ end Initialize;
+
+ ---------------------------
+ -- Is_Contract_Only_Body --
+ ---------------------------
+
+ function Is_Contract_Only_Body (E : Entity_Id) return Boolean is
+ begin
+ return Contract_Only_Body_Flag.Get (E);
+ end Is_Contract_Only_Body;
+
+ ----------------------------
+ -- Set_Contract_Only_Body --
+ ----------------------------
+
+ procedure Set_Contract_Only_Body (N : Node_Id; Value : Node_Id) is
+ begin
+ pragma Assert (CodePeer_Mode
+ and then Present (N)
+ and then Is_Contract_Only_Body (Value));
+
+ Contract_Only_Body_Nodes.Set (N, Value);
+ end Set_Contract_Only_Body;
+
+ -------------------------------
+ -- Set_Is_Contract_Only_Body --
+ -------------------------------
+
+ procedure Set_Is_Contract_Only_Body (E : Entity_Id) is
+ begin
+ Contract_Only_Body_Flag.Set (E, True);
+ end Set_Is_Contract_Only_Body;
+
-------------------
-- Set_SCIL_Node --
-------------------
@@ -133,11 +199,7 @@ package body SCIL_LL is
end case;
end if;
- if Atree.Last_Node_Id > SCIL_Nodes.Last then
- SCIL_Nodes.Set_Last (Atree.Last_Node_Id);
- end if;
-
- SCIL_Nodes.Set_Item (N, Value);
+ SCIL_Nodes.Set (N, Value);
end Set_SCIL_Node;
end SCIL_LL;
diff --git a/gcc/ada/scil_ll.ads b/gcc/ada/scil_ll.ads
index 8265a19df3..bebe0e7ffa 100644
--- a/gcc/ada/scil_ll.ads
+++ b/gcc/ada/scil_ll.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2010, Free Software Foundation, Inc. --
+-- Copyright (C) 2010-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,20 +29,32 @@
-- --
------------------------------------------------------------------------------
--- This package extends the tree nodes with a field that is used to reference
--- the SCIL node.
+-- This package extends the tree nodes with fields that are used to reference
+-- the SCIL node and the Contract_Only_Body of a subprogram with aspects.
with Types; use Types;
package SCIL_LL is
+ function Get_Contract_Only_Body (N : Node_Id) return Node_Id;
+ -- Read the value of attribute Contract_Only_Body
+
function Get_SCIL_Node (N : Node_Id) return Node_Id;
-- Read the value of attribute SCIL node
+ procedure Set_Contract_Only_Body (N : Node_Id; Value : Node_Id);
+ -- Set the value of attribute Contract_Only_Body
+
procedure Set_SCIL_Node (N : Node_Id; Value : Node_Id);
-- Set the value of attribute SCIL node
procedure Initialize;
-- Initialize the table of SCIL nodes
+ function Is_Contract_Only_Body (E : Entity_Id) return Boolean;
+ -- Return True if E is a Contract_Only_Body subprogram
+
+ procedure Set_Is_Contract_Only_Body (E : Entity_Id);
+ -- Set E as Contract_Only_Body subprogram
+
end SCIL_LL;
diff --git a/gcc/ada/scn.adb b/gcc/ada/scn.adb
index cc88ab9c12..ef0311619d 100644
--- a/gcc/ada/scn.adb
+++ b/gcc/ada/scn.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -383,6 +383,14 @@ package body Scn is
Token_Chars : constant String := Token_Type'Image (Token);
begin
+ -- AI12-0125 : '@' denotes the target_name, i.e. serves as an
+ -- abbreviation for the LHS of an assignment.
+
+ if Token = Tok_At_Sign then
+ Token_Node := New_Node (N_Target_Name, Token_Ptr);
+ return;
+ end if;
+
-- We have in Token_Chars the image of the Token name, i.e. Tok_xxx.
-- This code extracts the xxx and makes an identifier out of it.
diff --git a/gcc/ada/scn.ads b/gcc/ada/scn.ads
index ea7b22be9f..f5628a9e4e 100644
--- a/gcc/ada/scn.ads
+++ b/gcc/ada/scn.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -44,8 +44,8 @@ package Scn is
-- source index for reading the configuration pragma file.
function Determine_Token_Casing return Casing_Type;
- -- Determines the casing style of the current token, which is
- -- either a keyword or an identifier. See also package Casing.
+ -- Determines the casing style of the current token, which is either a
+ -- keyword or an identifier. See also package Casing.
procedure Post_Scan;
-- Create nodes for tokens: Char_Literal, Identifier, Real_Literal,
diff --git a/gcc/ada/scng.adb b/gcc/ada/scng.adb
index f0a9013a8b..a46b80ce64 100644
--- a/gcc/ada/scng.adb
+++ b/gcc/ada/scng.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -149,45 +149,132 @@ package body Scng is
-- Token_Type are detected by the compiler.
case Token is
- when Tok_Integer_Literal | Tok_Real_Literal | Tok_String_Literal |
- Tok_Char_Literal | Tok_Operator_Symbol | Tok_Identifier |
- Tok_Double_Asterisk | Tok_Ampersand | Tok_Minus | Tok_Plus |
- Tok_Asterisk | Tok_Mod | Tok_Rem | Tok_Slash | Tok_New |
- Tok_Abs | Tok_Others | Tok_Null | Tok_Dot | Tok_Apostrophe |
- Tok_Left_Paren | Tok_Delta | Tok_Digits | Tok_Range |
- Tok_Right_Paren | Tok_Comma | Tok_And | Tok_Or | Tok_Xor |
- Tok_Less | Tok_Equal | Tok_Greater | Tok_Not_Equal |
- Tok_Greater_Equal | Tok_Less_Equal | Tok_In | Tok_Not |
- Tok_Box | Tok_Colon_Equal | Tok_Colon | Tok_Greater_Greater |
- Tok_Abstract | Tok_Access | Tok_Aliased | Tok_All | Tok_Array |
- Tok_At | Tok_Body | Tok_Constant | Tok_Do | Tok_Is |
- Tok_Interface | Tok_Limited | Tok_Of | Tok_Out | Tok_Record |
- Tok_Renames | Tok_Reverse =>
-
+ when Tok_Abs
+ | Tok_Abstract
+ | Tok_Access
+ | Tok_Aliased
+ | Tok_All
+ | Tok_Ampersand
+ | Tok_And
+ | Tok_Apostrophe
+ | Tok_Array
+ | Tok_Asterisk
+ | Tok_At
+ | Tok_At_Sign
+ | Tok_Body
+ | Tok_Box
+ | Tok_Char_Literal
+ | Tok_Colon
+ | Tok_Colon_Equal
+ | Tok_Comma
+ | Tok_Constant
+ | Tok_Delta
+ | Tok_Digits
+ | Tok_Do
+ | Tok_Dot
+ | Tok_Double_Asterisk
+ | Tok_Equal
+ | Tok_Greater
+ | Tok_Greater_Equal
+ | Tok_Greater_Greater
+ | Tok_Identifier
+ | Tok_In
+ | Tok_Integer_Literal
+ | Tok_Interface
+ | Tok_Is
+ | Tok_Left_Paren
+ | Tok_Less
+ | Tok_Less_Equal
+ | Tok_Limited
+ | Tok_Minus
+ | Tok_Mod
+ | Tok_New
+ | Tok_Not
+ | Tok_Not_Equal
+ | Tok_Null
+ | Tok_Of
+ | Tok_Operator_Symbol
+ | Tok_Or
+ | Tok_Others
+ | Tok_Out
+ | Tok_Plus
+ | Tok_Range
+ | Tok_Real_Literal
+ | Tok_Record
+ | Tok_Rem
+ | Tok_Renames
+ | Tok_Reverse
+ | Tok_Right_Paren
+ | Tok_Slash
+ | Tok_String_Literal
+ | Tok_Xor
+ =>
System.CRC32.Update
(System.CRC32.CRC32 (Checksum),
Character'Val (Token_Type'Pos (Token)));
when Tok_Some =>
-
System.CRC32.Update
(System.CRC32.CRC32 (Checksum),
Character'Val (Token_Type'Pos (Tok_Identifier)));
- when Tok_Tagged | Tok_Then | Tok_Less_Less | Tok_Abort | Tok_Accept |
- Tok_Case | Tok_Delay | Tok_Else | Tok_Elsif | Tok_End |
- Tok_Exception | Tok_Exit | Tok_Goto | Tok_If | Tok_Pragma |
- Tok_Raise | Tok_Requeue | Tok_Return | Tok_Select |
- Tok_Terminate | Tok_Until | Tok_When | Tok_Begin | Tok_Declare |
- Tok_For | Tok_Loop | Tok_While | Tok_Entry | Tok_Protected |
- Tok_Task | Tok_Type | Tok_Subtype | Tok_Overriding |
- Tok_Synchronized | Tok_Use | Tok_Function | Tok_Generic |
- Tok_Package | Tok_Procedure | Tok_Private | Tok_With |
- Tok_Separate | Tok_EOF | Tok_Semicolon | Tok_Arrow |
- Tok_Vertical_Bar | Tok_Dot_Dot | Tok_Project | Tok_Extends |
- Tok_External | Tok_External_As_List | Tok_Comment |
- Tok_End_Of_Line | Tok_Special | Tok_SPARK_Hide | No_Token =>
-
+ when No_Token
+ | Tok_Abort
+ | Tok_Accept
+ | Tok_Arrow
+ | Tok_Begin
+ | Tok_Case
+ | Tok_Comment
+ | Tok_Declare
+ | Tok_Delay
+ | Tok_Dot_Dot
+ | Tok_Else
+ | Tok_Elsif
+ | Tok_End
+ | Tok_End_Of_Line
+ | Tok_Entry
+ | Tok_EOF
+ | Tok_Exception
+ | Tok_Exit
+ | Tok_Extends
+ | Tok_External
+ | Tok_External_As_List
+ | Tok_For
+ | Tok_Function
+ | Tok_Generic
+ | Tok_Goto
+ | Tok_If
+ | Tok_Less_Less
+ | Tok_Loop
+ | Tok_Overriding
+ | Tok_Package
+ | Tok_Pragma
+ | Tok_Private
+ | Tok_Procedure
+ | Tok_Project
+ | Tok_Protected
+ | Tok_Raise
+ | Tok_Requeue
+ | Tok_Return
+ | Tok_Select
+ | Tok_Semicolon
+ | Tok_Separate
+ | Tok_SPARK_Hide
+ | Tok_Special
+ | Tok_Subtype
+ | Tok_Synchronized
+ | Tok_Tagged
+ | Tok_Task
+ | Tok_Terminate
+ | Tok_Then
+ | Tok_Type
+ | Tok_Until
+ | Tok_Use
+ | Tok_Vertical_Bar
+ | Tok_When
+ | Tok_While
+ | Tok_With
+ =>
System.CRC32.Update
(System.CRC32.CRC32 (Checksum),
Character'Val (Token_Type'Pos (Token_Type'Pred (Token))));
@@ -205,54 +292,143 @@ package body Scng is
-- Token_Type are detected by the compiler.
case Token is
- when Tok_Integer_Literal | Tok_Real_Literal | Tok_String_Literal |
- Tok_Char_Literal | Tok_Operator_Symbol | Tok_Identifier |
- Tok_Double_Asterisk | Tok_Ampersand | Tok_Minus | Tok_Plus |
- Tok_Asterisk | Tok_Mod | Tok_Rem | Tok_Slash | Tok_New |
- Tok_Abs | Tok_Others | Tok_Null | Tok_Dot | Tok_Apostrophe |
- Tok_Left_Paren | Tok_Delta | Tok_Digits | Tok_Range |
- Tok_Right_Paren | Tok_Comma | Tok_And | Tok_Or | Tok_Xor |
- Tok_Less | Tok_Equal | Tok_Greater | Tok_Not_Equal |
- Tok_Greater_Equal | Tok_Less_Equal | Tok_In | Tok_Not |
- Tok_Box | Tok_Colon_Equal | Tok_Colon | Tok_Greater_Greater |
- Tok_Abstract | Tok_Access | Tok_Aliased | Tok_All | Tok_Array |
- Tok_At | Tok_Body | Tok_Constant | Tok_Do | Tok_Is =>
-
+ when Tok_Abs
+ | Tok_Abstract
+ | Tok_Access
+ | Tok_Aliased
+ | Tok_All
+ | Tok_Ampersand
+ | Tok_And
+ | Tok_Apostrophe
+ | Tok_Array
+ | Tok_Asterisk
+ | Tok_At
+ | Tok_At_Sign
+ | Tok_Body
+ | Tok_Box
+ | Tok_Char_Literal
+ | Tok_Colon
+ | Tok_Colon_Equal
+ | Tok_Comma
+ | Tok_Constant
+ | Tok_Delta
+ | Tok_Digits
+ | Tok_Do
+ | Tok_Dot
+ | Tok_Double_Asterisk
+ | Tok_Equal
+ | Tok_Greater
+ | Tok_Greater_Equal
+ | Tok_Greater_Greater
+ | Tok_Identifier
+ | Tok_In
+ | Tok_Integer_Literal
+ | Tok_Is
+ | Tok_Left_Paren
+ | Tok_Less
+ | Tok_Less_Equal
+ | Tok_Minus
+ | Tok_Mod
+ | Tok_New
+ | Tok_Not
+ | Tok_Not_Equal
+ | Tok_Null
+ | Tok_Operator_Symbol
+ | Tok_Or
+ | Tok_Others
+ | Tok_Plus
+ | Tok_Range
+ | Tok_Real_Literal
+ | Tok_Rem
+ | Tok_Right_Paren
+ | Tok_Slash
+ | Tok_String_Literal
+ | Tok_Xor
+ =>
System.CRC32.Update
(System.CRC32.CRC32 (Checksum),
Character'Val (Token_Type'Pos (Token)));
- when Tok_Interface | Tok_Some | Tok_Overriding | Tok_Synchronized =>
+ when Tok_Interface
+ | Tok_Overriding
+ | Tok_Some
+ | Tok_Synchronized
+ =>
System.CRC32.Update
(System.CRC32.CRC32 (Checksum),
Character'Val (Token_Type'Pos (Tok_Identifier)));
- when Tok_Limited | Tok_Of | Tok_Out | Tok_Record |
- Tok_Renames | Tok_Reverse =>
-
+ when Tok_Limited
+ | Tok_Of
+ | Tok_Out
+ | Tok_Record
+ | Tok_Renames
+ | Tok_Reverse
+ =>
System.CRC32.Update
(System.CRC32.CRC32 (Checksum),
Character'Val (Token_Type'Pos (Token) - 1));
- when Tok_Tagged | Tok_Then | Tok_Less_Less | Tok_Abort | Tok_Accept |
- Tok_Case | Tok_Delay | Tok_Else | Tok_Elsif | Tok_End |
- Tok_Exception | Tok_Exit | Tok_Goto | Tok_If | Tok_Pragma |
- Tok_Raise | Tok_Requeue | Tok_Return | Tok_Select |
- Tok_Terminate | Tok_Until | Tok_When | Tok_Begin | Tok_Declare |
- Tok_For | Tok_Loop | Tok_While | Tok_Entry | Tok_Protected |
- Tok_Task | Tok_Type | Tok_Subtype =>
-
+ when Tok_Abort
+ | Tok_Accept
+ | Tok_Begin
+ | Tok_Case
+ | Tok_Declare
+ | Tok_Delay
+ | Tok_Else
+ | Tok_Elsif
+ | Tok_End
+ | Tok_Entry
+ | Tok_Exception
+ | Tok_Exit
+ | Tok_For
+ | Tok_Goto
+ | Tok_If
+ | Tok_Less_Less
+ | Tok_Loop
+ | Tok_Pragma
+ | Tok_Protected
+ | Tok_Raise
+ | Tok_Requeue
+ | Tok_Return
+ | Tok_Select
+ | Tok_Subtype
+ | Tok_Tagged
+ | Tok_Task
+ | Tok_Terminate
+ | Tok_Then
+ | Tok_Type
+ | Tok_Until
+ | Tok_When
+ | Tok_While
+ =>
System.CRC32.Update
(System.CRC32.CRC32 (Checksum),
Character'Val (Token_Type'Pos (Token) - 2));
- when Tok_Use | Tok_Function | Tok_Generic |
- Tok_Package | Tok_Procedure | Tok_Private | Tok_With |
- Tok_Separate | Tok_EOF | Tok_Semicolon | Tok_Arrow |
- Tok_Vertical_Bar | Tok_Dot_Dot | Tok_Project | Tok_Extends |
- Tok_External | Tok_External_As_List | Tok_Comment |
- Tok_End_Of_Line | Tok_Special | Tok_SPARK_Hide | No_Token =>
-
+ when No_Token
+ | Tok_Arrow
+ | Tok_Comment
+ | Tok_Dot_Dot
+ | Tok_End_Of_Line
+ | Tok_EOF
+ | Tok_Extends
+ | Tok_External
+ | Tok_External_As_List
+ | Tok_Function
+ | Tok_Generic
+ | Tok_Package
+ | Tok_Private
+ | Tok_Procedure
+ | Tok_Project
+ | Tok_Semicolon
+ | Tok_Separate
+ | Tok_SPARK_Hide
+ | Tok_Special
+ | Tok_Use
+ | Tok_Vertical_Bar
+ | Tok_With
+ =>
System.CRC32.Update
(System.CRC32.CRC32 (Checksum),
Character'Val (Token_Type'Pos (Token) - 4));
@@ -1435,6 +1611,20 @@ package body Scng is
return;
end if;
+ when '@' =>
+ if Ada_Version < Ada_2020 then
+ Error_Msg ("target_name is an Ada 2020 feature", Scan_Ptr);
+ Scan_Ptr := Scan_Ptr + 1;
+
+ else
+ -- AI12-0125-03 : @ is target_name
+
+ Accumulate_Checksum ('@');
+ Scan_Ptr := Scan_Ptr + 1;
+ Token := Tok_At_Sign;
+ return;
+ end if;
+
-- Asterisk (can be multiplication operator or double asterisk which
-- is the exponentiation compound delimiter).
@@ -2217,15 +2407,40 @@ package body Scng is
-- Invalid control characters
- when NUL | SOH | STX | ETX | EOT | ENQ | ACK | BEL | BS | ASCII.SO |
- SI | DLE | DC1 | DC2 | DC3 | DC4 | NAK | SYN | ETB | CAN |
- EM | FS | GS | RS | US | DEL
+ when ACK
+ | ASCII.SO
+ | BEL
+ | BS
+ | CAN
+ | DC1
+ | DC2
+ | DC3
+ | DC4
+ | DEL
+ | DLE
+ | EM
+ | ENQ
+ | EOT
+ | ETB
+ | ETX
+ | FS
+ | GS
+ | NAK
+ | NUL
+ | RS
+ | SI
+ | SOH
+ | STX
+ | SYN
+ | US
=>
Error_Illegal_Character;
-- Invalid graphic characters
+ -- Note that '@' is handled elsewhere, because following AI12-125
+ -- it denotes the target_name of an assignment.
- when '#' | '$' | '?' | '@' | '`' | '\' | '^' | '~' =>
+ when '#' | '$' | '?' | '`' | '\' | '^' | '~' =>
-- If Set_Special_Character has been called for this character,
-- set Scans.Special_Character and return a Special token.
@@ -2322,7 +2537,6 @@ package body Scng is
-- initial character of a wide character sequence.
<<Scan_Wide_Character>>
-
declare
Code : Char_Code;
Cat : Category;
diff --git a/gcc/ada/scng.ads b/gcc/ada/scng.ads
index 32ecc67d0a..d25ed54e51 100644
--- a/gcc/ada/scng.ads
+++ b/gcc/ada/scng.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -78,8 +78,10 @@ package Scng is
-- either a keyword or an identifier. See also package Casing.
procedure Set_Special_Character (C : Character);
- -- Indicate that one of the following character '#', '$', '?', '@', '`',
+ -- Indicate that one of the following character '#', '$', '?', '`',
-- '\', '^', '_' or '~', when found is a Special token.
+ -- AI12-0125-03 : target name (ES) is not in this list because '@' is
+ -- handled as a special token as abbreviation of LHS of assignment.
procedure Reset_Special_Characters;
-- Indicate that there is no characters that are Special tokens., which
diff --git a/gcc/ada/scos.ads b/gcc/ada/scos.ads
index da5cc47c5a..412a45b258 100644
--- a/gcc/ada/scos.ads
+++ b/gcc/ada/scos.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2009-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2009-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -152,6 +152,7 @@ package SCOs is
-- o object declaration
-- r renaming declaration
-- i generic instantiation
+ -- d any other kind of declaration
-- A ACCEPT statement (from ACCEPT to end of parameter profile)
-- C CASE statement (from CASE to end of expression)
-- E EXIT statement
@@ -497,6 +498,11 @@ package SCOs is
-- Used to index values in this table. Values start at 1 and are assigned
-- sequentially as entries are constructed.
+ Missing_Dep_Num : constant Nat := 0;
+ -- Represents a dependency number for a dependency that is ignored. SCO
+ -- information consumers use this to strip units that must be kept out of
+ -- the coverage analysis.
+
type SCO_Unit_Table_Entry is record
File_Name : String_Ptr;
-- Pointer to file name in ALI file
@@ -505,7 +511,9 @@ package SCOs is
-- Index for the source file
Dep_Num : Nat;
- -- Dependency number in ALI file
+ -- Dependency number in ALI file. This is a positive number when the
+ -- dependency is actually available in the context, it is
+ -- Missing_Dep_Num otherwise.
From : Nat;
-- Starting index in SCO_Table of SCO information for this unit
diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb
index 819bcd5d95..9b7c490397 100644
--- a/gcc/ada/sem.adb
+++ b/gcc/ada/sem.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -23,38 +23,40 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Debug; use Debug;
-with Debug_A; use Debug_A;
-with Elists; use Elists;
-with Expander; use Expander;
-with Fname; use Fname;
-with Ghost; use Ghost;
-with Lib; use Lib;
-with Lib.Load; use Lib.Load;
-with Nlists; use Nlists;
-with Output; use Output;
-with Restrict; use Restrict;
-with Sem_Attr; use Sem_Attr;
-with Sem_Aux; use Sem_Aux;
-with Sem_Ch2; use Sem_Ch2;
-with Sem_Ch3; use Sem_Ch3;
-with Sem_Ch4; use Sem_Ch4;
-with Sem_Ch5; use Sem_Ch5;
-with Sem_Ch6; use Sem_Ch6;
-with Sem_Ch7; use Sem_Ch7;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Ch9; use Sem_Ch9;
-with Sem_Ch10; use Sem_Ch10;
-with Sem_Ch11; use Sem_Ch11;
-with Sem_Ch12; use Sem_Ch12;
-with Sem_Ch13; use Sem_Ch13;
-with Sem_Prag; use Sem_Prag;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Stand; use Stand;
-with Uintp; use Uintp;
-with Uname; use Uname;
+with Atree; use Atree;
+with Debug; use Debug;
+with Debug_A; use Debug_A;
+with Elists; use Elists;
+with Exp_SPARK; use Exp_SPARK;
+with Expander; use Expander;
+with Fname; use Fname;
+with Ghost; use Ghost;
+with Lib; use Lib;
+with Lib.Load; use Lib.Load;
+with Nlists; use Nlists;
+with Output; use Output;
+with Restrict; use Restrict;
+with Sem_Attr; use Sem_Attr;
+with Sem_Aux; use Sem_Aux;
+with Sem_Ch2; use Sem_Ch2;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch4; use Sem_Ch4;
+with Sem_Ch5; use Sem_Ch5;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch7; use Sem_Ch7;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch9; use Sem_Ch9;
+with Sem_Ch10; use Sem_Ch10;
+with Sem_Ch11; use Sem_Ch11;
+with Sem_Ch12; use Sem_Ch12;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Prag; use Sem_Prag;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Stand; use Stand;
+with Stylesw; use Stylesw;
+with Uintp; use Uintp;
+with Uname; use Uname;
with Unchecked_Deallocation;
@@ -95,8 +97,13 @@ package body Sem is
-- Analyze --
-------------
+ -- WARNING: This routine manages Ghost regions. Return statements must be
+ -- replaced by gotos which jump to the end of the routine and restore the
+ -- Ghost mode.
+
procedure Analyze (N : Node_Id) is
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
+ Mode : Ghost_Mode_Type;
+ Mode_Set : Boolean := False;
begin
Debug_A_Entry ("analyzing ", N);
@@ -113,7 +120,8 @@ package body Sem is
-- marked as Ghost.
if Is_Declaration (N) then
- Set_Ghost_Mode (N);
+ Mark_And_Set_Ghost_Declaration (N, Mode);
+ Mode_Set := True;
end if;
-- Otherwise processing depends on the node kind
@@ -191,6 +199,9 @@ package body Sem is
when N_Delay_Until_Statement =>
Analyze_Delay_Until (N);
+ when N_Delta_Aggregate =>
+ Analyze_Aggregate (N);
+
when N_Entry_Body =>
Analyze_Entry_Body (N);
@@ -203,7 +214,7 @@ package body Sem is
when N_Entry_Declaration =>
Analyze_Entry_Declaration (N);
- when N_Entry_Index_Specification =>
+ when N_Entry_Index_Specification =>
Analyze_Entry_Index_Specification (N);
when N_Enumeration_Representation_Clause =>
@@ -555,6 +566,9 @@ package body Sem is
when N_Subunit =>
Analyze_Subunit (N);
+ when N_Target_Name =>
+ Analyze_Target_Name (N);
+
when N_Task_Body =>
Analyze_Task_Body (N);
@@ -616,8 +630,11 @@ package body Sem is
-- A call to analyze the error node is simply ignored, to avoid
-- causing cascaded errors (happens of course only in error cases)
+ -- Disable expansion in case it is still enabled, to prevent other
+ -- subsequent compiler glitches.
when N_Error =>
+ Expander_Mode_Save_And_Set (False);
null;
-- Push/Pop nodes normally don't come through an analyze call. An
@@ -632,9 +649,10 @@ package body Sem is
-- the call to analyze them is generated when the full list is
-- analyzed.
- when N_SCIL_Dispatch_Table_Tag_Init |
- N_SCIL_Dispatching_Call |
- N_SCIL_Membership_Test =>
+ when N_SCIL_Dispatch_Table_Tag_Init
+ | N_SCIL_Dispatching_Call
+ | N_SCIL_Membership_Test
+ =>
null;
-- For the remaining node types, we generate compiler abort, because
@@ -644,63 +662,65 @@ package body Sem is
-- node appears only in the context of a type declaration, and is
-- processed by the analyze routine for type declarations.
- when N_Abortable_Part |
- N_Access_Definition |
- N_Access_Function_Definition |
- N_Access_Procedure_Definition |
- N_Access_To_Object_Definition |
- N_Aspect_Specification |
- N_Case_Expression_Alternative |
- N_Case_Statement_Alternative |
- N_Compilation_Unit_Aux |
- N_Component_Association |
- N_Component_Clause |
- N_Component_Definition |
- N_Component_List |
- N_Constrained_Array_Definition |
- N_Contract |
- N_Decimal_Fixed_Point_Definition |
- N_Defining_Character_Literal |
- N_Defining_Identifier |
- N_Defining_Operator_Symbol |
- N_Defining_Program_Unit_Name |
- N_Delta_Constraint |
- N_Derived_Type_Definition |
- N_Designator |
- N_Digits_Constraint |
- N_Discriminant_Association |
- N_Discriminant_Specification |
- N_Elsif_Part |
- N_Entry_Call_Statement |
- N_Enumeration_Type_Definition |
- N_Exception_Handler |
- N_Floating_Point_Definition |
- N_Formal_Decimal_Fixed_Point_Definition |
- N_Formal_Derived_Type_Definition |
- N_Formal_Discrete_Type_Definition |
- N_Formal_Floating_Point_Definition |
- N_Formal_Modular_Type_Definition |
- N_Formal_Ordinary_Fixed_Point_Definition |
- N_Formal_Private_Type_Definition |
- N_Formal_Incomplete_Type_Definition |
- N_Formal_Signed_Integer_Type_Definition |
- N_Function_Specification |
- N_Generic_Association |
- N_Index_Or_Discriminant_Constraint |
- N_Iteration_Scheme |
- N_Mod_Clause |
- N_Modular_Type_Definition |
- N_Ordinary_Fixed_Point_Definition |
- N_Parameter_Specification |
- N_Pragma_Argument_Association |
- N_Procedure_Specification |
- N_Real_Range_Specification |
- N_Record_Definition |
- N_Signed_Integer_Type_Definition |
- N_Unconstrained_Array_Definition |
- N_Unused_At_Start |
- N_Unused_At_End |
- N_Variant =>
+ when N_Abortable_Part
+ | N_Access_Definition
+ | N_Access_Function_Definition
+ | N_Access_Procedure_Definition
+ | N_Access_To_Object_Definition
+ | N_Aspect_Specification
+ | N_Case_Expression_Alternative
+ | N_Case_Statement_Alternative
+ | N_Compilation_Unit_Aux
+ | N_Component_Association
+ | N_Component_Clause
+ | N_Component_Definition
+ | N_Component_List
+ | N_Constrained_Array_Definition
+ | N_Contract
+ | N_Decimal_Fixed_Point_Definition
+ | N_Defining_Character_Literal
+ | N_Defining_Identifier
+ | N_Defining_Operator_Symbol
+ | N_Defining_Program_Unit_Name
+ | N_Delta_Constraint
+ | N_Derived_Type_Definition
+ | N_Designator
+ | N_Digits_Constraint
+ | N_Discriminant_Association
+ | N_Discriminant_Specification
+ | N_Elsif_Part
+ | N_Entry_Call_Statement
+ | N_Enumeration_Type_Definition
+ | N_Exception_Handler
+ | N_Floating_Point_Definition
+ | N_Formal_Decimal_Fixed_Point_Definition
+ | N_Formal_Derived_Type_Definition
+ | N_Formal_Discrete_Type_Definition
+ | N_Formal_Floating_Point_Definition
+ | N_Formal_Modular_Type_Definition
+ | N_Formal_Ordinary_Fixed_Point_Definition
+ | N_Formal_Private_Type_Definition
+ | N_Formal_Incomplete_Type_Definition
+ | N_Formal_Signed_Integer_Type_Definition
+ | N_Function_Specification
+ | N_Generic_Association
+ | N_Index_Or_Discriminant_Constraint
+ | N_Iterated_Component_Association
+ | N_Iteration_Scheme
+ | N_Mod_Clause
+ | N_Modular_Type_Definition
+ | N_Ordinary_Fixed_Point_Definition
+ | N_Parameter_Specification
+ | N_Pragma_Argument_Association
+ | N_Procedure_Specification
+ | N_Real_Range_Specification
+ | N_Record_Definition
+ | N_Signed_Integer_Type_Definition
+ | N_Unconstrained_Array_Definition
+ | N_Unused_At_End
+ | N_Unused_At_Start
+ | N_Variant
+ =>
raise Program_Error;
end case;
@@ -725,9 +745,26 @@ package body Sem is
and then Etype (N) = Standard_Void_Type)
then
Expand (N);
+
+ -- Replace a reference to a renaming with the renamed object for SPARK.
+ -- In general this modification is performed by Expand_SPARK, however
+ -- certain constructs may not reach the resolution or expansion phase
+ -- and thus remain unchanged. The replacement is not performed when the
+ -- construct is overloaded as resolution must first take place. This is
+ -- also not done when analyzing a generic to preserve the original tree
+ -- and because the reference may become overloaded in the instance.
+
+ elsif GNATprove_Mode
+ and then Nkind_In (N, N_Expanded_Name, N_Identifier)
+ and then not Is_Overloaded (N)
+ and then not Inside_A_Generic
+ then
+ Expand_SPARK_Potential_Renaming (N);
end if;
- Ghost_Mode := Save_Ghost_Mode;
+ if Mode_Set then
+ Restore_Ghost_Mode (Mode);
+ end if;
end Analyze;
-- Version with check(s) suppressed
@@ -998,7 +1035,7 @@ package body Sem is
if Present (M) then
-- If we are not at the end of the list, then the easiest
- -- coding is simply to insert before our successor
+ -- coding is simply to insert before our successor.
if Present (Next (N)) then
Insert_Before_And_Analyze (Next (N), M);
@@ -1313,9 +1350,20 @@ package body Sem is
-- Do_Analyze --
----------------
+ -- WARNING: This routine manages Ghost regions. Return statements must
+ -- be replaced by gotos which jump to the end of the routine and restore
+ -- the Ghost mode.
+
procedure Do_Analyze is
Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
+ -- Generally style checks are preserved across compilations, with
+ -- one exception: s-oscons.ads, which allows arbitrary long lines
+ -- unconditionally, and has no restore mechanism, because it is
+ -- intended as a lowest-level Pure package.
+
+ Save_Max_Line : constant Int := Style_Max_Line_Length;
+
List : Elist_Id;
begin
@@ -1324,11 +1372,12 @@ package body Sem is
-- Set up a clean environment before analyzing
- Ghost_Mode := None;
+ Install_Ghost_Mode (None);
Outer_Generic_Scope := Empty;
Scope_Suppress := Suppress_Options;
Scope_Stack.Table
- (Scope_Stack.Last).Component_Alignment_Default := Calign_Default;
+ (Scope_Stack.Last).Component_Alignment_Default :=
+ Configuration_Component_Alignment;
Scope_Stack.Table
(Scope_Stack.Last).Is_Active_Stack_Base := True;
@@ -1339,13 +1388,14 @@ package body Sem is
-- Check for scope mismatch on exit from compilation
pragma Assert (Current_Scope = Standard_Standard
- or else Comp_Unit = Cunit (Main_Unit));
+ or else Comp_Unit = Cunit (Main_Unit));
-- Then pop entry for Standard, and pop implicit types
Pop_Scope;
Restore_Scope_Stack (List);
- Ghost_Mode := Save_Ghost_Mode;
+ Restore_Ghost_Mode (Save_Ghost_Mode);
+ Style_Max_Line_Length := Save_Max_Line;
end Do_Analyze;
-- Local variables
@@ -1454,9 +1504,10 @@ package body Sem is
-- compiling a separate unit (this is to handle a situation
-- where this new processing causes trouble).
- or else ((Configurable_Run_Time_Mode or No_Run_Time_Mode)
- and not Debug_Flag_Dot_ZZ
- and Nkind (Unit (Cunit (Main_Unit))) /= N_Subunit));
+ or else
+ ((Configurable_Run_Time_Mode or No_Run_Time_Mode)
+ and then not Debug_Flag_Dot_ZZ
+ and then Nkind (Unit (Cunit (Main_Unit))) /= N_Subunit));
end if;
Full_Analysis := True;
@@ -1592,6 +1643,15 @@ package body Sem is
return ss (Scope_Stack.Last);
end sst;
+ ------------
+ -- Unlock --
+ ------------
+
+ procedure Unlock is
+ begin
+ Scope_Stack.Locked := False;
+ end Unlock;
+
------------------------
-- Walk_Library_Items --
------------------------
@@ -1694,16 +1754,16 @@ package body Sem is
pragma Assert (No (CU) or else Nkind (CU) = N_Compilation_Unit);
case Nkind (Item) is
- when N_Generic_Subprogram_Declaration |
- N_Generic_Package_Declaration |
- N_Package_Declaration |
- N_Subprogram_Declaration |
- N_Subprogram_Renaming_Declaration |
- N_Package_Renaming_Declaration |
- N_Generic_Function_Renaming_Declaration |
- N_Generic_Package_Renaming_Declaration |
- N_Generic_Procedure_Renaming_Declaration =>
-
+ when N_Generic_Function_Renaming_Declaration
+ | N_Generic_Package_Declaration
+ | N_Generic_Package_Renaming_Declaration
+ | N_Generic_Procedure_Renaming_Declaration
+ | N_Generic_Subprogram_Declaration
+ | N_Package_Declaration
+ | N_Package_Renaming_Declaration
+ | N_Subprogram_Declaration
+ | N_Subprogram_Renaming_Declaration
+ =>
-- Specs are OK
null;
@@ -1723,10 +1783,10 @@ package body Sem is
or else CU = Cunit (Main_Unit));
null;
- when N_Function_Instantiation |
- N_Procedure_Instantiation |
- N_Package_Instantiation =>
-
+ when N_Function_Instantiation
+ | N_Package_Instantiation
+ | N_Procedure_Instantiation
+ =>
-- Can only happen if some generic body (needed for gnat2scil
-- traversal, but not by GNAT) is not available, ignore.
@@ -1738,6 +1798,13 @@ package body Sem is
pragma Assert (False, "subunit");
null;
+ when N_Null_Statement =>
+
+ -- Do not call Action for an ignored ghost unit
+
+ pragma Assert (Is_Ignored_Ghost_Node (Original_Node (Item)));
+ return;
+
when others =>
pragma Assert (False);
null;
@@ -2039,7 +2106,7 @@ package body Sem is
-- The flag Withed_Body on a context clause indicates that a
-- unit contains an instantiation that may be needed later,
-- and therefore the body that contains the generic body (and
- -- its context) must be traversed immediately after the
+ -- its context) must be traversed immediately after the
-- corresponding spec (see Do_Unit_And_Dependents).
-- The main unit itself is processed separately after all other
@@ -2061,10 +2128,16 @@ package body Sem is
Unit (Library_Unit (Main_CU)));
end if;
- -- It's a spec, process it, and the units it depends on,
- -- unless it is a descendent of the main unit. This can
- -- happen when the body of a parent depends on some other
- -- descendent.
+ -- It is a spec, process it, and the units it depends on,
+ -- unless it is a descendant of the main unit. This can happen
+ -- when the body of a parent depends on some other descendant.
+
+ when N_Null_Statement =>
+
+ -- Ignore an ignored ghost unit
+
+ pragma Assert (Is_Ignored_Ghost_Node (Original_Node (N)));
+ null;
when others =>
Par := Scope (Defining_Entity (Unit (CU)));
diff --git a/gcc/ada/sem.ads b/gcc/ada/sem.ads
index 22da223300..6cd050e7fb 100644
--- a/gcc/ada/sem.ads
+++ b/gcc/ada/sem.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -122,7 +122,7 @@
-- xx : x := y * z;
-- end record;
--- for x'small use 0.25
+-- for x'small use 0.25;
-- The expander is in charge of dealing with fixed-point, and of course the
-- small declaration, which is not too late, since the declaration of type q
@@ -253,6 +253,11 @@ package Sem is
-- future possibility by making it a counter. As with In_Spec_Expression,
-- it must be recursively saved and restored for a Semantics call.
+ In_Compile_Time_Warning_Or_Error : Boolean := False;
+ -- Switch to indicate that we are validating a pragma Compile_Time_Warning
+ -- or Compile_Time_Error after the back end has been called (to check these
+ -- pragmas for size and alignment appropriateness).
+
In_Default_Expr : Boolean := False;
-- Switch to indicate that we are analyzing a default component expression.
-- As with In_Spec_Expression, it must be recursively saved and restored
@@ -461,6 +466,11 @@ package Sem is
-- Transient blocks have three associated actions list, to be inserted
-- before and after the block's statements, and as cleanup actions.
+ Configuration_Component_Alignment : Component_Alignment_Kind :=
+ Calign_Default;
+ -- Used for handling the pragma Component_Alignment in the context of a
+ -- configuration file.
+
type Scope_Stack_Entry is record
Entity : Entity_Id;
-- Entity representing the scope
@@ -513,8 +523,8 @@ package Sem is
-- See Sem_Ch10 (Install_Parents, Remove_Parents).
Node_To_Be_Wrapped : Node_Id;
- -- Only used in transient scopes. Records the node which will
- -- be wrapped by the transient block.
+ -- Only used in transient scopes. Records the node which will be wrapped
+ -- by the transient block.
Actions_To_Be_Wrapped : Scope_Actions;
-- Actions that have to be inserted at the start, at the end, or as
@@ -570,6 +580,9 @@ package Sem is
procedure Lock;
-- Lock internal tables before calling back end
+ procedure Unlock;
+ -- Unlock internal tables
+
procedure Semantics (Comp_Unit : Node_Id);
-- This procedure is called to perform semantic analysis on the specified
-- node which is the N_Compilation_Unit node for the unit.
diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb
index 60cd131987..efa5d60b6a 100644
--- a/gcc/ada/sem_aggr.adb
+++ b/gcc/ada/sem_aggr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -479,7 +479,7 @@ package body Sem_Aggr is
else
if Compile_Time_Known_Value (This_Low) then
if not Compile_Time_Known_Value (Aggr_Low (Dim)) then
- Aggr_Low (Dim) := This_Low;
+ Aggr_Low (Dim) := This_Low;
elsif Expr_Value (This_Low) /= Expr_Value (Aggr_Low (Dim)) then
Set_Raises_Constraint_Error (N);
@@ -491,7 +491,7 @@ package body Sem_Aggr is
if Compile_Time_Known_Value (This_High) then
if not Compile_Time_Known_Value (Aggr_High (Dim)) then
- Aggr_High (Dim) := This_High;
+ Aggr_High (Dim) := This_High;
elsif
Expr_Value (This_High) /= Expr_Value (Aggr_High (Dim))
@@ -647,9 +647,9 @@ package body Sem_Aggr is
begin
-- All the components of List are matched against Component and a count
- -- is maintained of possible misspellings. When at the end of the the
+ -- is maintained of possible misspellings. When at the end of the
-- analysis there are one or two (not more) possible misspellings,
- -- these misspellings will be suggested as possible correction.
+ -- these misspellings will be suggested as possible corrections.
Component_Elmt := First_Elmt (Elements);
while Nr_Of_Suggestions <= Max_Suggestions
@@ -664,7 +664,7 @@ package body Sem_Aggr is
case Nr_Of_Suggestions is
when 1 => Suggestion_1 := Node (Component_Elmt);
when 2 => Suggestion_2 := Node (Component_Elmt);
- when others => exit;
+ when others => null;
end case;
end if;
@@ -809,8 +809,8 @@ package body Sem_Aggr is
begin
return No (Expressions (Aggr))
and then
- Nkind (First (Choices (First (Component_Associations (Aggr))))) =
- N_Others_Choice;
+ Nkind (First (Choice_List (First (Component_Associations (Aggr))))) =
+ N_Others_Choice;
end Is_Others_Aggregate;
----------------------------
@@ -986,13 +986,16 @@ package body Sem_Aggr is
elsif Is_Array_Type (Typ) then
- -- First a special test, for the case of a positional aggregate
- -- of characters which can be replaced by a string literal.
+ -- First a special test, for the case of a positional aggregate of
+ -- characters which can be replaced by a string literal.
- -- Do not perform this transformation if this was a string literal to
- -- start with, whose components needed constraint checks, or if the
- -- component type is non-static, because it will require those checks
- -- and be transformed back into an aggregate.
+ -- Do not perform this transformation if this was a string literal
+ -- to start with, whose components needed constraint checks, or if
+ -- the component type is non-static, because it will require those
+ -- checks and be transformed back into an aggregate. If the index
+ -- type is not Integer the aggregate may represent a user-defined
+ -- string type but the context might need the original type so we
+ -- do not perform the transformation at this point.
if Number_Dimensions (Typ) = 1
and then Is_Standard_Character_Type (Component_Type (Typ))
@@ -1002,6 +1005,8 @@ package body Sem_Aggr is
and then not Is_Bit_Packed_Array (Typ)
and then Nkind (Original_Node (Parent (N))) /= N_String_Literal
and then Is_OK_Static_Subtype (Component_Type (Typ))
+ and then Base_Type (Etype (First_Index (Typ))) =
+ Base_Type (Standard_Integer)
then
declare
Expr : Node_Id;
@@ -1094,18 +1099,6 @@ package body Sem_Aggr is
Index_Constr => First_Index (Typ),
Component_Typ => Component_Type (Typ),
Others_Allowed => True);
-
- elsif not Expander_Active
- and then Pkind = N_Assignment_Statement
- then
- Aggr_Resolved :=
- Resolve_Array_Aggregate
- (N,
- Index => First_Index (Aggr_Typ),
- Index_Constr => First_Index (Typ),
- Component_Typ => Component_Type (Typ),
- Others_Allowed => True);
-
else
Aggr_Resolved :=
Resolve_Array_Aggregate
@@ -1192,6 +1185,11 @@ package body Sem_Aggr is
Index_Base_High : constant Node_Id := Type_High_Bound (Index_Base);
-- Ditto for the base type
+ Others_Present : Boolean := False;
+
+ Nb_Choices : Nat := 0;
+ -- Contains the overall number of named choices in this sub-aggregate
+
function Add (Val : Uint; To : Node_Id) return Node_Id;
-- Creates a new expression node where Val is added to expression To.
-- Tries to constant fold whenever possible. To must be an already
@@ -1233,6 +1231,11 @@ package body Sem_Aggr is
-- N_Component_Association node as Expr, since there is no Expression in
-- that case, and we need a Sloc for the error message.
+ procedure Resolve_Iterated_Component_Association
+ (N : Node_Id;
+ Index_Typ : Entity_Id);
+ -- For AI12-061
+
---------
-- Add --
---------
@@ -1610,9 +1613,12 @@ package body Sem_Aggr is
-- If an aggregate component has a type with predicates, an explicit
-- predicate check must be applied, as for an assignment statement,
-- because the aggegate might not be expanded into individual
- -- component assignments.
+ -- component assignments. If the expression covers several components
+ -- the analysis and the predicate check take place later.
- if Present (Predicate_Function (Component_Typ)) then
+ if Present (Predicate_Function (Component_Typ))
+ and then Analyzed (Expr)
+ then
Apply_Predicate_Check (Expr, Component_Typ);
end if;
@@ -1635,38 +1641,86 @@ package body Sem_Aggr is
return Resolution_OK;
end Resolve_Aggr_Expr;
- -- Variables local to Resolve_Array_Aggregate
+ --------------------------------------------
+ -- Resolve_Iterated_Component_Association --
+ --------------------------------------------
+
+ procedure Resolve_Iterated_Component_Association
+ (N : Node_Id;
+ Index_Typ : Entity_Id)
+ is
+ Id : constant Entity_Id := Defining_Identifier (N);
+ Loc : constant Source_Ptr := Sloc (N);
+
+ Choice : Node_Id;
+ Dummy : Boolean;
+ Ent : Entity_Id;
+
+ begin
+ Choice := First (Discrete_Choices (N));
+
+ while Present (Choice) loop
+ if Nkind (Choice) = N_Others_Choice then
+ Others_Present := True;
+
+ else
+ Analyze_And_Resolve (Choice, Index_Typ);
+ end if;
+
+ Next (Choice);
+ end loop;
+
+ -- Create a scope in which to introduce an index, which is usually
+ -- visible in the expression for the component, and needed for its
+ -- analysis.
+
+ Ent := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L');
+ Set_Etype (Ent, Standard_Void_Type);
+ Set_Parent (Ent, Parent (N));
+
+ -- Decorate the index variable in the current scope. The association
+ -- may have several choices, each one leading to a loop, so we create
+ -- this variable only once to prevent homonyms in this scope.
+
+ if No (Scope (Id)) then
+ Enter_Name (Id);
+ Set_Etype (Id, Index_Typ);
+ Set_Ekind (Id, E_Variable);
+ Set_Scope (Id, Ent);
+ end if;
+
+ Push_Scope (Ent);
+ Dummy := Resolve_Aggr_Expr (Expression (N), False);
+ End_Scope;
+ end Resolve_Iterated_Component_Association;
+
+ -- Local variables
Assoc : Node_Id;
Choice : Node_Id;
Expr : Node_Id;
Discard : Node_Id;
- Delete_Choice : Boolean;
- -- Used when replacing a subtype choice with predicate by a list
-
Aggr_Low : Node_Id := Empty;
Aggr_High : Node_Id := Empty;
-- The actual low and high bounds of this sub-aggregate
+ Case_Table_Size : Nat;
+ -- Contains the size of the case table needed to sort aggregate choices
+
Choices_Low : Node_Id := Empty;
Choices_High : Node_Id := Empty;
-- The lowest and highest discrete choices values for a named aggregate
+ Delete_Choice : Boolean;
+ -- Used when replacing a subtype choice with predicate by a list
+
Nb_Elements : Uint := Uint_0;
-- The number of elements in a positional aggregate
- Others_Present : Boolean := False;
-
- Nb_Choices : Nat := 0;
- -- Contains the overall number of named choices in this sub-aggregate
-
Nb_Discrete_Choices : Nat := 0;
-- The overall number of discrete choices (not counting others choice)
- Case_Table_Size : Nat;
- -- Contains the size of the case table needed to sort aggregate choices
-
-- Start of processing for Resolve_Array_Aggregate
begin
@@ -1684,13 +1738,17 @@ package body Sem_Aggr is
if Present (Component_Associations (N)) then
Assoc := First (Component_Associations (N));
while Present (Assoc) loop
- Choice := First (Choices (Assoc));
+ if Nkind (Assoc) = N_Iterated_Component_Association then
+ Resolve_Iterated_Component_Association (Assoc, Index_Typ);
+ end if;
+
+ Choice := First (Choice_List (Assoc));
Delete_Choice := False;
while Present (Choice) loop
if Nkind (Choice) = N_Others_Choice then
Others_Present := True;
- if Choice /= First (Choices (Assoc))
+ if Choice /= First (Choice_List (Assoc))
or else Present (Next (Choice))
then
Error_Msg_N
@@ -1739,9 +1797,14 @@ package body Sem_Aggr is
-- If the subtype has a static predicate, replace the
-- original choice with the list of individual values
- -- covered by the predicate.
+ -- covered by the predicate. Do not perform this
+ -- transformation if we need to preserve the source
+ -- for ASIS use.
+ -- This should be deferred to expansion time ???
- if Present (Static_Discrete_Predicate (E)) then
+ if Present (Static_Discrete_Predicate (E))
+ and then not ASIS_Mode
+ then
Delete_Choice := True;
New_Cs := New_List;
@@ -1789,7 +1852,7 @@ package body Sem_Aggr is
then
Error_Msg_N
("named association cannot follow positional association",
- First (Choices (First (Component_Associations (N)))));
+ First (Choice_List (First (Component_Associations (N)))));
return Failure;
end if;
@@ -1818,6 +1881,25 @@ package body Sem_Aggr is
end if;
Step_2 : declare
+ function Empty_Range (A : Node_Id) return Boolean;
+ -- If an association covers an empty range, some warnings on the
+ -- expression of the association can be disabled.
+
+ -----------------
+ -- Empty_Range --
+ -----------------
+
+ function Empty_Range (A : Node_Id) return Boolean is
+ R : constant Node_Id := First (Choices (A));
+ begin
+ return No (Next (R))
+ and then Nkind (R) = N_Range
+ and then Compile_Time_Compare
+ (Low_Bound (R), High_Bound (R), False) = GT;
+ end Empty_Range;
+
+ -- Local variables
+
Low : Node_Id;
High : Node_Id;
-- Denote the lowest and highest values in an aggregate choice
@@ -1842,23 +1924,6 @@ package body Sem_Aggr is
Errors_Posted_On_Choices : Boolean := False;
-- Keeps track of whether any choices have semantic errors
- function Empty_Range (A : Node_Id) return Boolean;
- -- If an association covers an empty range, some warnings on the
- -- expression of the association can be disabled.
-
- -----------------
- -- Empty_Range --
- -----------------
-
- function Empty_Range (A : Node_Id) return Boolean is
- R : constant Node_Id := First (Choices (A));
- begin
- return No (Next (R))
- and then Nkind (R) = N_Range
- and then Compile_Time_Compare
- (Low_Bound (R), High_Bound (R), False) = GT;
- end Empty_Range;
-
-- Start of processing for Step_2
begin
@@ -1867,7 +1932,8 @@ package body Sem_Aggr is
Assoc := First (Component_Associations (N));
while Present (Assoc) loop
Prev_Nb_Discrete_Choices := Nb_Discrete_Choices;
- Choice := First (Choices (Assoc));
+ Choice := First (Choice_List (Assoc));
+
loop
Analyze (Choice);
@@ -2022,6 +2088,9 @@ package body Sem_Aggr is
return Failure;
end if;
+ elsif Nkind (Assoc) = N_Iterated_Component_Association then
+ null; -- handled above, in a loop context.
+
elsif not Resolve_Aggr_Expr
(Expression (Assoc), Single_Elmt => Single_Choice)
then
@@ -2052,6 +2121,13 @@ package body Sem_Aggr is
Set_Parent (Expr, Parent (Expression (Assoc)));
Analyze (Expr);
+ -- Compute its dimensions now, rather than at the end of
+ -- resolution, because in the case of multidimensional
+ -- aggregates subsequent expansion may lead to spurious
+ -- errors.
+
+ Check_Expression_Dimensions (Expr, Component_Typ);
+
-- If the expression is a literal, propagate this info
-- to the expression in the association, to enable some
-- optimizations downstream.
@@ -2215,7 +2291,22 @@ package body Sem_Aggr is
if Lo_Dup > Hi_Dup then
null;
- -- Otherwise place proper message
+ -- Otherwise place proper message. Because
+ -- of the missing expansion of subtypes with
+ -- predicates in ASIS mode, do not report
+ -- spurious overlap errors.
+
+ elsif ASIS_Mode
+ and then
+ ((Is_Type (Entity (Table (J).Choice))
+ and then Has_Predicates
+ (Entity (Table (J).Choice)))
+ or else
+ (Is_Type (Entity (Table (K).Choice))
+ and then Has_Predicates
+ (Entity (Table (K).Choice))))
+ then
+ null;
else
-- We place message on later choice, with a
@@ -2644,6 +2735,150 @@ package body Sem_Aggr is
return Success;
end Resolve_Array_Aggregate;
+ -----------------------------
+ -- Resolve_Delta_Aggregate --
+ -----------------------------
+
+ procedure Resolve_Delta_Aggregate (N : Node_Id; Typ : Entity_Id) is
+ Base : constant Node_Id := Expression (N);
+ Deltas : constant List_Id := Component_Associations (N);
+
+ function Get_Component_Type (Nam : Node_Id) return Entity_Id;
+
+ ------------------------
+ -- Get_Component_Type --
+ ------------------------
+
+ function Get_Component_Type (Nam : Node_Id) return Entity_Id is
+ Comp : Entity_Id;
+
+ begin
+ Comp := First_Entity (Typ);
+
+ while Present (Comp) loop
+ if Chars (Comp) = Chars (Nam) then
+ if Ekind (Comp) = E_Discriminant then
+ Error_Msg_N ("delta cannot apply to discriminant", Nam);
+ end if;
+
+ return Etype (Comp);
+ end if;
+
+ Comp := Next_Entity (Comp);
+ end loop;
+
+ Error_Msg_NE ("type& has no component with this name", Nam, Typ);
+ return Any_Type;
+ end Get_Component_Type;
+
+ -- Local variables
+
+ Assoc : Node_Id;
+ Choice : Node_Id;
+ Comp_Type : Entity_Id;
+ Index_Type : Entity_Id;
+
+ -- Start of processing for Resolve_Delta_Aggregate
+
+ begin
+ if not Is_Composite_Type (Typ) then
+ Error_Msg_N ("not a composite type", N);
+ end if;
+
+ Analyze_And_Resolve (Base, Typ);
+
+ if Is_Array_Type (Typ) then
+ Index_Type := Etype (First_Index (Typ));
+ Assoc := First (Deltas);
+ while Present (Assoc) loop
+ if Nkind (Assoc) = N_Iterated_Component_Association then
+ Choice := First (Choice_List (Assoc));
+ while Present (Choice) loop
+ if Nkind (Choice) = N_Others_Choice then
+ Error_Msg_N
+ ("others not allowed in delta aggregate", Choice);
+
+ else
+ Analyze_And_Resolve (Choice, Index_Type);
+ end if;
+
+ Next (Choice);
+ end loop;
+
+ declare
+ Id : constant Entity_Id := Defining_Identifier (Assoc);
+ Ent : constant Entity_Id :=
+ New_Internal_Entity
+ (E_Loop, Current_Scope, Sloc (Assoc), 'L');
+
+ begin
+ Set_Etype (Ent, Standard_Void_Type);
+ Set_Parent (Ent, Assoc);
+
+ if No (Scope (Id)) then
+ Enter_Name (Id);
+ Set_Etype (Id, Index_Type);
+ Set_Ekind (Id, E_Variable);
+ Set_Scope (Id, Ent);
+ end if;
+
+ Push_Scope (Ent);
+ Analyze_And_Resolve
+ (New_Copy_Tree (Expression (Assoc)), Component_Type (Typ));
+ End_Scope;
+ end;
+
+ else
+ Choice := First (Choice_List (Assoc));
+ while Present (Choice) loop
+ if Nkind (Choice) = N_Others_Choice then
+ Error_Msg_N
+ ("others not allowed in delta aggregate", Choice);
+
+ else
+ Analyze (Choice);
+ if Is_Entity_Name (Choice)
+ and then Is_Type (Entity (Choice))
+ then
+ -- Choice covers a range of values.
+ if Base_Type (Entity (Choice)) /=
+ Base_Type (Index_Type)
+ then
+ Error_Msg_NE
+ ("choice does mat match index type of",
+ Choice, Typ);
+ end if;
+ else
+ Resolve (Choice, Index_Type);
+ end if;
+ end if;
+
+ Next (Choice);
+ end loop;
+
+ Analyze_And_Resolve (Expression (Assoc), Component_Type (Typ));
+ end if;
+
+ Next (Assoc);
+ end loop;
+
+ else
+ Assoc := First (Deltas);
+ while Present (Assoc) loop
+ Choice := First (Choice_List (Assoc));
+ while Present (Choice) loop
+ Comp_Type := Get_Component_Type (Choice);
+ Next (Choice);
+ end loop;
+
+ Analyze_And_Resolve (Expression (Assoc), Comp_Type);
+ Next (Assoc);
+ end loop;
+ end if;
+
+ Set_Etype (N, Typ);
+ end Resolve_Delta_Aggregate;
+
---------------------------------
-- Resolve_Extension_Aggregate --
---------------------------------
@@ -2930,7 +3165,7 @@ package body Sem_Aggr is
end if;
else
- Error_Msg_N ("no unique type for this aggregate", A);
+ Error_Msg_N ("no unique type for this aggregate", A);
end if;
Check_Function_Writable_Actuals (N);
@@ -2941,25 +3176,9 @@ package body Sem_Aggr is
------------------------------
procedure Resolve_Record_Aggregate (N : Node_Id; Typ : Entity_Id) is
- Assoc : Node_Id;
- -- N_Component_Association node belonging to the input aggregate N
-
- Expr : Node_Id;
- Positional_Expr : Node_Id;
- Component : Entity_Id;
- Component_Elmt : Elmt_Id;
-
- Components : constant Elist_Id := New_Elmt_List;
- -- Components is the list of the record components whose value must be
- -- provided in the aggregate. This list does include discriminants.
-
New_Assoc_List : constant List_Id := New_List;
- New_Assoc : Node_Id;
-- New_Assoc_List is the newly built list of N_Component_Association
- -- nodes. New_Assoc is one such N_Component_Association node in it.
- -- Note that while Assoc and New_Assoc contain the same kind of nodes,
- -- they are used to iterate over two different N_Component_Association
- -- lists.
+ -- nodes.
Others_Etype : Entity_Id := Empty;
-- This variable is used to save the Etype of the last record component
@@ -2972,14 +3191,19 @@ package body Sem_Aggr is
--
-- This variable is updated as a side effect of function Get_Value.
+ Box_Node : Node_Id;
Is_Box_Present : Boolean := False;
- Others_Box : Boolean := False;
+ Others_Box : Integer := 0;
-- Ada 2005 (AI-287): Variables used in case of default initialization
-- to provide a functionality similar to Others_Etype. Box_Present
-- indicates that the component takes its default initialization;
- -- Others_Box indicates that at least one component takes its default
- -- initialization. Similar to Others_Etype, they are also updated as a
- -- side effect of function Get_Value.
+ -- Others_Box counts the number of components of the current aggregate
+ -- (which may be a sub-aggregate of a larger one) that are default-
+ -- initialized. A value of One indicates that an others_box is present.
+ -- Any larger value indicates that the others_box is not redundant.
+ -- These variables, similar to Others_Etype, are also updated as a side
+ -- effect of function Get_Value. Box_Node is used to place a warning on
+ -- a redundant others_box.
procedure Add_Association
(Component : Entity_Id;
@@ -2991,14 +3215,23 @@ package body Sem_Aggr is
-- either New_Assoc_List, or the association being built for an inner
-- aggregate.
- function Discr_Present (Discr : Entity_Id) return Boolean;
+ procedure Add_Discriminant_Values
+ (New_Aggr : Node_Id;
+ Assoc_List : List_Id);
+ -- The constraint to a component may be given by a discriminant of the
+ -- enclosing type, in which case we have to retrieve its value, which is
+ -- part of the enclosing aggregate. Assoc_List provides the discriminant
+ -- associations of the current type or of some enclosing record.
+
+ function Discriminant_Present (Input_Discr : Entity_Id) return Boolean;
-- If aggregate N is a regular aggregate this routine will return True.
- -- Otherwise, if N is an extension aggregate, Discr is a discriminant
- -- whose value may already have been specified by N's ancestor part.
- -- This routine checks whether this is indeed the case and if so returns
- -- False, signaling that no value for Discr should appear in N's
- -- aggregate part. Also, in this case, the routine appends to
- -- New_Assoc_List the discriminant value specified in the ancestor part.
+ -- Otherwise, if N is an extension aggregate, then Input_Discr denotes
+ -- a discriminant whose value may already have been specified by N's
+ -- ancestor part. This routine checks whether this is indeed the case
+ -- and if so returns False, signaling that no value for Input_Discr
+ -- should appear in N's aggregate part. Also, in this case, the routine
+ -- appends to New_Assoc_List the discriminant value specified in the
+ -- ancestor part.
--
-- If the aggregate is in a context with expansion delayed, it will be
-- reanalyzed. The inherited discriminant values must not be reinserted
@@ -3006,11 +3239,16 @@ package body Sem_Aggr is
-- present on first analysis to build the proper subtype indications.
-- The flag Inherited_Discriminant is used to prevent the re-insertion.
+ function Find_Private_Ancestor (Typ : Entity_Id) return Entity_Id;
+ -- AI05-0115: Find earlier ancestor in the derivation chain that is
+ -- derived from private view Typ. Whether the aggregate is legal depends
+ -- on the current visibility of the type as well as that of the parent
+ -- of the ancestor.
+
function Get_Value
(Compon : Node_Id;
From : List_Id;
- Consider_Others_Choice : Boolean := False)
- return Node_Id;
+ Consider_Others_Choice : Boolean := False) return Node_Id;
-- Given a record component stored in parameter Compon, this function
-- returns its value as it appears in the list From, which is a list
-- of N_Component_Association nodes.
@@ -3035,7 +3273,14 @@ package body Sem_Aggr is
-- Same as New_Copy_Tree (defined in Sem_Util), except that this routine
-- also copies the dimensions of Source to the returned node.
- procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Node_Id);
+ procedure Propagate_Discriminants
+ (Aggr : Node_Id;
+ Assoc_List : List_Id);
+ -- Nested components may themselves be discriminated types constrained
+ -- by outer discriminants, whose values must be captured before the
+ -- aggregate is expanded into assignments.
+
+ procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Entity_Id);
-- Analyzes and resolves expression Expr against the Etype of the
-- Component. This routine also applies all appropriate checks to Expr.
-- It finally saves a Expr in the newly created association list that
@@ -3053,13 +3298,12 @@ package body Sem_Aggr is
Assoc_List : List_Id;
Is_Box_Present : Boolean := False)
is
- Loc : Source_Ptr;
Choice_List : constant List_Id := New_List;
- New_Assoc : Node_Id;
+ Loc : Source_Ptr;
begin
- -- If this is a box association the expression is missing, so
- -- use the Sloc of the aggregate itself for the new association.
+ -- If this is a box association the expression is missing, so use the
+ -- Sloc of the aggregate itself for the new association.
if Present (Expr) then
Loc := Sloc (Expr);
@@ -3067,34 +3311,97 @@ package body Sem_Aggr is
Loc := Sloc (N);
end if;
- Append (New_Occurrence_Of (Component, Loc), Choice_List);
- New_Assoc :=
+ Append_To (Choice_List, New_Occurrence_Of (Component, Loc));
+
+ Append_To (Assoc_List,
Make_Component_Association (Loc,
Choices => Choice_List,
Expression => Expr,
- Box_Present => Is_Box_Present);
- Append (New_Assoc, Assoc_List);
+ Box_Present => Is_Box_Present));
end Add_Association;
- -------------------
- -- Discr_Present --
- -------------------
+ -----------------------------
+ -- Add_Discriminant_Values --
+ -----------------------------
+
+ procedure Add_Discriminant_Values
+ (New_Aggr : Node_Id;
+ Assoc_List : List_Id)
+ is
+ Assoc : Node_Id;
+ Discr : Entity_Id;
+ Discr_Elmt : Elmt_Id;
+ Discr_Val : Node_Id;
+ Val : Entity_Id;
+
+ begin
+ Discr := First_Discriminant (Etype (New_Aggr));
+ Discr_Elmt := First_Elmt (Discriminant_Constraint (Etype (New_Aggr)));
+ while Present (Discr_Elmt) loop
+ Discr_Val := Node (Discr_Elmt);
+
+ -- If the constraint is given by a discriminant then it is a
+ -- discriminant of an enclosing record, and its value has already
+ -- been placed in the association list.
+
+ if Is_Entity_Name (Discr_Val)
+ and then Ekind (Entity (Discr_Val)) = E_Discriminant
+ then
+ Val := Entity (Discr_Val);
+
+ Assoc := First (Assoc_List);
+ while Present (Assoc) loop
+ if Present (Entity (First (Choices (Assoc))))
+ and then Entity (First (Choices (Assoc))) = Val
+ then
+ Discr_Val := Expression (Assoc);
+ exit;
+ end if;
+
+ Next (Assoc);
+ end loop;
+ end if;
+
+ Add_Association
+ (Discr, New_Copy_Tree (Discr_Val),
+ Component_Associations (New_Aggr));
+
+ -- If the discriminant constraint is a current instance, mark the
+ -- current aggregate so that the self-reference can be expanded
+ -- later. The constraint may refer to the subtype of aggregate, so
+ -- use base type for comparison.
+
+ if Nkind (Discr_Val) = N_Attribute_Reference
+ and then Is_Entity_Name (Prefix (Discr_Val))
+ and then Is_Type (Entity (Prefix (Discr_Val)))
+ and then Base_Type (Etype (N)) = Entity (Prefix (Discr_Val))
+ then
+ Set_Has_Self_Reference (N);
+ end if;
+
+ Next_Elmt (Discr_Elmt);
+ Next_Discriminant (Discr);
+ end loop;
+ end Add_Discriminant_Values;
- function Discr_Present (Discr : Entity_Id) return Boolean is
+ --------------------------
+ -- Discriminant_Present --
+ --------------------------
+
+ function Discriminant_Present (Input_Discr : Entity_Id) return Boolean is
Regular_Aggr : constant Boolean := Nkind (N) /= N_Extension_Aggregate;
+ Ancestor_Is_Subtyp : Boolean;
+
Loc : Source_Ptr;
Ancestor : Node_Id;
+ Ancestor_Typ : Entity_Id;
Comp_Assoc : Node_Id;
+ Discr : Entity_Id;
Discr_Expr : Node_Id;
-
- Ancestor_Typ : Entity_Id;
+ Discr_Val : Elmt_Id := No_Elmt;
Orig_Discr : Entity_Id;
- D : Entity_Id;
- D_Val : Elmt_Id := No_Elmt; -- stop junk warning
-
- Ancestor_Is_Subtyp : Boolean;
begin
if Regular_Aggr then
@@ -3151,41 +3458,66 @@ package body Sem_Aggr is
-- Now look to see if Discr was specified in the ancestor part
if Ancestor_Is_Subtyp then
- D_Val := First_Elmt (Discriminant_Constraint (Entity (Ancestor)));
+ Discr_Val :=
+ First_Elmt (Discriminant_Constraint (Entity (Ancestor)));
end if;
- Orig_Discr := Original_Record_Component (Discr);
+ Orig_Discr := Original_Record_Component (Input_Discr);
- D := First_Discriminant (Ancestor_Typ);
- while Present (D) loop
+ Discr := First_Discriminant (Ancestor_Typ);
+ while Present (Discr) loop
-- If Ancestor has already specified Disc value then insert its
-- value in the final aggregate.
- if Original_Record_Component (D) = Orig_Discr then
+ if Original_Record_Component (Discr) = Orig_Discr then
if Ancestor_Is_Subtyp then
- Discr_Expr := New_Copy_Tree (Node (D_Val));
+ Discr_Expr := New_Copy_Tree (Node (Discr_Val));
else
Discr_Expr :=
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Ancestor),
- Selector_Name => New_Occurrence_Of (Discr, Loc));
+ Selector_Name => New_Occurrence_Of (Input_Discr, Loc));
end if;
- Resolve_Aggr_Expr (Discr_Expr, Discr);
+ Resolve_Aggr_Expr (Discr_Expr, Input_Discr);
Set_Inherited_Discriminant (Last (New_Assoc_List));
return False;
end if;
- Next_Discriminant (D);
+ Next_Discriminant (Discr);
if Ancestor_Is_Subtyp then
- Next_Elmt (D_Val);
+ Next_Elmt (Discr_Val);
end if;
end loop;
return True;
- end Discr_Present;
+ end Discriminant_Present;
+
+ ---------------------------
+ -- Find_Private_Ancestor --
+ ---------------------------
+
+ function Find_Private_Ancestor (Typ : Entity_Id) return Entity_Id is
+ Par : Entity_Id;
+
+ begin
+ Par := Typ;
+ loop
+ if Has_Private_Ancestor (Par)
+ and then not Has_Private_Ancestor (Etype (Base_Type (Par)))
+ then
+ return Par;
+
+ elsif not Is_Derived_Type (Par) then
+ return Empty;
+
+ else
+ Par := Etype (Base_Type (Par));
+ end if;
+ end loop;
+ end Find_Private_Ancestor;
---------------
-- Get_Value --
@@ -3194,8 +3526,7 @@ package body Sem_Aggr is
function Get_Value
(Compon : Node_Id;
From : List_Id;
- Consider_Others_Choice : Boolean := False)
- return Node_Id
+ Consider_Others_Choice : Boolean := False) return Node_Id
is
Typ : constant Entity_Id := Etype (Compon);
Assoc : Node_Id;
@@ -3231,7 +3562,7 @@ package body Sem_Aggr is
-- checks when the default includes function calls.
if Box_Present (Assoc) then
- Others_Box := True;
+ Others_Box := Others_Box + 1;
Is_Box_Present := True;
if Expander_Active then
@@ -3260,14 +3591,14 @@ package body Sem_Aggr is
null;
else
Error_Msg_N
- ("components in OTHERS choice must "
- & "have same type", Selector_Name);
+ ("components in OTHERS choice must have same "
+ & "type", Selector_Name);
end if;
end if;
Others_Etype := Typ;
- -- Copy expression so that it is resolved
+ -- Copy the expression so that it is resolved
-- independently for each component, This is needed
-- for accessibility checks on compoents of anonymous
-- access types, even in compile_only mode.
@@ -3408,15 +3739,110 @@ package body Sem_Aggr is
return New_Copy;
end New_Copy_Tree_And_Copy_Dimensions;
+ -----------------------------
+ -- Propagate_Discriminants --
+ -----------------------------
+
+ procedure Propagate_Discriminants
+ (Aggr : Node_Id;
+ Assoc_List : List_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+
+ Needs_Box : Boolean := False;
+
+ procedure Process_Component (Comp : Entity_Id);
+ -- Add one component with a box association to the inner aggregate,
+ -- and recurse if component is itself composite.
+
+ -----------------------
+ -- Process_Component --
+ -----------------------
+
+ procedure Process_Component (Comp : Entity_Id) is
+ T : constant Entity_Id := Etype (Comp);
+ New_Aggr : Node_Id;
+
+ begin
+ if Is_Record_Type (T) and then Has_Discriminants (T) then
+ New_Aggr := Make_Aggregate (Loc, New_List, New_List);
+ Set_Etype (New_Aggr, T);
+
+ Add_Association
+ (Comp, New_Aggr, Component_Associations (Aggr));
+
+ -- Collect discriminant values and recurse
+
+ Add_Discriminant_Values (New_Aggr, Assoc_List);
+ Propagate_Discriminants (New_Aggr, Assoc_List);
+
+ else
+ Needs_Box := True;
+ end if;
+ end Process_Component;
+
+ -- Local variables
+
+ Aggr_Type : constant Entity_Id := Base_Type (Etype (Aggr));
+ Components : constant Elist_Id := New_Elmt_List;
+ Def_Node : constant Node_Id :=
+ Type_Definition (Declaration_Node (Aggr_Type));
+
+ Comp : Node_Id;
+ Comp_Elmt : Elmt_Id;
+ Errors : Boolean;
+
+ -- Start of processing for Propagate_Discriminants
+
+ begin
+ -- The component type may be a variant type. Collect the components
+ -- that are ruled by the known values of the discriminants. Their
+ -- values have already been inserted into the component list of the
+ -- current aggregate.
+
+ if Nkind (Def_Node) = N_Record_Definition
+ and then Present (Component_List (Def_Node))
+ and then Present (Variant_Part (Component_List (Def_Node)))
+ then
+ Gather_Components (Aggr_Type,
+ Component_List (Def_Node),
+ Governed_By => Component_Associations (Aggr),
+ Into => Components,
+ Report_Errors => Errors);
+
+ Comp_Elmt := First_Elmt (Components);
+ while Present (Comp_Elmt) loop
+ if Ekind (Node (Comp_Elmt)) /= E_Discriminant then
+ Process_Component (Node (Comp_Elmt));
+ end if;
+
+ Next_Elmt (Comp_Elmt);
+ end loop;
+
+ -- No variant part, iterate over all components
+
+ else
+ Comp := First_Component (Etype (Aggr));
+ while Present (Comp) loop
+ Process_Component (Comp);
+ Next_Component (Comp);
+ end loop;
+ end if;
+
+ if Needs_Box then
+ Append_To (Component_Associations (Aggr),
+ Make_Component_Association (Loc,
+ Choices => New_List (Make_Others_Choice (Loc)),
+ Expression => Empty,
+ Box_Present => True));
+ end if;
+ end Propagate_Discriminants;
+
-----------------------
-- Resolve_Aggr_Expr --
-----------------------
- procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Node_Id) is
- Expr_Type : Entity_Id := Empty;
- New_C : Entity_Id := Component;
- New_Expr : Node_Id;
-
+ procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Entity_Id) is
function Has_Expansion_Delayed (Expr : Node_Id) return Boolean;
-- If the expression is an aggregate (possibly qualified) then its
-- expansion is delayed until the enclosing aggregate is expanded
@@ -3426,6 +3852,28 @@ package body Sem_Aggr is
-- dynamic-sized aggregate in the code, something that gigi cannot
-- handle.
+ ---------------------------
+ -- Has_Expansion_Delayed --
+ ---------------------------
+
+ function Has_Expansion_Delayed (Expr : Node_Id) return Boolean is
+ begin
+ return
+ (Nkind_In (Expr, N_Aggregate, N_Extension_Aggregate)
+ and then Present (Etype (Expr))
+ and then Is_Record_Type (Etype (Expr))
+ and then Expansion_Delayed (Expr))
+ or else
+ (Nkind (Expr) = N_Qualified_Expression
+ and then Has_Expansion_Delayed (Expression (Expr)));
+ end Has_Expansion_Delayed;
+
+ -- Local variables
+
+ Expr_Type : Entity_Id := Empty;
+ New_C : Entity_Id := Component;
+ New_Expr : Node_Id;
+
Relocate : Boolean;
-- Set to True if the resolved Expr node needs to be relocated when
-- attached to the newly created association list. This node need not
@@ -3435,21 +3883,6 @@ package body Sem_Aggr is
-- aggregate and hence it needs to be relocated when moved over to
-- the new association list.
- ---------------------------
- -- Has_Expansion_Delayed --
- ---------------------------
-
- function Has_Expansion_Delayed (Expr : Node_Id) return Boolean is
- Kind : constant Node_Kind := Nkind (Expr);
- begin
- return (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate)
- and then Present (Etype (Expr))
- and then Is_Record_Type (Etype (Expr))
- and then Expansion_Delayed (Expr))
- or else (Kind = N_Qualified_Expression
- and then Has_Expansion_Delayed (Expression (Expr)));
- end Has_Expansion_Delayed;
-
-- Start of processing for Resolve_Aggr_Expr
begin
@@ -3552,7 +3985,9 @@ package body Sem_Aggr is
-- because the aggegate might not be expanded into individual
-- component assignments.
- if Present (Predicate_Function (Expr_Type)) then
+ if Present (Predicate_Function (Expr_Type))
+ and then Analyzed (Expr)
+ then
Apply_Predicate_Check (Expr, Expr_Type);
end if;
@@ -3570,6 +4005,8 @@ package body Sem_Aggr is
Generate_Range_Check (Expr, Expr_Type, CE_Range_Check_Failed);
end if;
+ -- Add association Component => Expr if the caller requests it
+
if Relocate then
New_Expr := Relocate_Node (Expr);
@@ -3585,6 +4022,17 @@ package body Sem_Aggr is
Add_Association (New_C, New_Expr, New_Assoc_List);
end Resolve_Aggr_Expr;
+ -- Local variables
+
+ Components : constant Elist_Id := New_Elmt_List;
+ -- Components is the list of the record components whose value must be
+ -- provided in the aggregate. This list does include discriminants.
+
+ Expr : Node_Id;
+ Component : Entity_Id;
+ Component_Elmt : Elmt_Id;
+ Positional_Expr : Node_Id;
+
-- Start of processing for Resolve_Record_Aggregate
begin
@@ -3597,7 +4045,6 @@ package body Sem_Aggr is
if Present (Component_Associations (N))
and then Present (First (Component_Associations (N)))
then
-
if Present (Expressions (N)) then
Check_SPARK_05_Restriction
("named association cannot follow positional one",
@@ -3668,8 +4115,9 @@ package body Sem_Aggr is
-- STEP 2: Verify aggregate structure
Step_2 : declare
- Selector_Name : Node_Id;
+ Assoc : Node_Id;
Bad_Aggregate : Boolean := False;
+ Selector_Name : Node_Id;
begin
if Present (Component_Associations (N)) then
@@ -3704,7 +4152,8 @@ package body Sem_Aggr is
-- any component.
elsif Box_Present (Assoc) then
- Others_Box := True;
+ Others_Box := 1;
+ Box_Node := Assoc;
end if;
else
@@ -3763,7 +4212,7 @@ package body Sem_Aggr is
-- First find the discriminant values in the positional components
while Present (Discrim) and then Present (Positional_Expr) loop
- if Discr_Present (Discrim) then
+ if Discriminant_Present (Discrim) then
Resolve_Aggr_Expr (Positional_Expr, Discrim);
-- Ada 2005 (AI-231)
@@ -3791,7 +4240,7 @@ package body Sem_Aggr is
while Present (Discrim) loop
Expr := Get_Value (Discrim, Component_Associations (N), True);
- if not Discr_Present (Discrim) then
+ if not Discriminant_Present (Discrim) then
if Present (Expr) then
Error_Msg_NE
("more than one value supplied for discriminant &",
@@ -3839,17 +4288,17 @@ package body Sem_Aggr is
and then Present (Underlying_Record_View (Typ)))
then
Build_Constrained_Itype : declare
+ Constrs : constant List_Id := New_List;
Loc : constant Source_Ptr := Sloc (N);
+ Def_Id : Entity_Id;
Indic : Node_Id;
+ New_Assoc : Node_Id;
Subtyp_Decl : Node_Id;
- Def_Id : Entity_Id;
-
- C : constant List_Id := New_List;
begin
New_Assoc := First (New_Assoc_List);
while Present (New_Assoc) loop
- Append (Duplicate_Subexpr (Expression (New_Assoc)), To => C);
+ Append_To (Constrs, Duplicate_Subexpr (Expression (New_Assoc)));
Next (New_Assoc);
end loop;
@@ -3861,14 +4310,16 @@ package body Sem_Aggr is
Subtype_Mark =>
New_Occurrence_Of (Underlying_Record_View (Typ), Loc),
Constraint =>
- Make_Index_Or_Discriminant_Constraint (Loc, C));
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => Constrs));
else
Indic :=
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (Base_Type (Typ), Loc),
Constraint =>
- Make_Index_Or_Discriminant_Constraint (Loc, C));
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => Constrs));
end if;
Def_Id := Create_Itype (Ekind (Typ), N);
@@ -3895,45 +4346,13 @@ package body Sem_Aggr is
-- STEP 5: Get remaining components according to discriminant values
Step_5 : declare
+ Dnode : Node_Id;
+ Errors_Found : Boolean := False;
Record_Def : Node_Id;
Parent_Typ : Entity_Id;
- Root_Typ : Entity_Id;
Parent_Typ_List : Elist_Id;
Parent_Elmt : Elmt_Id;
- Errors_Found : Boolean := False;
- Dnode : Node_Id;
-
- function Find_Private_Ancestor return Entity_Id;
- -- AI05-0115: Find earlier ancestor in the derivation chain that is
- -- derived from a private view. Whether the aggregate is legal
- -- depends on the current visibility of the type as well as that
- -- of the parent of the ancestor.
-
- ---------------------------
- -- Find_Private_Ancestor --
- ---------------------------
-
- function Find_Private_Ancestor return Entity_Id is
- Par : Entity_Id;
-
- begin
- Par := Typ;
- loop
- if Has_Private_Ancestor (Par)
- and then not Has_Private_Ancestor (Etype (Base_Type (Par)))
- then
- return Par;
-
- elsif not Is_Derived_Type (Par) then
- return Empty;
-
- else
- Par := Etype (Base_Type (Par));
- end if;
- end loop;
- end Find_Private_Ancestor;
-
- -- Start of processing for Step_5
+ Root_Typ : Entity_Id;
begin
if Is_Derived_Type (Typ) and then Is_Tagged_Type (Typ) then
@@ -3948,19 +4367,20 @@ package body Sem_Aggr is
Root_Typ := Base_Type (Etype (Ancestor_Part (N)));
else
- -- AI05-0115: check legality of aggregate for type with
- -- aa private ancestor.
+ -- AI05-0115: check legality of aggregate for type with a
+ -- private ancestor.
Root_Typ := Root_Type (Typ);
if Has_Private_Ancestor (Typ) then
declare
Ancestor : constant Entity_Id :=
- Find_Private_Ancestor;
+ Find_Private_Ancestor (Typ);
Ancestor_Unit : constant Entity_Id :=
- Cunit_Entity (Get_Source_Unit (Ancestor));
+ Cunit_Entity
+ (Get_Source_Unit (Ancestor));
Parent_Unit : constant Entity_Id :=
- Cunit_Entity
- (Get_Source_Unit (Base_Type (Etype (Ancestor))));
+ Cunit_Entity (Get_Source_Unit
+ (Base_Type (Etype (Ancestor))));
begin
-- Check whether we are in a scope that has full view
-- over the private ancestor and its parent. This can
@@ -4178,8 +4598,7 @@ package body Sem_Aggr is
-- object of the aggregate.
if Present (Parent (Component))
- and then
- Nkind (Parent (Component)) = N_Component_Declaration
+ and then Nkind (Parent (Component)) = N_Component_Declaration
and then Present (Expression (Parent (Component)))
then
Expr :=
@@ -4202,26 +4621,18 @@ package body Sem_Aggr is
elsif Present (Underlying_Type (Ctyp))
and then Is_Access_Type (Underlying_Type (Ctyp))
then
- if not Is_Private_Type (Ctyp) then
- Expr := Make_Null (Sloc (N));
- Set_Etype (Expr, Ctyp);
- Add_Association
- (Component => Component,
- Expr => Expr,
- Assoc_List => New_Assoc_List);
-
-- If the component's type is private with an access type as
-- its underlying type then we have to create an unchecked
-- conversion to satisfy type checking.
- else
+ if Is_Private_Type (Ctyp) then
declare
Qual_Null : constant Node_Id :=
Make_Qualified_Expression (Sloc (N),
Subtype_Mark =>
New_Occurrence_Of
(Underlying_Type (Ctyp), Sloc (N)),
- Expression => Make_Null (Sloc (N)));
+ Expression => Make_Null (Sloc (N)));
Convert_Null : constant Node_Id :=
Unchecked_Convert_To
@@ -4234,6 +4645,17 @@ package body Sem_Aggr is
Expr => Convert_Null,
Assoc_List => New_Assoc_List);
end;
+
+ -- Otherwise the component type is non-private
+
+ else
+ Expr := Make_Null (Sloc (N));
+ Set_Etype (Expr, Ctyp);
+
+ Add_Association
+ (Component => Component,
+ Expr => Expr,
+ Assoc_List => New_Assoc_List);
end if;
-- Ada 2012: If component is scalar with default value, use it
@@ -4243,8 +4665,9 @@ package body Sem_Aggr is
then
Add_Association
(Component => Component,
- Expr => Default_Aspect_Value
- (First_Subtype (Underlying_Type (Ctyp))),
+ Expr =>
+ Default_Aspect_Value
+ (First_Subtype (Underlying_Type (Ctyp))),
Assoc_List => New_Assoc_List);
elsif Has_Non_Null_Base_Init_Proc (Ctyp)
@@ -4259,8 +4682,8 @@ package body Sem_Aggr is
-- for the rest, if other components are present.
-- The type of the aggregate is the known subtype of
- -- the component. The capture of discriminants must
- -- be recursive because subcomponents may be constrained
+ -- the component. The capture of discriminants must be
+ -- recursive because subcomponents may be constrained
-- (transitively) by discriminants of enclosing types.
-- For a private type with discriminants, a call to the
-- initialization procedure will be generated, and no
@@ -4270,205 +4693,6 @@ package body Sem_Aggr is
Loc : constant Source_Ptr := Sloc (N);
Expr : Node_Id;
- procedure Add_Discriminant_Values
- (New_Aggr : Node_Id;
- Assoc_List : List_Id);
- -- The constraint to a component may be given by a
- -- discriminant of the enclosing type, in which case
- -- we have to retrieve its value, which is part of the
- -- enclosing aggregate. Assoc_List provides the
- -- discriminant associations of the current type or
- -- of some enclosing record.
-
- procedure Propagate_Discriminants
- (Aggr : Node_Id;
- Assoc_List : List_Id);
- -- Nested components may themselves be discriminated
- -- types constrained by outer discriminants, whose
- -- values must be captured before the aggregate is
- -- expanded into assignments.
-
- -----------------------------
- -- Add_Discriminant_Values --
- -----------------------------
-
- procedure Add_Discriminant_Values
- (New_Aggr : Node_Id;
- Assoc_List : List_Id)
- is
- Assoc : Node_Id;
- Discr : Entity_Id;
- Discr_Elmt : Elmt_Id;
- Discr_Val : Node_Id;
- Val : Entity_Id;
-
- begin
- Discr := First_Discriminant (Etype (New_Aggr));
- Discr_Elmt :=
- First_Elmt
- (Discriminant_Constraint (Etype (New_Aggr)));
- while Present (Discr_Elmt) loop
- Discr_Val := Node (Discr_Elmt);
-
- -- If the constraint is given by a discriminant
- -- it is a discriminant of an enclosing record,
- -- and its value has already been placed in the
- -- association list.
-
- if Is_Entity_Name (Discr_Val)
- and then
- Ekind (Entity (Discr_Val)) = E_Discriminant
- then
- Val := Entity (Discr_Val);
-
- Assoc := First (Assoc_List);
- while Present (Assoc) loop
- if Present
- (Entity (First (Choices (Assoc))))
- and then
- Entity (First (Choices (Assoc))) = Val
- then
- Discr_Val := Expression (Assoc);
- exit;
- end if;
-
- Next (Assoc);
- end loop;
- end if;
-
- Add_Association
- (Discr, New_Copy_Tree (Discr_Val),
- Component_Associations (New_Aggr));
-
- -- If the discriminant constraint is a current
- -- instance, mark the current aggregate so that
- -- the self-reference can be expanded later.
- -- The constraint may refer to the subtype of
- -- aggregate, so use base type for comparison.
-
- if Nkind (Discr_Val) = N_Attribute_Reference
- and then Is_Entity_Name (Prefix (Discr_Val))
- and then Is_Type (Entity (Prefix (Discr_Val)))
- and then Base_Type (Etype (N)) =
- Entity (Prefix (Discr_Val))
- then
- Set_Has_Self_Reference (N);
- end if;
-
- Next_Elmt (Discr_Elmt);
- Next_Discriminant (Discr);
- end loop;
- end Add_Discriminant_Values;
-
- -----------------------------
- -- Propagate_Discriminants --
- -----------------------------
-
- procedure Propagate_Discriminants
- (Aggr : Node_Id;
- Assoc_List : List_Id)
- is
- Aggr_Type : constant Entity_Id :=
- Base_Type (Etype (Aggr));
- Def_Node : constant Node_Id :=
- Type_Definition
- (Declaration_Node (Aggr_Type));
-
- Comp : Node_Id;
- Comp_Elmt : Elmt_Id;
- Components : constant Elist_Id := New_Elmt_List;
- Needs_Box : Boolean := False;
- Errors : Boolean;
-
- procedure Process_Component (Comp : Entity_Id);
- -- Add one component with a box association to the
- -- inner aggregate, and recurse if component is
- -- itself composite.
-
- -----------------------
- -- Process_Component --
- -----------------------
-
- procedure Process_Component (Comp : Entity_Id) is
- T : constant Entity_Id := Etype (Comp);
- New_Aggr : Node_Id;
-
- begin
- if Is_Record_Type (T)
- and then Has_Discriminants (T)
- then
- New_Aggr :=
- Make_Aggregate (Loc, New_List, New_List);
- Set_Etype (New_Aggr, T);
- Add_Association
- (Comp, New_Aggr,
- Component_Associations (Aggr));
-
- -- Collect discriminant values and recurse
-
- Add_Discriminant_Values
- (New_Aggr, Assoc_List);
- Propagate_Discriminants
- (New_Aggr, Assoc_List);
-
- else
- Needs_Box := True;
- end if;
- end Process_Component;
-
- -- Start of processing for Propagate_Discriminants
-
- begin
- -- The component type may be a variant type, so
- -- collect the components that are ruled by the
- -- known values of the discriminants. Their values
- -- have already been inserted into the component
- -- list of the current aggregate.
-
- if Nkind (Def_Node) = N_Record_Definition
- and then Present (Component_List (Def_Node))
- and then
- Present
- (Variant_Part (Component_List (Def_Node)))
- then
- Gather_Components (Aggr_Type,
- Component_List (Def_Node),
- Governed_By => Component_Associations (Aggr),
- Into => Components,
- Report_Errors => Errors);
-
- Comp_Elmt := First_Elmt (Components);
- while Present (Comp_Elmt) loop
- if Ekind (Node (Comp_Elmt)) /= E_Discriminant
- then
- Process_Component (Node (Comp_Elmt));
- end if;
-
- Next_Elmt (Comp_Elmt);
- end loop;
-
- -- No variant part, iterate over all components
-
- else
- Comp := First_Component (Etype (Aggr));
- while Present (Comp) loop
- Process_Component (Comp);
- Next_Component (Comp);
- end loop;
- end if;
-
- if Needs_Box then
- Append_To (Component_Associations (Aggr),
- Make_Component_Association (Loc,
- Choices =>
- New_List (Make_Others_Choice (Loc)),
- Expression => Empty,
- Box_Present => True));
- end if;
- end Propagate_Discriminants;
-
- -- Start of processing for Capture_Discriminants
-
begin
Expr := Make_Aggregate (Loc, New_List, New_List);
Set_Etype (Expr, Ctyp);
@@ -4486,9 +4710,9 @@ package body Sem_Aggr is
elsif Has_Discriminants (Ctyp) then
Add_Discriminant_Values
- (Expr, Component_Associations (Expr));
+ (Expr, Component_Associations (Expr));
Propagate_Discriminants
- (Expr, Component_Associations (Expr));
+ (Expr, Component_Associations (Expr));
else
declare
@@ -4511,6 +4735,7 @@ package body Sem_Aggr is
Expression => Empty,
Box_Present => True));
end if;
+
exit;
end if;
@@ -4525,6 +4750,9 @@ package body Sem_Aggr is
Assoc_List => New_Assoc_List);
end Capture_Discriminants;
+ -- Otherwise the component type is not a record, or it has
+ -- not discriminants, or it is private.
+
else
Add_Association
(Component => Component,
@@ -4564,6 +4792,9 @@ package body Sem_Aggr is
-- STEP 7: check for invalid components + check type in choice list
Step_7 : declare
+ Assoc : Node_Id;
+ New_Assoc : Node_Id;
+
Selectr : Node_Id;
-- Selector name
@@ -4585,9 +4816,14 @@ package body Sem_Aggr is
-- Ada 2005 (AI-287): others choice may have expression or box
- if No (Others_Etype) and then not Others_Box then
+ if No (Others_Etype) and then Others_Box = 0 then
Error_Msg_N
("OTHERS must represent at least one component", Selectr);
+
+ elsif Others_Box = 1 and then Warn_On_Redundant_Constructs then
+ Error_Msg_N ("others choice is redundant?", Box_Node);
+ Error_Msg_N
+ ("\previous choices cover all components?", Box_Node);
end if;
exit Verification;
@@ -4634,7 +4870,7 @@ package body Sem_Aggr is
if Nkind (N) /= N_Extension_Aggregate
or else
Scope (Original_Record_Component (C)) /=
- Etype (Ancestor_Part (N))
+ Etype (Ancestor_Part (N))
then
exit;
end if;
@@ -4733,8 +4969,9 @@ package body Sem_Aggr is
when E_Array_Type =>
Comp_Typ := Component_Type (Typ);
- when E_Component |
- E_Discriminant =>
+ when E_Component
+ | E_Discriminant
+ =>
Comp_Typ := Etype (Typ);
when others =>
diff --git a/gcc/ada/sem_aggr.ads b/gcc/ada/sem_aggr.ads
index a0c1620cd3..8e795291c3 100644
--- a/gcc/ada/sem_aggr.ads
+++ b/gcc/ada/sem_aggr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -30,6 +30,7 @@ with Types; use Types;
package Sem_Aggr is
+ procedure Resolve_Delta_Aggregate (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Aggregate (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Extension_Aggregate (N : Node_Id; Typ : Entity_Id);
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index f0bb4cf932..bb719d3301 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -78,6 +78,8 @@ with Uintp; use Uintp;
with Uname; use Uname;
with Urealp; use Urealp;
+with System.CRC32; use System.CRC32;
+
package body Sem_Attr is
True_Value : constant Uint := Uint_1;
@@ -748,7 +750,25 @@ package body Sem_Attr is
if Nkind_In (Par, N_Aggregate, N_Extension_Aggregate) then
if Etype (Par) = Typ then
Set_Has_Self_Reference (Par);
- return True;
+
+ -- Check the context: the aggregate must be part of the
+ -- initialization of a type or component, or it is the
+ -- resulting expansion in an initialization procedure.
+
+ if Is_Init_Proc (Current_Scope) then
+ return True;
+ else
+ Par := Parent (Par);
+ while Present (Par) loop
+ if Nkind (Par) = N_Full_Type_Declaration then
+ return True;
+ end if;
+
+ Par := Parent (Par);
+ end loop;
+ end if;
+
+ return False;
end if;
end if;
@@ -1016,9 +1036,16 @@ package body Sem_Attr is
Set_Never_Set_In_Source (Ent, False);
end if;
- -- Mark entity as address taken, and kill current values
+ -- Mark entity as address taken in the case of
+ -- 'Unrestricted_Access or subprograms, and kill current
+ -- values.
+
+ if Aname = Name_Unrestricted_Access
+ or else Is_Subprogram (Ent)
+ then
+ Set_Address_Taken (Ent);
+ end if;
- Set_Address_Taken (Ent);
Kill_Current_Values (Ent);
exit;
@@ -1033,7 +1060,7 @@ package body Sem_Attr is
end loop;
end;
- -- Check for aliased view.. We allow a nonaliased prefix when within
+ -- Check for aliased view. We allow a nonaliased prefix when within
-- an instance because the prefix may have been a tagged formal
-- object, which is defined to be aliased even when the actual
-- might not be (other instance cases will have been caught in the
@@ -1336,14 +1363,27 @@ package body Sem_Attr is
-- The aspect or pragma where the attribute resides should be
-- associated with a subprogram declaration or a body. If this is not
-- the case, then the aspect or pragma is illegal. Return as analysis
- -- cannot be carried out.
+ -- cannot be carried out. Note that it is legal to have the aspect
+ -- appear on a subprogram renaming, when the renamed entity is an
+ -- attribute reference.
- if not Nkind_In (Subp_Decl, N_Abstract_Subprogram_Declaration,
- N_Entry_Declaration,
- N_Generic_Subprogram_Declaration,
- N_Subprogram_Body,
- N_Subprogram_Body_Stub,
- N_Subprogram_Declaration)
+ -- Generating C code the internally built nested _postcondition
+ -- subprograms are inlined; after expanded, inlined aspects are
+ -- located in the internal block generated by the frontend.
+
+ if Nkind (Subp_Decl) = N_Block_Statement
+ and then Modify_Tree_For_C
+ and then In_Inlined_Body
+ then
+ null;
+
+ elsif not Nkind_In (Subp_Decl, N_Abstract_Subprogram_Declaration,
+ N_Entry_Declaration,
+ N_Generic_Subprogram_Declaration,
+ N_Subprogram_Body,
+ N_Subprogram_Body_Stub,
+ N_Subprogram_Declaration,
+ N_Subprogram_Renaming_Declaration)
then
return;
end if;
@@ -1352,6 +1392,26 @@ package body Sem_Attr is
Legal := True;
Spec_Id := Unique_Defining_Entity (Subp_Decl);
+
+ -- When generating C code, nested _postcondition subprograms are
+ -- inlined by the front end to avoid problems (when unnested) with
+ -- referenced itypes. Handle that here, since as part of inlining the
+ -- expander nests subprogram within a dummy procedure named _parent
+ -- (see Build_Postconditions_Procedure and Build_Body_To_Inline).
+ -- Hence, in this context, the spec_id of _postconditions is the
+ -- enclosing scope.
+
+ if Modify_Tree_For_C
+ and then Chars (Spec_Id) = Name_uParent
+ and then Chars (Scope (Spec_Id)) = Name_uPostconditions
+ then
+ -- This situation occurs only when preanalyzing the inlined body
+
+ pragma Assert (not Full_Analysis);
+
+ Spec_Id := Scope (Spec_Id);
+ pragma Assert (Is_Inlined (Spec_Id));
+ end if;
end Analyze_Attribute_Old_Result;
---------------------------------
@@ -1374,10 +1434,41 @@ package body Sem_Attr is
--------------------------------
procedure Check_Array_Or_Scalar_Type is
+ function In_Aspect_Specification return Boolean;
+ -- A current instance of a type in an aspect specification is an
+ -- object and not a type, and therefore cannot be of a scalar type
+ -- in the prefix of one of the array attributes if the attribute
+ -- reference is part of an aspect expression.
+
+ -----------------------------
+ -- In_Aspect_Specification --
+ -----------------------------
+
+ function In_Aspect_Specification return Boolean is
+ P : Node_Id;
+
+ begin
+ P := Parent (N);
+ while Present (P) loop
+ if Nkind (P) = N_Aspect_Specification then
+ return P_Type = Entity (P);
+
+ elsif Nkind (P) in N_Declaration then
+ return False;
+ end if;
+
+ P := Parent (P);
+ end loop;
+
+ return False;
+ end In_Aspect_Specification;
+
+ -- Local variables
+
+ Dims : Int;
Index : Entity_Id;
- D : Int;
- -- Dimension number for array attributes
+ -- Start of processing for Check_Array_Or_Scalar_Type
begin
-- Case of string literal or string literal subtype. These cases
@@ -1397,6 +1488,12 @@ package body Sem_Attr is
if Present (E1) then
Error_Attr ("invalid argument in % attribute", E1);
+
+ elsif In_Aspect_Specification then
+ Error_Attr
+ ("prefix of % attribute cannot be the current instance of a "
+ & "scalar type", P);
+
else
Set_Etype (N, P_Base_Type);
return;
@@ -1432,9 +1529,9 @@ package body Sem_Attr is
Set_Etype (N, Base_Type (Etype (Index)));
else
- D := UI_To_Int (Intval (E1));
+ Dims := UI_To_Int (Intval (E1));
- for J in 1 .. D - 1 loop
+ for J in 1 .. Dims - 1 loop
Next_Index (Index);
end loop;
@@ -2624,13 +2721,15 @@ package body Sem_Attr is
-- Start of processing for Analyze_Attribute
begin
- -- Immediate return if unrecognized attribute (already diagnosed
- -- by parser, so there is nothing more that we need to do)
+ -- Immediate return if unrecognized attribute (already diagnosed by
+ -- parser, so there is nothing more that we need to do).
if not Is_Attribute_Name (Aname) then
raise Bad_Attribute;
end if;
+ Check_Restriction_No_Use_Of_Attribute (N);
+
-- Deal with Ada 83 issues
if Comes_From_Source (N) then
@@ -2847,12 +2946,13 @@ package body Sem_Attr is
-- Attributes related to Ada 2012 iterators. Attribute specifications
-- exist for these, but they cannot be queried.
- when Attribute_Constant_Indexing |
- Attribute_Default_Iterator |
- Attribute_Implicit_Dereference |
- Attribute_Iterator_Element |
- Attribute_Iterable |
- Attribute_Variable_Indexing =>
+ when Attribute_Constant_Indexing
+ | Attribute_Default_Iterator
+ | Attribute_Implicit_Dereference
+ | Attribute_Iterator_Element
+ | Attribute_Iterable
+ | Attribute_Variable_Indexing
+ =>
Error_Msg_N ("illegal attribute", N);
-- Internal attributes used to deal with Ada 2012 delayed aspects. These
@@ -2933,7 +3033,7 @@ package body Sem_Attr is
when Attribute_Asm_Input =>
Check_Asm_Attribute;
- -- The back-end may need to take the address of E2
+ -- The back end may need to take the address of E2
if Is_Entity_Name (E2) then
Set_Address_Taken (Entity (E2));
@@ -2960,7 +3060,7 @@ package body Sem_Attr is
Note_Possible_Modification (E2, Sure => True);
- -- The back-end may need to take the address of E2
+ -- The back end may need to take the address of E2
if Is_Entity_Name (E2) then
Set_Address_Taken (Entity (E2));
@@ -3023,8 +3123,7 @@ package body Sem_Attr is
-- Bit --
---------
- when Attribute_Bit => Bit :
- begin
+ when Attribute_Bit =>
Check_E0;
if not Is_Object_Reference (P) then
@@ -3037,14 +3136,12 @@ package body Sem_Attr is
end if;
Set_Etype (N, Universal_Integer);
- end Bit;
---------------
-- Bit_Order --
---------------
- when Attribute_Bit_Order => Bit_Order :
- begin
+ when Attribute_Bit_Order =>
Check_E0;
Check_Type;
@@ -3066,7 +3163,6 @@ package body Sem_Attr is
-- Reset incorrect indication of staticness
Set_Is_Static_Expression (N, False);
- end Bit_Order;
------------------
-- Bit_Position --
@@ -3258,8 +3354,8 @@ package body Sem_Attr is
if Warn_On_Obsolescent_Feature then
Error_Msg_N
- ("constrained for private type is an " &
- "obsolescent feature (RM J.4)?j?", N);
+ ("constrained for private type is an obsolescent feature "
+ & "(RM J.4)?j?", N);
end if;
-- If we are within an instance, the attribute must be legal
@@ -3297,9 +3393,9 @@ package body Sem_Attr is
P_Type := Underlying_Type (P_Type);
end if;
- -- Must have discriminants or be an access type designating
- -- a type with discriminants. If it is a classwide type it
- -- has unknown discriminants.
+ -- Must have discriminants or be an access type designating a type
+ -- with discriminants. If it is a class-wide type it has unknown
+ -- discriminants.
if Has_Discriminants (P_Type)
or else Has_Unknown_Discriminants (P_Type)
@@ -3351,8 +3447,7 @@ package body Sem_Attr is
-- Count --
-----------
- when Attribute_Count => Count :
- declare
+ when Attribute_Count => Count : declare
Ent : Entity_Id;
S : Entity_Id;
Tsk : Entity_Id;
@@ -3426,8 +3521,10 @@ package body Sem_Attr is
exit;
elsif Ekind (Scope (Ent)) in Task_Kind
- and then
- not Ekind_In (S, E_Loop, E_Block, E_Entry, E_Entry_Family)
+ and then not Ekind_In (S, E_Block,
+ E_Entry,
+ E_Entry_Family,
+ E_Loop)
then
Error_Attr ("Attribute % cannot appear in inner unit", N);
@@ -3593,10 +3690,10 @@ package body Sem_Attr is
-- Also handles processing for Elab_Spec and Elab_Subp_Body
- when Attribute_Elab_Body |
- Attribute_Elab_Spec |
- Attribute_Elab_Subp_Body =>
-
+ when Attribute_Elab_Body
+ | Attribute_Elab_Spec
+ | Attribute_Elab_Subp_Body
+ =>
Check_E0;
Check_Unit_Name (P);
Set_Etype (N, Standard_Void_Type);
@@ -3656,32 +3753,23 @@ package body Sem_Attr is
-- Enum_Rep --
--------------
- when Attribute_Enum_Rep => Enum_Rep : declare
- begin
+ when Attribute_Enum_Rep =>
if Present (E1) then
Check_E1;
Check_Discrete_Type;
Resolve (E1, P_Base_Type);
- else
- if not Is_Entity_Name (P)
- or else (not Is_Object (Entity (P))
- and then Ekind (Entity (P)) /= E_Enumeration_Literal)
- then
- Error_Attr_P
- ("prefix of % attribute must be " &
- "discrete type/object or enum literal");
- end if;
+ elsif not Is_Discrete_Type (Etype (P)) then
+ Error_Attr_P ("prefix of % attribute must be of discrete type");
end if;
Set_Etype (N, Universal_Integer);
- end Enum_Rep;
--------------
-- Enum_Val --
--------------
- when Attribute_Enum_Val => Enum_Val : begin
+ when Attribute_Enum_Val =>
Check_E1;
Check_Type;
@@ -3707,7 +3795,6 @@ package body Sem_Attr is
Resolve (E1, Any_Integer);
Set_Etype (N, P_Base_Type);
end if;
- end Enum_Val;
-------------
-- Epsilon --
@@ -3748,6 +3835,42 @@ package body Sem_Attr is
Check_Standard_Prefix;
Rewrite (N, New_Occurrence_Of (Boolean_Literals (Fast_Math), Loc));
+ -----------------------
+ -- Finalization_Size --
+ -----------------------
+
+ when Attribute_Finalization_Size =>
+ Check_E0;
+
+ -- The prefix denotes an object
+
+ if Is_Object_Reference (P) then
+ Check_Object_Reference (P);
+
+ -- The prefix denotes a type
+
+ elsif Is_Entity_Name (P) and then Is_Type (Entity (P)) then
+ Check_Type;
+ Check_Not_Incomplete_Type;
+
+ -- Attribute 'Finalization_Size is not defined for class-wide
+ -- types because it is not possible to know statically whether
+ -- a definite type will have controlled components or not.
+
+ if Is_Class_Wide_Type (Etype (P)) then
+ Error_Attr_P
+ ("prefix of % attribute cannot denote a class-wide type");
+ end if;
+
+ -- The prefix denotes an illegal construct
+
+ else
+ Error_Attr_P
+ ("prefix of % attribute must be a definite type or an object");
+ end if;
+
+ Set_Etype (N, Universal_Integer);
+
-----------
-- First --
-----------
@@ -3885,8 +4008,8 @@ package body Sem_Attr is
else
if Ada_Version >= Ada_2005 then
Error_Attr_P
- ("prefix of % attribute must be an exception, a " &
- "task or a task interface class-wide object");
+ ("prefix of % attribute must be an exception, a task or a "
+ & "task interface class-wide object");
else
Error_Attr_P
("prefix of % attribute must be a task or an exception");
@@ -3897,10 +4020,30 @@ package body Sem_Attr is
-- Image --
-----------
- when Attribute_Image => Image :
- begin
+ when Attribute_Image =>
Check_SPARK_05_Restriction_On_Attribute;
- Check_Scalar_Type;
+
+ -- AI12-00124-1 : The ARG has adopted the GNAT semantics of 'Img
+ -- for scalar types, so that the prefix can be an object and not
+ -- a type, and there is no need for an argument. Given this vote
+ -- of confidence from the ARG, simplest is to transform this new
+ -- usage of 'Image into a reference to 'Img.
+
+ if Ada_Version > Ada_2005
+ and then Is_Object_Reference (P)
+ and then Is_Scalar_Type (P_Type)
+ then
+ Rewrite (N,
+ Make_Attribute_Reference (Loc,
+ Prefix => Relocate_Node (P),
+ Attribute_Name => Name_Img));
+ Analyze (N);
+ return;
+
+ else
+ Check_Scalar_Type;
+ end if;
+
Set_Etype (N, Standard_String);
if Is_Real_Type (P_Type) then
@@ -3929,14 +4072,12 @@ package body Sem_Attr is
then
Check_Restriction (No_Fixed_IO, P);
end if;
- end Image;
---------
-- Img --
---------
- when Attribute_Img => Img :
- begin
+ when Attribute_Img =>
Check_E0;
Set_Etype (N, Standard_String);
@@ -3956,7 +4097,6 @@ package body Sem_Attr is
then
Check_Restriction (No_Fixed_IO, P);
end if;
- end Img;
-----------
-- Input --
@@ -4155,13 +4295,13 @@ package body Sem_Attr is
-- Local variables
- Context : constant Node_Id := Parent (N);
- Attr : Node_Id;
- Enclosing_Loop : Node_Id;
- Loop_Id : Entity_Id := Empty;
- Scop : Entity_Id;
- Stmt : Node_Id;
- Enclosing_Pragma : Node_Id := Empty;
+ Context : constant Node_Id := Parent (N);
+ Attr : Node_Id;
+ Encl_Loop : Node_Id;
+ Encl_Prag : Node_Id := Empty;
+ Loop_Id : Entity_Id := Empty;
+ Scop : Entity_Id;
+ Stmt : Node_Id;
-- Start of processing for Loop_Entry
@@ -4272,14 +4412,14 @@ package body Sem_Attr is
-- that the pragma appears in an appropriate loop location.
if Nkind (Original_Node (Stmt)) = N_Pragma
- and then Nam_In (Pragma_Name (Original_Node (Stmt)),
+ and then Nam_In (Pragma_Name_Unmapped (Original_Node (Stmt)),
Name_Loop_Invariant,
Name_Loop_Variant,
Name_Assert,
Name_Assert_And_Cut,
Name_Assume)
then
- Enclosing_Pragma := Original_Node (Stmt);
+ Encl_Prag := Original_Node (Stmt);
-- Locate the enclosing loop (if any). Note that Ada 2012 array
-- iteration may be expanded into several nested loops, we are
@@ -4291,14 +4431,14 @@ package body Sem_Attr is
and then Comes_From_Source (Original_Node (Stmt))
and then Nkind (Original_Node (Stmt)) = N_Loop_Statement
then
- Enclosing_Loop := Stmt;
+ Encl_Loop := Stmt;
-- The original attribute reference may lack a loop name. Use
-- the name of the enclosing loop because it is the related
-- loop.
if No (Loop_Id) then
- Loop_Id := Entity (Identifier (Enclosing_Loop));
+ Loop_Id := Entity (Identifier (Encl_Loop));
end if;
exit;
@@ -4317,7 +4457,17 @@ package body Sem_Attr is
-- purpose if they appear in an appropriate location in a loop,
-- which was already checked by the top level pragma circuit).
- if No (Enclosing_Pragma) then
+ -- Loop_Entry also denotes a value and as such can appear within an
+ -- expression that is an argument for another loop aspect. In that
+ -- case it will have been expanded into the corresponding assignment.
+
+ if Expander_Active
+ and then Nkind (Parent (N)) = N_Assignment_Statement
+ and then not Comes_From_Source (Parent (N))
+ then
+ null;
+
+ elsif No (Encl_Prag) then
Error_Attr ("attribute% must appear within appropriate pragma", N);
end if;
@@ -4354,8 +4504,8 @@ package body Sem_Attr is
then
null;
- elsif Present (Enclosing_Loop)
- and then Entity (Identifier (Enclosing_Loop)) /= Loop_Id
+ elsif Present (Encl_Loop)
+ and then Entity (Identifier (Encl_Loop)) /= Loop_Id
then
Error_Attr_P
("prefix of attribute % that applies to outer loop must denote "
@@ -4371,11 +4521,13 @@ package body Sem_Attr is
-- early transformation also avoids the generation of a useless loop
-- entry constant.
- if Is_Ignored (Enclosing_Pragma) then
+ if Present (Encl_Prag) and then Is_Ignored (Encl_Prag) then
Rewrite (N, Relocate_Node (P));
- end if;
+ Preanalyze_And_Resolve (N);
- Preanalyze_And_Resolve (P);
+ else
+ Preanalyze_And_Resolve (P);
+ end if;
end Loop_Entry;
-------------
@@ -4793,7 +4945,16 @@ package body Sem_Attr is
-- the case, then the aspect or pragma is illegal. Return as analysis
-- cannot be carried out.
- if not Legal then
+ -- The exception to this rule is when generating C since in this case
+ -- postconditions are inlined.
+
+ if No (Spec_Id)
+ and then Modify_Tree_For_C
+ and then In_Inlined_Body
+ then
+ Spec_Id := Entity (P);
+
+ elsif not Legal then
return;
end if;
@@ -4847,7 +5008,13 @@ package body Sem_Attr is
-- function Func (...) return ...
-- with Post => Func'Old ...;
- elsif Nkind (P) = N_Function_Call then
+ -- The function may be specified in qualified form X.Y where X is
+ -- a protected object and Y is a protected function. In that case
+ -- ensure that the qualified form has an entity.
+
+ elsif Nkind (P) = N_Function_Call
+ and then Nkind (Name (P)) in N_Has_Entity
+ then
Pref_Id := Entity (Name (P));
if Ekind_In (Spec_Id, E_Function, E_Generic_Function)
@@ -4871,13 +5038,20 @@ package body Sem_Attr is
-- out-of-order issues.
-- This expansion is both harmful and not needed in SPARK mode,
- -- since the formal verification backend relies on the types of
+ -- since the formal verification back end relies on the types of
-- nodes (hence is not robust w.r.t. a change to base type here),
-- and does not suffer from the out-of-order issue described
-- above. Thus, this expansion is skipped in SPARK mode.
+ -- The expansion is not relevant for discrete types, which will
+ -- not generate extra declarations, and where use of the base type
+ -- may lead to spurious errors if context is a case.
+
if not GNATprove_Mode then
- Pref_Typ := Base_Type (Pref_Typ);
+ if not Is_Discrete_Type (Pref_Typ) then
+ Pref_Typ := Base_Type (Pref_Typ);
+ end if;
+
Set_Etype (N, Pref_Typ);
Set_Etype (P, Pref_Typ);
@@ -4916,8 +5090,7 @@ package body Sem_Attr is
-- Partition_ID --
------------------
- when Attribute_Partition_ID => Partition_Id :
- begin
+ when Attribute_Partition_ID =>
Check_E0;
if P_Type /= Any_Type then
@@ -4936,7 +5109,6 @@ package body Sem_Attr is
end if;
Set_Etype (N, Universal_Integer);
- end Partition_Id;
-------------------------
-- Passed_By_Reference --
@@ -5031,6 +5203,8 @@ package body Sem_Attr is
Check_E0;
+ Check_Restriction (No_Dynamic_Priorities, N);
+
-- The prefix must be a protected object (AARM D.5.2 (2/2))
Analyze (P);
@@ -5103,7 +5277,8 @@ package body Sem_Attr is
(Pref_Id : Entity_Id;
Spec_Id : Entity_Id) return Boolean
is
- Subp_Spec : constant Node_Id := Parent (Spec_Id);
+ Over_Id : constant Entity_Id := Overridden_Operation (Spec_Id);
+ Subp_Spec : constant Node_Id := Parent (Spec_Id);
begin
-- The prefix denotes the related subprogram
@@ -5143,6 +5318,14 @@ package body Sem_Attr is
then
return True;
end if;
+
+ -- Account for a special case where a primitive of a tagged type
+ -- inherits a class-wide postcondition from a parent type. In this
+ -- case the prefix of attribute 'Result denotes the overriding
+ -- primitive.
+
+ elsif Present (Over_Id) and then Pref_Id = Over_Id then
+ return True;
end if;
-- Otherwise the prefix does not denote the related subprogram
@@ -5152,6 +5335,10 @@ package body Sem_Attr is
-- Local variables
+ In_Inlined_C_Postcondition : constant Boolean :=
+ Modify_Tree_For_C
+ and then In_Inlined_Body;
+
Legal : Boolean;
Pref_Id : Entity_Id;
Spec_Id : Entity_Id;
@@ -5182,7 +5369,13 @@ package body Sem_Attr is
-- the case, then the aspect or pragma is illegal. Return as analysis
-- cannot be carried out.
- if not Legal then
+ -- The exception to this rule is when generating C since in this case
+ -- postconditions are inlined.
+
+ if No (Spec_Id) and then In_Inlined_C_Postcondition then
+ Spec_Id := Entity (P);
+
+ elsif not Legal then
return;
end if;
@@ -5192,7 +5385,11 @@ package body Sem_Attr is
-- Instead, rewrite the attribute as a reference to formal parameter
-- _Result of the _Postconditions procedure.
- if Chars (Spec_Id) = Name_uPostconditions then
+ if Chars (Spec_Id) = Name_uPostconditions
+ or else
+ (In_Inlined_C_Postcondition
+ and then Nkind (Parent (Spec_Id)) = N_Block_Statement)
+ then
Rewrite (N, Make_Identifier (Loc, Name_uResult));
-- The type of formal parameter _Result is that of the function
@@ -5211,7 +5408,9 @@ package body Sem_Attr is
if Is_Entity_Name (P) then
Pref_Id := Entity (P);
- if Ekind_In (Pref_Id, E_Function, E_Generic_Function) then
+ if Ekind_In (Pref_Id, E_Function, E_Generic_Function)
+ and then Ekind (Spec_Id) = Ekind (Pref_Id)
+ then
if Denote_Same_Function (Pref_Id, Spec_Id) then
-- Correct the prefix of the attribute when the context
@@ -5469,8 +5668,7 @@ package body Sem_Attr is
-- Scalar_Storage_Order --
--------------------------
- when Attribute_Scalar_Storage_Order => Scalar_Storage_Order :
- declare
+ when Attribute_Scalar_Storage_Order => Scalar_Storage_Order : declare
Ent : Entity_Id := Empty;
begin
@@ -5546,8 +5744,9 @@ package body Sem_Attr is
-- Size --
----------
- when Attribute_Size | Attribute_VADS_Size => Size :
- begin
+ when Attribute_Size
+ | Attribute_VADS_Size
+ =>
Check_E0;
-- If prefix is parameterless function call, rewrite and resolve
@@ -5594,7 +5793,22 @@ package body Sem_Attr is
Check_Not_Incomplete_Type;
Check_Not_CPP_Type;
Set_Etype (N, Universal_Integer);
- end Size;
+
+ -- If we are processing pragmas Compile_Time_Warning and Compile_
+ -- Time_Errors after the back end has been called and this occurrence
+ -- of 'Size is known at compile time then it is safe to perform this
+ -- evaluation. Needed to perform the static evaluation of the full
+ -- boolean expression of these pragmas.
+
+ if In_Compile_Time_Warning_Or_Error
+ and then Is_Entity_Name (P)
+ and then (Is_Type (Entity (P))
+ or else Ekind (Entity (P)) = E_Enumeration_Literal)
+ and then Size_Known_At_Compile_Time (Entity (P))
+ then
+ Rewrite (N, Make_Integer_Literal (Sloc (N), Esize (Entity (P))));
+ Analyze (N);
+ end if;
-----------
-- Small --
@@ -5609,9 +5823,9 @@ package body Sem_Attr is
-- Storage_Pool --
------------------
- when Attribute_Storage_Pool |
- Attribute_Simple_Storage_Pool => Storage_Pool :
- begin
+ when Attribute_Storage_Pool
+ | Attribute_Simple_Storage_Pool
+ =>
Check_E0;
if Is_Access_Type (P_Type) then
@@ -5634,8 +5848,9 @@ package body Sem_Attr is
then
Error_Msg_Name_1 := Aname;
Error_Msg_Warn := SPARK_Mode /= On;
- Error_Msg_N ("cannot use % attribute for type with simple "
- & "storage pool<<", N);
+ Error_Msg_N
+ ("cannot use % attribute for type with simple storage "
+ & "pool<<", N);
Error_Msg_N ("\Program_Error [<<", N);
Rewrite
@@ -5670,14 +5885,12 @@ package body Sem_Attr is
else
Error_Attr_P ("prefix of % attribute must be access type");
end if;
- end Storage_Pool;
------------------
-- Storage_Size --
------------------
- when Attribute_Storage_Size => Storage_Size :
- begin
+ when Attribute_Storage_Size =>
Check_E0;
if Is_Task_Type (P_Type) then
@@ -5716,7 +5929,6 @@ package body Sem_Attr is
else
Error_Attr_P ("prefix of % attribute must be access or task type");
end if;
- end Storage_Size;
------------------
-- Storage_Unit --
@@ -5774,7 +5986,7 @@ package body Sem_Attr is
else
Error_Attr_P
- ("prefix of% attribute must be remote access to classwide");
+ ("prefix of% attribute must be remote access-to-class-wide");
end if;
----------
@@ -5825,8 +6037,7 @@ package body Sem_Attr is
-- Tag --
---------
- when Attribute_Tag => Tag :
- begin
+ when Attribute_Tag =>
Check_E0;
Check_Dereference;
@@ -5856,7 +6067,6 @@ package body Sem_Attr is
-- Set appropriate type
Set_Etype (N, RTE (RE_Tag));
- end Tag;
-----------------
-- Target_Name --
@@ -5986,44 +6196,150 @@ package body Sem_Attr is
-- Type_Key --
--------------
- when Attribute_Type_Key =>
- Check_E0;
- Check_Type;
+ when Attribute_Type_Key => Type_Key : declare
+ Full_Name : constant String_Id :=
+ Fully_Qualified_Name_String (Entity (P));
- -- This processing belongs in Eval_Attribute ???
+ CRC : CRC32;
+ -- The computed signature for the type
- declare
- function Type_Key return String_Id;
- -- A very preliminary implementation. For now, a signature
- -- consists of only the type name. This is clearly incomplete
- -- (e.g., adding a new field to a record type should change the
- -- type's Type_Key attribute).
+ Deref : Boolean;
+ -- To simplify the handling of mutually recursive types, follow a
+ -- single dereference link in a composite type.
- --------------
- -- Type_Key --
- --------------
+ procedure Compute_Type_Key (T : Entity_Id);
+ -- Create a CRC integer from the declaration of the type, For a
+ -- composite type, fold in the representation of its components in
+ -- recursive fashion. We use directly the source representation of
+ -- the types involved.
- function Type_Key return String_Id is
- Full_Name : constant String_Id :=
- Fully_Qualified_Name_String (Entity (P));
+ ----------------------
+ -- Compute_Type_Key --
+ ----------------------
+
+ procedure Compute_Type_Key (T : Entity_Id) is
+ Buffer : Source_Buffer_Ptr;
+ P_Max : Source_Ptr;
+ P_Min : Source_Ptr;
+ Rep : Node_Id;
+ SFI : Source_File_Index;
+
+ procedure Process_One_Declaration;
+ -- Update CRC with the characters of one type declaration, or a
+ -- representation pragma that applies to the type.
+
+ -----------------------------
+ -- Process_One_Declaration --
+ -----------------------------
+
+ procedure Process_One_Declaration is
+ Ptr : Source_Ptr;
begin
- -- Copy all characters in Full_Name but the trailing NUL
+ Ptr := P_Min;
- Start_String;
- for J in 1 .. String_Length (Full_Name) - 1 loop
- Store_String_Char (Get_String_Char (Full_Name, Int (J)));
+ -- Scan type declaration, skipping blanks
+
+ while Ptr <= P_Max loop
+ if Buffer (Ptr) /= ' ' then
+ System.CRC32.Update (CRC, Buffer (Ptr));
+ end if;
+
+ Ptr := Ptr + 1;
end loop;
+ end Process_One_Declaration;
- Store_String_Chars ("'Type_Key");
- return End_String;
- end Type_Key;
+ -- Start of processing for Compute_Type_Key
begin
- Rewrite (N, Make_String_Literal (Loc, Type_Key));
- end;
+ if Is_Itype (T) then
+ return;
+ end if;
+ Sloc_Range (Enclosing_Declaration (T), P_Min, P_Max);
+ SFI := Get_Source_File_Index (P_Min);
+ Buffer := Source_Text (SFI);
+
+ Process_One_Declaration;
+
+ -- Recurse on relevant component types
+
+ if Is_Array_Type (T) then
+ Compute_Type_Key (Component_Type (T));
+
+ elsif Is_Access_Type (T) then
+ if not Deref then
+ Deref := True;
+ Compute_Type_Key (Designated_Type (T));
+ end if;
+
+ elsif Is_Derived_Type (T) then
+ Compute_Type_Key (Etype (T));
+
+ elsif Is_Record_Type (T) then
+ declare
+ Comp : Entity_Id;
+ begin
+ Comp := First_Component (T);
+ while Present (Comp) loop
+ Compute_Type_Key (Etype (Comp));
+ Next_Component (Comp);
+ end loop;
+ end;
+ end if;
+
+ -- Fold in representation aspects for the type, which appear in
+ -- the same source buffer.
+
+ Rep := First_Rep_Item (T);
+
+ while Present (Rep) loop
+ if Comes_From_Source (Rep) then
+ Sloc_Range (Rep, P_Min, P_Max);
+ Process_One_Declaration;
+ end if;
+
+ Rep := Next_Rep_Item (Rep);
+ end loop;
+ end Compute_Type_Key;
+
+ -- Start of processing for Type_Key
+
+ begin
+ Check_E0;
+ Check_Type;
+
+ Start_String;
+ Deref := False;
+
+ -- Copy all characters in Full_Name but the trailing NUL
+
+ for J in 1 .. String_Length (Full_Name) - 1 loop
+ Store_String_Char (Get_String_Char (Full_Name, Pos (J)));
+ end loop;
+
+ -- For standard types return the name of the type, as there is no
+ -- explicit source declaration to use. Otherwise compute CRC and
+ -- convert it to string one character at a time, so as not to use
+ -- Image within the compiler.
+
+ if Scope (Entity (P)) /= Standard_Standard then
+ Initialize (CRC);
+ Compute_Type_Key (Entity (P));
+
+ if not Is_Frozen (Entity (P)) then
+ Error_Msg_N ("premature usage of Type_Key?", N);
+ end if;
+
+ while CRC > 0 loop
+ Store_String_Char (Character'Val (48 + (CRC rem 10)));
+ CRC := CRC / 10;
+ end loop;
+ end if;
+
+ Rewrite (N, Make_String_Literal (Loc, End_String));
Analyze_And_Resolve (N, Standard_String);
+ end Type_Key;
-----------------------
-- Unbiased_Rounding --
@@ -6068,8 +6384,7 @@ package body Sem_Attr is
-- the literal as it appeared in the source program with a possible
-- leading minus sign.
- when Attribute_Universal_Literal_String => Universal_Literal_String :
- begin
+ when Attribute_Universal_Literal_String =>
Check_E0;
if not Is_Entity_Name (P)
@@ -6123,7 +6438,6 @@ package body Sem_Attr is
Set_Is_Static_Expression (N, True);
end;
end if;
- end Universal_Literal_String;
-------------------------
-- Unrestricted_Access --
@@ -6476,8 +6790,7 @@ package body Sem_Attr is
-- Val --
---------
- when Attribute_Val => Val : declare
- begin
+ when Attribute_Val =>
Check_E1;
Check_Discrete_Type;
@@ -6488,13 +6801,12 @@ package body Sem_Attr is
("attribute% is not allowed for type%", P);
end if;
- Resolve (E1, Any_Integer);
- Set_Etype (N, P_Base_Type);
-
-- Note, we need a range check in general, but we wait for the
-- Resolve call to do this, since we want to let Eval_Attribute
-- have a chance to find an static illegality first.
- end Val;
+
+ Resolve (E1, Any_Integer);
+ Set_Etype (N, P_Base_Type);
-----------
-- Valid --
@@ -6561,8 +6873,7 @@ package body Sem_Attr is
-- Value --
-----------
- when Attribute_Value => Value :
- begin
+ when Attribute_Value =>
Check_SPARK_05_Restriction_On_Attribute;
Check_E1;
Check_Scalar_Type;
@@ -6608,7 +6919,6 @@ package body Sem_Attr is
then
Check_Restriction (No_Fixed_IO, P);
end if;
- end Value;
----------------
-- Value_Size --
@@ -6640,8 +6950,7 @@ package body Sem_Attr is
-- Wide_Image --
----------------
- when Attribute_Wide_Image => Wide_Image :
- begin
+ when Attribute_Wide_Image =>
Check_SPARK_05_Restriction_On_Attribute;
Check_Scalar_Type;
Set_Etype (N, Standard_Wide_String);
@@ -6656,14 +6965,12 @@ package body Sem_Attr is
then
Check_Restriction (No_Fixed_IO, P);
end if;
- end Wide_Image;
---------------------
-- Wide_Wide_Image --
---------------------
- when Attribute_Wide_Wide_Image => Wide_Wide_Image :
- begin
+ when Attribute_Wide_Wide_Image =>
Check_Scalar_Type;
Set_Etype (N, Standard_Wide_Wide_String);
Check_E1;
@@ -6677,14 +6984,12 @@ package body Sem_Attr is
then
Check_Restriction (No_Fixed_IO, P);
end if;
- end Wide_Wide_Image;
----------------
-- Wide_Value --
----------------
- when Attribute_Wide_Value => Wide_Value :
- begin
+ when Attribute_Wide_Value =>
Check_SPARK_05_Restriction_On_Attribute;
Check_E1;
Check_Scalar_Type;
@@ -6702,14 +7007,12 @@ package body Sem_Attr is
then
Check_Restriction (No_Fixed_IO, P);
end if;
- end Wide_Value;
---------------------
-- Wide_Wide_Value --
---------------------
- when Attribute_Wide_Wide_Value => Wide_Wide_Value :
- begin
+ when Attribute_Wide_Wide_Value =>
Check_E1;
Check_Scalar_Type;
@@ -6726,7 +7029,6 @@ package body Sem_Attr is
then
Check_Restriction (No_Fixed_IO, P);
end if;
- end Wide_Wide_Value;
---------------------
-- Wide_Wide_Width --
@@ -6776,6 +7078,29 @@ package body Sem_Attr is
end case;
+ -- In SPARK certain attributes (see below) depend on Tasking_State.
+ -- Ensure that the entity is available for gnat2why by loading it.
+ -- See SPARK RM 9(18) for the relevant rule.
+
+ if GNATprove_Mode then
+ declare
+ Unused : Entity_Id;
+
+ begin
+ case Attr_Id is
+ when Attribute_Callable
+ | Attribute_Caller
+ | Attribute_Count
+ | Attribute_Terminated
+ =>
+ Unused := RTE (RE_Tasking_State);
+
+ when others =>
+ null;
+ end case;
+ end;
+ end if;
+
-- All errors raise Bad_Attribute, so that we get out before any further
-- damage occurs when an error is detected (for example, if we check for
-- one attribute expression, and the check succeeds, we want to be able
@@ -7285,35 +7610,51 @@ package body Sem_Attr is
elsif Id = Attribute_Enum_Rep then
if Is_Entity_Name (P) then
- -- The prefix denotes a constant or an enumeration literal, the
- -- attribute can be folded. A generated loop variable for an
- -- iterator is a constant, but cannot be constant-folded.
+ declare
+ Enum_Expr : Node_Id;
+ -- The enumeration-type expression of interest
- if Ekind (Entity (P)) = E_Enumeration_Literal
- or else
- (Ekind (Entity (P)) = E_Constant
- and then Ekind (Scope (Entity (P))) /= E_Loop)
- then
- P_Entity := Etype (P);
+ begin
+ -- P'Enum_Rep case
- -- The prefix denotes an enumeration type. Folding can occur
- -- when the argument is a constant or an enumeration literal.
+ if Ekind_In (Entity (P), E_Constant,
+ E_Enumeration_Literal)
+ then
+ Enum_Expr := P;
- elsif Is_Enumeration_Type (Entity (P))
- and then Present (E1)
- and then Is_Entity_Name (E1)
- and then Ekind_In (Entity (E1), E_Constant,
- E_Enumeration_Literal)
- then
- P_Entity := Etype (P);
+ -- Enum_Type'Enum_Rep (E1) case
- -- Otherwise the attribute must be expanded into a conversion
- -- and evaluated at run time.
+ elsif Is_Enumeration_Type (Entity (P)) then
+ Enum_Expr := E1;
- else
- Check_Expressions;
- return;
- end if;
+ -- Otherwise the attribute must be expanded into a
+ -- conversion and evaluated at run time.
+
+ else
+ Check_Expressions;
+ return;
+ end if;
+
+ -- We can fold if the expression is an enumeration
+ -- literal, or if it denotes a constant whose value
+ -- is known at compile time.
+
+ if Nkind (Enum_Expr) in N_Has_Entity
+ and then (Ekind (Entity (Enum_Expr)) =
+ E_Enumeration_Literal
+ or else
+ (Ekind (Entity (Enum_Expr)) = E_Constant
+ and then Nkind (Parent (Entity (Enum_Expr))) =
+ N_Object_Declaration
+ and then Compile_Time_Known_Value
+ (Expression (Parent (Entity (P))))))
+ then
+ P_Entity := Etype (P);
+ else
+ Check_Expressions;
+ return;
+ end if;
+ end;
-- Otherwise the attribute is illegal, do not attempt to perform
-- any kind of folding.
@@ -7816,12 +8157,14 @@ package body Sem_Attr is
-- Attributes related to Ada 2012 iterators (placeholder ???)
- when Attribute_Constant_Indexing |
- Attribute_Default_Iterator |
- Attribute_Implicit_Dereference |
- Attribute_Iterator_Element |
- Attribute_Iterable |
- Attribute_Variable_Indexing => null;
+ when Attribute_Constant_Indexing
+ | Attribute_Default_Iterator
+ | Attribute_Implicit_Dereference
+ | Attribute_Iterator_Element
+ | Attribute_Iterable
+ | Attribute_Variable_Indexing
+ =>
+ null;
-- Internal attributes used to deal with Ada 2012 delayed aspects.
-- These were already rejected by the parser. Thus they shouldn't
@@ -8106,12 +8449,18 @@ package body Sem_Attr is
Fold_Uint (N,
Eval_Fat.Exponent (P_Base_Type, Expr_Value_R (E1)), Static);
+ -----------------------
+ -- Finalization_Size --
+ -----------------------
+
+ when Attribute_Finalization_Size =>
+ null;
+
-----------
-- First --
-----------
- when Attribute_First => First_Attr :
- begin
+ when Attribute_First =>
Set_Bounds;
if Compile_Time_Known_Value (Lo_Bound) then
@@ -8124,14 +8473,12 @@ package body Sem_Attr is
else
Check_Concurrent_Discriminant (Lo_Bound);
end if;
- end First_Attr;
-----------------
-- First_Valid --
-----------------
- when Attribute_First_Valid => First_Valid :
- begin
+ when Attribute_First_Valid =>
if Has_Predicates (P_Type)
and then Has_Static_Predicate (P_Type)
then
@@ -8150,7 +8497,6 @@ package body Sem_Attr is
Set_Bounds;
Fold_Uint (N, Expr_Value (Lo_Bound), Static);
end if;
- end First_Valid;
-----------------
-- Fixed_Value --
@@ -8343,8 +8689,7 @@ package body Sem_Attr is
-- Last --
----------
- when Attribute_Last => Last_Attr :
- begin
+ when Attribute_Last =>
Set_Bounds;
if Compile_Time_Known_Value (Hi_Bound) then
@@ -8357,14 +8702,12 @@ package body Sem_Attr is
else
Check_Concurrent_Discriminant (Hi_Bound);
end if;
- end Last_Attr;
----------------
-- Last_Valid --
----------------
- when Attribute_Last_Valid => Last_Valid :
- begin
+ when Attribute_Last_Valid =>
if Has_Predicates (P_Type)
and then Has_Static_Predicate (P_Type)
then
@@ -8383,7 +8726,6 @@ package body Sem_Attr is
Set_Bounds;
Fold_Uint (N, Expr_Value (Hi_Bound), Static);
end if;
- end Last_Valid;
------------------
-- Leading_Part --
@@ -8677,15 +9019,13 @@ package body Sem_Attr is
-- Max --
---------
- when Attribute_Max => Max :
- begin
+ when Attribute_Max =>
if Is_Real_Type (P_Type) then
Fold_Ureal
(N, UR_Max (Expr_Value_R (E1), Expr_Value_R (E2)), Static);
else
Fold_Uint (N, UI_Max (Expr_Value (E1), Expr_Value (E2)), Static);
end if;
- end Max;
----------------------------------
-- Max_Alignment_For_Allocation --
@@ -8697,18 +9037,17 @@ package body Sem_Attr is
-- and the alignment of the dope. Also, if the alignment is unknown, we
-- use the max (it's OK to be pessimistic).
- when Attribute_Max_Alignment_For_Allocation =>
- declare
- A : Uint := UI_From_Int (Ttypes.Maximum_Alignment);
- begin
- if Known_Alignment (P_Type) and then
- (not Is_Array_Type (P_Type) or else Alignment (P_Type) > A)
- then
- A := Alignment (P_Type);
- end if;
+ when Attribute_Max_Alignment_For_Allocation => Max_Align : declare
+ A : Uint := UI_From_Int (Ttypes.Maximum_Alignment);
+ begin
+ if Known_Alignment (P_Type)
+ and then (not Is_Array_Type (P_Type) or else Alignment (P_Type) > A)
+ then
+ A := Alignment (P_Type);
+ end if;
Fold_Uint (N, A, Static);
- end;
+ end Max_Align;
----------------------------------
-- Max_Size_In_Storage_Elements --
@@ -8730,37 +9069,36 @@ package body Sem_Attr is
-- Mechanism_Code --
--------------------
- when Attribute_Mechanism_Code =>
- declare
- Val : Int;
- Formal : Entity_Id;
- Mech : Mechanism_Type;
+ when Attribute_Mechanism_Code => Mechanism_Code : declare
+ Formal : Entity_Id;
+ Mech : Mechanism_Type;
+ Val : Int;
- begin
- if No (E1) then
- Mech := Mechanism (P_Entity);
+ begin
+ if No (E1) then
+ Mech := Mechanism (P_Entity);
- else
- Val := UI_To_Int (Expr_Value (E1));
+ else
+ Val := UI_To_Int (Expr_Value (E1));
- Formal := First_Formal (P_Entity);
- for J in 1 .. Val - 1 loop
- Next_Formal (Formal);
- end loop;
- Mech := Mechanism (Formal);
- end if;
+ Formal := First_Formal (P_Entity);
+ for J in 1 .. Val - 1 loop
+ Next_Formal (Formal);
+ end loop;
- if Mech < 0 then
- Fold_Uint (N, UI_From_Int (Int (-Mech)), Static);
- end if;
- end;
+ Mech := Mechanism (Formal);
+ end if;
+
+ if Mech < 0 then
+ Fold_Uint (N, UI_From_Int (Int (-Mech)), Static);
+ end if;
+ end Mechanism_Code;
---------
-- Min --
---------
- when Attribute_Min => Min :
- begin
+ when Attribute_Min =>
if Is_Real_Type (P_Type) then
Fold_Ureal
(N, UR_Min (Expr_Value_R (E1), Expr_Value_R (E2)), Static);
@@ -8768,7 +9106,6 @@ package body Sem_Attr is
Fold_Uint
(N, UI_Min (Expr_Value (E1), Expr_Value (E2)), Static);
end if;
- end Min;
---------
-- Mod --
@@ -8875,8 +9212,8 @@ package body Sem_Attr is
-- Pred --
----------
- when Attribute_Pred => Pred :
- begin
+ when Attribute_Pred =>
+
-- Floating-point case
if Is_Floating_Point_Type (P_Type) then
@@ -8915,7 +9252,6 @@ package body Sem_Attr is
Fold_Uint (N, Expr_Value (E1) - 1, Static);
end if;
- end Pred;
-----------
-- Range --
@@ -8931,7 +9267,10 @@ package body Sem_Attr is
-- Range_Length --
------------------
- when Attribute_Range_Length =>
+ when Attribute_Range_Length => Range_Length : declare
+ Diff : aliased Uint;
+
+ begin
Set_Bounds;
-- Can fold if both bounds are compile time known
@@ -8948,29 +9287,24 @@ package body Sem_Attr is
-- One more case is where Hi_Bound and Lo_Bound are compile-time
-- comparable, and we can figure out the difference between them.
- declare
- Diff : aliased Uint;
-
- begin
- case
- Compile_Time_Compare
+ case Compile_Time_Compare
(Lo_Bound, Hi_Bound, Diff'Access, Assume_Valid => False)
- is
- when EQ =>
- Fold_Uint (N, Uint_1, Static);
+ is
+ when EQ =>
+ Fold_Uint (N, Uint_1, Static);
- when GT =>
- Fold_Uint (N, Uint_0, Static);
+ when GT =>
+ Fold_Uint (N, Uint_0, Static);
- when LT =>
- if Diff /= No_Uint then
- Fold_Uint (N, Diff + 1, Static);
- end if;
+ when LT =>
+ if Diff /= No_Uint then
+ Fold_Uint (N, Diff + 1, Static);
+ end if;
- when others =>
- null;
- end case;
- end;
+ when others =>
+ null;
+ end case;
+ end Range_Length;
---------
-- Ref --
@@ -9005,18 +9339,15 @@ package body Sem_Attr is
-- Restriction --
-----------------
- when Attribute_Restriction_Set => Restriction_Set : declare
- begin
+ when Attribute_Restriction_Set =>
Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
Set_Is_Static_Expression (N);
- end Restriction_Set;
-----------
-- Round --
-----------
- when Attribute_Round => Round :
- declare
+ when Attribute_Round => Round : declare
Sr : Ureal;
Si : Uint;
@@ -9130,53 +9461,57 @@ package body Sem_Attr is
-- one of the places where it is annoying that a size of zero means two
-- things (zero size for scalars, unspecified size for non-scalars).
- when Attribute_Size | Attribute_VADS_Size => Size : declare
- P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
+ when Attribute_Size
+ | Attribute_VADS_Size
+ =>
+ Size : declare
+ P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
- begin
- if Is_Scalar_Type (P_TypeA) or else RM_Size (P_TypeA) /= Uint_0 then
-
- -- VADS_Size case
+ begin
+ if Is_Scalar_Type (P_TypeA)
+ or else RM_Size (P_TypeA) /= Uint_0
+ then
+ -- VADS_Size case
- if Id = Attribute_VADS_Size or else Use_VADS_Size then
- declare
- S : constant Node_Id := Size_Clause (P_TypeA);
+ if Id = Attribute_VADS_Size or else Use_VADS_Size then
+ declare
+ S : constant Node_Id := Size_Clause (P_TypeA);
- begin
- -- If a size clause applies, then use the size from it.
- -- This is one of the rare cases where we can use the
- -- Size_Clause field for a subtype when Has_Size_Clause
- -- is False. Consider:
+ begin
+ -- If a size clause applies, then use the size from it.
+ -- This is one of the rare cases where we can use the
+ -- Size_Clause field for a subtype when Has_Size_Clause
+ -- is False. Consider:
- -- type x is range 1 .. 64;
- -- for x'size use 12;
- -- subtype y is x range 0 .. 3;
+ -- type x is range 1 .. 64;
+ -- for x'size use 12;
+ -- subtype y is x range 0 .. 3;
- -- Here y has a size clause inherited from x, but normally
- -- it does not apply, and y'size is 2. However, y'VADS_Size
- -- is indeed 12 and not 2.
+ -- Here y has a size clause inherited from x, but
+ -- normally it does not apply, and y'size is 2. However,
+ -- y'VADS_Size is indeed 12 and not 2.
- if Present (S)
- and then Is_OK_Static_Expression (Expression (S))
- then
- Fold_Uint (N, Expr_Value (Expression (S)), Static);
+ if Present (S)
+ and then Is_OK_Static_Expression (Expression (S))
+ then
+ Fold_Uint (N, Expr_Value (Expression (S)), Static);
- -- If no size is specified, then we simply use the object
- -- size in the VADS_Size case (e.g. Natural'Size is equal
- -- to Integer'Size, not one less).
+ -- If no size is specified, then we simply use the object
+ -- size in the VADS_Size case (e.g. Natural'Size is equal
+ -- to Integer'Size, not one less).
- else
- Fold_Uint (N, Esize (P_TypeA), Static);
- end if;
- end;
+ else
+ Fold_Uint (N, Esize (P_TypeA), Static);
+ end if;
+ end;
- -- Normal case (Size) in which case we want the RM_Size
+ -- Normal case (Size) in which case we want the RM_Size
- else
- Fold_Uint (N, RM_Size (P_TypeA), Static);
+ else
+ Fold_Uint (N, RM_Size (P_TypeA), Static);
+ end if;
end if;
- end if;
- end Size;
+ end Size;
-----------
-- Small --
@@ -9218,8 +9553,7 @@ package body Sem_Attr is
-- Succ --
----------
- when Attribute_Succ => Succ :
- begin
+ when Attribute_Succ =>
-- Floating-point case
if Is_Floating_Point_Type (P_Type) then
@@ -9257,7 +9591,6 @@ package body Sem_Attr is
Fold_Uint (N, Expr_Value (E1) + 1, Static);
end if;
end if;
- end Succ;
----------------
-- Truncation --
@@ -9278,7 +9611,7 @@ package body Sem_Attr is
Id : RE_Id;
begin
- if Is_Descendent_Of_Address (Typ) then
+ if Is_Descendant_Of_Address (Typ) then
Id := RE_Type_Class_Address;
elsif Is_Enumeration_Type (Typ) then
@@ -9372,8 +9705,7 @@ package body Sem_Attr is
-- Val --
---------
- when Attribute_Val => Val :
- begin
+ when Attribute_Val =>
if Expr_Value (E1) < Expr_Value (Type_Low_Bound (P_Base_Type))
or else
Expr_Value (E1) > Expr_Value (Type_High_Bound (P_Base_Type))
@@ -9389,7 +9721,6 @@ package body Sem_Attr is
else
Fold_Uint (N, Expr_Value (E1), Static);
end if;
- end Val;
----------------
-- Value_Size --
@@ -9402,6 +9733,7 @@ package body Sem_Attr is
when Attribute_Value_Size => Value_Size : declare
P_TypeA : constant Entity_Id := Underlying_Type (P_Type);
+
begin
if Is_Scalar_Type (P_TypeA) or else RM_Size (P_TypeA) /= Uint_0 then
Fold_Uint (N, RM_Size (P_TypeA), Static);
@@ -9455,10 +9787,10 @@ package body Sem_Attr is
-- This processing also handles the case of Wide_[Wide_]Width
- when Attribute_Width |
- Attribute_Wide_Width |
- Attribute_Wide_Wide_Width => Width :
- begin
+ when Attribute_Width
+ | Attribute_Wide_Width
+ | Attribute_Wide_Wide_Width
+ =>
if Compile_Time_Known_Bounds (P_Type) then
-- Floating-point types
@@ -9566,29 +9898,83 @@ package body Sem_Attr is
-- names (length = 12).
case C is
- when Reserved_128 | Reserved_129 |
- Reserved_132 | Reserved_153
- => Wt := 12;
-
- when BS | HT | LF | VT | FF | CR |
- SO | SI | EM | FS | GS | RS |
- US | RI | MW | ST | PM
- => Wt := 2;
-
- when NUL | SOH | STX | ETX | EOT |
- ENQ | ACK | BEL | DLE | DC1 |
- DC2 | DC3 | DC4 | NAK | SYN |
- ETB | CAN | SUB | ESC | DEL |
- BPH | NBH | NEL | SSA | ESA |
- HTS | HTJ | VTS | PLD | PLU |
- SS2 | SS3 | DCS | PU1 | PU2 |
- STS | CCH | SPA | EPA | SOS |
- SCI | CSI | OSC | APC
- => Wt := 3;
-
- when Space .. Tilde |
- No_Break_Space .. LC_Y_Diaeresis
- =>
+ when Reserved_128
+ | Reserved_129
+ | Reserved_132
+ | Reserved_153
+ =>
+ Wt := 12;
+
+ when BS
+ | CR
+ | EM
+ | FF
+ | FS
+ | GS
+ | HT
+ | LF
+ | MW
+ | PM
+ | RI
+ | RS
+ | SI
+ | SO
+ | ST
+ | US
+ | VT
+ =>
+ Wt := 2;
+
+ when ACK
+ | APC
+ | BEL
+ | BPH
+ | CAN
+ | CCH
+ | CSI
+ | DC1
+ | DC2
+ | DC3
+ | DC4
+ | DCS
+ | DEL
+ | DLE
+ | ENQ
+ | EOT
+ | EPA
+ | ESA
+ | ESC
+ | ETB
+ | ETX
+ | HTJ
+ | HTS
+ | NAK
+ | NBH
+ | NEL
+ | NUL
+ | OSC
+ | PLD
+ | PLU
+ | PU1
+ | PU2
+ | SCI
+ | SOH
+ | SOS
+ | SPA
+ | SS2
+ | SS3
+ | SSA
+ | STS
+ | STX
+ | SUB
+ | SYN
+ | VTS
+ =>
+ Wt := 3;
+
+ when Space .. Tilde
+ | No_Break_Space .. LC_Y_Diaeresis
+ =>
-- Special case of soft hyphen in Ada 2005
if C = Character'Val (16#AD#)
@@ -9698,13 +10084,13 @@ package body Sem_Attr is
end;
end if;
end if;
- end Width;
-- The following attributes denote functions that cannot be folded
- when Attribute_From_Any |
- Attribute_To_Any |
- Attribute_TypeCode =>
+ when Attribute_From_Any
+ | Attribute_To_Any
+ | Attribute_TypeCode
+ =>
null;
-- The following attributes can never be folded, and furthermore we
@@ -9713,69 +10099,69 @@ package body Sem_Attr is
-- a result of the processing in Analyze_Attribute or earlier in
-- this procedure.
- when Attribute_Abort_Signal |
- Attribute_Access |
- Attribute_Address |
- Attribute_Address_Size |
- Attribute_Asm_Input |
- Attribute_Asm_Output |
- Attribute_Base |
- Attribute_Bit_Order |
- Attribute_Bit_Position |
- Attribute_Callable |
- Attribute_Caller |
- Attribute_Class |
- Attribute_Code_Address |
- Attribute_Compiler_Version |
- Attribute_Count |
- Attribute_Default_Bit_Order |
- Attribute_Default_Scalar_Storage_Order |
- Attribute_Deref |
- Attribute_Elaborated |
- Attribute_Elab_Body |
- Attribute_Elab_Spec |
- Attribute_Elab_Subp_Body |
- Attribute_Enabled |
- Attribute_External_Tag |
- Attribute_Fast_Math |
- Attribute_First_Bit |
- Attribute_Img |
- Attribute_Input |
- Attribute_Last_Bit |
- Attribute_Library_Level |
- Attribute_Maximum_Alignment |
- Attribute_Old |
- Attribute_Output |
- Attribute_Partition_ID |
- Attribute_Pool_Address |
- Attribute_Position |
- Attribute_Priority |
- Attribute_Read |
- Attribute_Result |
- Attribute_Scalar_Storage_Order |
- Attribute_Simple_Storage_Pool |
- Attribute_Storage_Pool |
- Attribute_Storage_Size |
- Attribute_Storage_Unit |
- Attribute_Stub_Type |
- Attribute_System_Allocator_Alignment |
- Attribute_Tag |
- Attribute_Target_Name |
- Attribute_Terminated |
- Attribute_To_Address |
- Attribute_Type_Key |
- Attribute_Unchecked_Access |
- Attribute_Universal_Literal_String |
- Attribute_Unrestricted_Access |
- Attribute_Valid |
- Attribute_Valid_Scalars |
- Attribute_Value |
- Attribute_Wchar_T_Size |
- Attribute_Wide_Value |
- Attribute_Wide_Wide_Value |
- Attribute_Word_Size |
- Attribute_Write =>
-
+ when Attribute_Abort_Signal
+ | Attribute_Access
+ | Attribute_Address
+ | Attribute_Address_Size
+ | Attribute_Asm_Input
+ | Attribute_Asm_Output
+ | Attribute_Base
+ | Attribute_Bit_Order
+ | Attribute_Bit_Position
+ | Attribute_Callable
+ | Attribute_Caller
+ | Attribute_Class
+ | Attribute_Code_Address
+ | Attribute_Compiler_Version
+ | Attribute_Count
+ | Attribute_Default_Bit_Order
+ | Attribute_Default_Scalar_Storage_Order
+ | Attribute_Deref
+ | Attribute_Elaborated
+ | Attribute_Elab_Body
+ | Attribute_Elab_Spec
+ | Attribute_Elab_Subp_Body
+ | Attribute_Enabled
+ | Attribute_External_Tag
+ | Attribute_Fast_Math
+ | Attribute_First_Bit
+ | Attribute_Img
+ | Attribute_Input
+ | Attribute_Last_Bit
+ | Attribute_Library_Level
+ | Attribute_Maximum_Alignment
+ | Attribute_Old
+ | Attribute_Output
+ | Attribute_Partition_ID
+ | Attribute_Pool_Address
+ | Attribute_Position
+ | Attribute_Priority
+ | Attribute_Read
+ | Attribute_Result
+ | Attribute_Scalar_Storage_Order
+ | Attribute_Simple_Storage_Pool
+ | Attribute_Storage_Pool
+ | Attribute_Storage_Size
+ | Attribute_Storage_Unit
+ | Attribute_Stub_Type
+ | Attribute_System_Allocator_Alignment
+ | Attribute_Tag
+ | Attribute_Target_Name
+ | Attribute_Terminated
+ | Attribute_To_Address
+ | Attribute_Type_Key
+ | Attribute_Unchecked_Access
+ | Attribute_Universal_Literal_String
+ | Attribute_Unrestricted_Access
+ | Attribute_Valid
+ | Attribute_Valid_Scalars
+ | Attribute_Value
+ | Attribute_Wchar_T_Size
+ | Attribute_Wide_Value
+ | Attribute_Wide_Wide_Value
+ | Attribute_Word_Size
+ | Attribute_Write
+ =>
raise Program_Error;
end case;
@@ -9976,10 +10362,8 @@ package body Sem_Attr is
when Attribute_Access
| Attribute_Unchecked_Access
- | Attribute_Unrestricted_Access =>
-
- Access_Attribute :
- begin
+ | Attribute_Unrestricted_Access
+ =>
-- Note possible modification if we have a variable
if Is_Variable (P) then
@@ -10058,17 +10442,21 @@ package body Sem_Attr is
Get_Next_Interp (Index, It);
end loop;
- -- If Prefix is a subprogram name, this reference freezes:
+ -- If Prefix is a subprogram name, this reference freezes,
+ -- but not if within spec expression mode. The profile of
+ -- the subprogram is not frozen at this point.
- -- If it is a type, there is nothing to resolve.
- -- If it is an object, complete its resolution.
-
- elsif Is_Overloadable (Entity (P)) then
+ if not In_Spec_Expression then
+ Freeze_Before (N, Entity (P), Do_Freeze_Profile => False);
+ end if;
- -- Avoid insertion of freeze actions in spec expression mode
+ -- If it is a type, there is nothing to resolve.
+ -- If it is a subprogram, do not freeze its profile.
+ -- If it is an object, complete its resolution.
+ elsif Is_Overloadable (Entity (P)) then
if not In_Spec_Expression then
- Freeze_Before (N, Entity (P));
+ Freeze_Before (N, Entity (P), Do_Freeze_Profile => False);
end if;
-- Nothing to do if prefix is a type name
@@ -10686,9 +11074,13 @@ package body Sem_Attr is
end;
end if;
- -- Mark that address of entity is taken
+ -- Mark that address of entity is taken in case of
+ -- 'Unrestricted_Access or in case of a subprogram.
- if Is_Entity_Name (P) then
+ if Is_Entity_Name (P)
+ and then (Attr_Id = Attribute_Unrestricted_Access
+ or else Is_Subprogram (Entity (P)))
+ then
Set_Address_Taken (Entity (P));
end if;
@@ -10795,7 +11187,6 @@ package body Sem_Attr is
end if;
end;
end if;
- end Access_Attribute;
-------------
-- Address --
@@ -10804,9 +11195,9 @@ package body Sem_Attr is
-- Deal with resolving the type for Address attribute, overloading
-- is not permitted here, since there is no context to resolve it.
- when Attribute_Address | Attribute_Code_Address =>
- Address_Attribute : begin
-
+ when Attribute_Address
+ | Attribute_Code_Address
+ =>
-- To be safe, assume that if the address of a variable is taken,
-- it may be modified via this address, so note modification.
@@ -10915,7 +11306,6 @@ package body Sem_Attr is
end if;
end;
end if;
- end Address_Attribute;
------------------
-- Body_Version --
@@ -11039,81 +11429,77 @@ package body Sem_Attr is
-- specifically mentions this equivalence, we take care that the
-- prefix is only evaluated once).
- when Attribute_Range => Range_Attribute :
- declare
- LB : Node_Id;
- HB : Node_Id;
- Dims : List_Id;
+ when Attribute_Range => Range_Attribute : declare
+ Dims : List_Id;
+ HB : Node_Id;
+ LB : Node_Id;
- begin
- if not Is_Entity_Name (P)
- or else not Is_Type (Entity (P))
- then
- Resolve (P);
- end if;
+ begin
+ if not Is_Entity_Name (P) or else not Is_Type (Entity (P)) then
+ Resolve (P);
+ end if;
- Dims := Expressions (N);
+ Dims := Expressions (N);
- HB :=
- Make_Attribute_Reference (Loc,
- Prefix => Duplicate_Subexpr (P, Name_Req => True),
- Attribute_Name => Name_Last,
- Expressions => Dims);
+ HB :=
+ Make_Attribute_Reference (Loc,
+ Prefix => Duplicate_Subexpr (P, Name_Req => True),
+ Attribute_Name => Name_Last,
+ Expressions => Dims);
- LB :=
- Make_Attribute_Reference (Loc,
- Prefix => P,
- Attribute_Name => Name_First,
- Expressions => (Dims));
+ LB :=
+ Make_Attribute_Reference (Loc,
+ Prefix => P,
+ Attribute_Name => Name_First,
+ Expressions => (Dims));
- -- Do not share the dimension indicator, if present. Even
- -- though it is a static constant, its source location
- -- may be modified when printing expanded code and node
- -- sharing will lead to chaos in Sprint.
+ -- Do not share the dimension indicator, if present. Even though
+ -- it is a static constant, its source location may be modified
+ -- when printing expanded code and node sharing will lead to chaos
+ -- in Sprint.
- if Present (Dims) then
- Set_Expressions (LB,
- New_List (New_Copy_Tree (First (Dims))));
- end if;
+ if Present (Dims) then
+ Set_Expressions (LB, New_List (New_Copy_Tree (First (Dims))));
+ end if;
- -- If the original was marked as Must_Not_Freeze (see code
- -- in Sem_Ch3.Make_Index), then make sure the rewriting
- -- does not freeze either.
+ -- If the original was marked as Must_Not_Freeze (see code in
+ -- Sem_Ch3.Make_Index), then make sure the rewriting does not
+ -- freeze either.
- if Must_Not_Freeze (N) then
- Set_Must_Not_Freeze (HB);
- Set_Must_Not_Freeze (LB);
- Set_Must_Not_Freeze (Prefix (HB));
- Set_Must_Not_Freeze (Prefix (LB));
- end if;
+ if Must_Not_Freeze (N) then
+ Set_Must_Not_Freeze (HB);
+ Set_Must_Not_Freeze (LB);
+ Set_Must_Not_Freeze (Prefix (HB));
+ Set_Must_Not_Freeze (Prefix (LB));
+ end if;
- if Raises_Constraint_Error (Prefix (N)) then
+ if Raises_Constraint_Error (Prefix (N)) then
- -- Preserve Sloc of prefix in the new bounds, so that
- -- the posted warning can be removed if we are within
- -- unreachable code.
+ -- Preserve Sloc of prefix in the new bounds, so that the
+ -- posted warning can be removed if we are within unreachable
+ -- code.
- Set_Sloc (LB, Sloc (Prefix (N)));
- Set_Sloc (HB, Sloc (Prefix (N)));
- end if;
+ Set_Sloc (LB, Sloc (Prefix (N)));
+ Set_Sloc (HB, Sloc (Prefix (N)));
+ end if;
- Rewrite (N, Make_Range (Loc, LB, HB));
- Analyze_And_Resolve (N, Typ);
+ Rewrite (N, Make_Range (Loc, LB, HB));
+ Analyze_And_Resolve (N, Typ);
- -- Ensure that the expanded range does not have side effects
+ -- Ensure that the expanded range does not have side effects
- Force_Evaluation (LB);
- Force_Evaluation (HB);
+ Force_Evaluation (LB);
+ Force_Evaluation (HB);
- -- Normally after resolving attribute nodes, Eval_Attribute
- -- is called to do any possible static evaluation of the node.
- -- However, here since the Range attribute has just been
- -- transformed into a range expression it is no longer an
- -- attribute node and therefore the call needs to be avoided
- -- and is accomplished by simply returning from the procedure.
+ -- Normally after resolving attribute nodes, Eval_Attribute
+ -- is called to do any possible static evaluation of the node.
+ -- However, here since the Range attribute has just been
+ -- transformed into a range expression it is no longer an
+ -- attribute node and therefore the call needs to be avoided
+ -- and is accomplished by simply returning from the procedure.
- return;
- end Range_Attribute;
+ return;
+ end Range_Attribute;
------------
-- Result --
@@ -11144,121 +11530,120 @@ package body Sem_Attr is
-- Resolve aggregate components in component associations
- when Attribute_Update =>
- declare
- Aggr : constant Node_Id := First (Expressions (N));
- Typ : constant Entity_Id := Etype (Prefix (N));
- Assoc : Node_Id;
- Comp : Node_Id;
- Expr : Node_Id;
+ when Attribute_Update => Update : declare
+ Aggr : constant Node_Id := First (Expressions (N));
+ Typ : constant Entity_Id := Etype (Prefix (N));
+ Assoc : Node_Id;
+ Comp : Node_Id;
+ Expr : Node_Id;
- begin
- -- Set the Etype of the aggregate to that of the prefix, even
- -- though the aggregate may not be a proper representation of a
- -- value of the type (missing or duplicated associations, etc.)
- -- Complete resolution of the prefix. Note that in Ada 2012 it
- -- can be a qualified expression that is e.g. an aggregate.
-
- Set_Etype (Aggr, Typ);
- Resolve (Prefix (N), Typ);
-
- -- For an array type, resolve expressions with the component
- -- type of the array, and apply constraint checks when needed.
-
- if Is_Array_Type (Typ) then
- Assoc := First (Component_Associations (Aggr));
- while Present (Assoc) loop
- Expr := Expression (Assoc);
- Resolve (Expr, Component_Type (Typ));
-
- -- For scalar array components set Do_Range_Check when
- -- needed. Constraint checking on non-scalar components
- -- is done in Aggregate_Constraint_Checks, but only if
- -- full analysis is enabled. These flags are not set in
- -- the front-end in GnatProve mode.
-
- if Is_Scalar_Type (Component_Type (Typ))
- and then not Is_OK_Static_Expression (Expr)
+ begin
+ -- Set the Etype of the aggregate to that of the prefix, even
+ -- though the aggregate may not be a proper representation of a
+ -- value of the type (missing or duplicated associations, etc.)
+ -- Complete resolution of the prefix. Note that in Ada 2012 it
+ -- can be a qualified expression that is e.g. an aggregate.
+
+ Set_Etype (Aggr, Typ);
+ Resolve (Prefix (N), Typ);
+
+ -- For an array type, resolve expressions with the component type
+ -- of the array, and apply constraint checks when needed.
+
+ if Is_Array_Type (Typ) then
+ Assoc := First (Component_Associations (Aggr));
+ while Present (Assoc) loop
+ Expr := Expression (Assoc);
+ Resolve (Expr, Component_Type (Typ));
+
+ -- For scalar array components set Do_Range_Check when
+ -- needed. Constraint checking on non-scalar components
+ -- is done in Aggregate_Constraint_Checks, but only if
+ -- full analysis is enabled. These flags are not set in
+ -- the front-end in GnatProve mode.
+
+ if Is_Scalar_Type (Component_Type (Typ))
+ and then not Is_OK_Static_Expression (Expr)
+ then
+ if Is_Entity_Name (Expr)
+ and then Etype (Expr) = Component_Type (Typ)
then
- if Is_Entity_Name (Expr)
- and then Etype (Expr) = Component_Type (Typ)
- then
- null;
+ null;
- else
- Set_Do_Range_Check (Expr);
- end if;
+ else
+ Set_Do_Range_Check (Expr);
end if;
+ end if;
- -- The choices in the association are static constants,
- -- or static aggregates each of whose components belongs
- -- to the proper index type. However, they must also
- -- belong to the index subtype (s) of the prefix, which
- -- may be a subtype (e.g. given by a slice).
+ -- The choices in the association are static constants,
+ -- or static aggregates each of whose components belongs
+ -- to the proper index type. However, they must also
+ -- belong to the index subtype (s) of the prefix, which
+ -- may be a subtype (e.g. given by a slice).
- -- Choices may also be identifiers with no staticness
- -- requirements, in which case they must resolve to the
- -- index type.
+ -- Choices may also be identifiers with no staticness
+ -- requirements, in which case they must resolve to the
+ -- index type.
- declare
- C : Node_Id;
- C_E : Node_Id;
- Indx : Node_Id;
+ declare
+ C : Node_Id;
+ C_E : Node_Id;
+ Indx : Node_Id;
- begin
- C := First (Choices (Assoc));
- while Present (C) loop
- Indx := First_Index (Etype (Prefix (N)));
+ begin
+ C := First (Choices (Assoc));
+ while Present (C) loop
+ Indx := First_Index (Etype (Prefix (N)));
- if Nkind (C) /= N_Aggregate then
- Analyze_And_Resolve (C, Etype (Indx));
- Apply_Constraint_Check (C, Etype (Indx));
- Check_Non_Static_Context (C);
+ if Nkind (C) /= N_Aggregate then
+ Analyze_And_Resolve (C, Etype (Indx));
+ Apply_Constraint_Check (C, Etype (Indx));
+ Check_Non_Static_Context (C);
- else
- C_E := First (Expressions (C));
- while Present (C_E) loop
- Analyze_And_Resolve (C_E, Etype (Indx));
- Apply_Constraint_Check (C_E, Etype (Indx));
- Check_Non_Static_Context (C_E);
-
- Next (C_E);
- Next_Index (Indx);
- end loop;
- end if;
+ else
+ C_E := First (Expressions (C));
+ while Present (C_E) loop
+ Analyze_And_Resolve (C_E, Etype (Indx));
+ Apply_Constraint_Check (C_E, Etype (Indx));
+ Check_Non_Static_Context (C_E);
+
+ Next (C_E);
+ Next_Index (Indx);
+ end loop;
+ end if;
- Next (C);
- end loop;
- end;
+ Next (C);
+ end loop;
+ end;
- Next (Assoc);
- end loop;
+ Next (Assoc);
+ end loop;
- -- For a record type, use type of each component, which is
- -- recorded during analysis.
+ -- For a record type, use type of each component, which is
+ -- recorded during analysis.
- else
- Assoc := First (Component_Associations (Aggr));
- while Present (Assoc) loop
- Comp := First (Choices (Assoc));
- Expr := Expression (Assoc);
+ else
+ Assoc := First (Component_Associations (Aggr));
+ while Present (Assoc) loop
+ Comp := First (Choices (Assoc));
+ Expr := Expression (Assoc);
- if Nkind (Comp) /= N_Others_Choice
- and then not Error_Posted (Comp)
- then
- Resolve (Expr, Etype (Entity (Comp)));
+ if Nkind (Comp) /= N_Others_Choice
+ and then not Error_Posted (Comp)
+ then
+ Resolve (Expr, Etype (Entity (Comp)));
- if Is_Scalar_Type (Etype (Entity (Comp)))
- and then not Is_OK_Static_Expression (Expr)
- then
- Set_Do_Range_Check (Expr);
- end if;
+ if Is_Scalar_Type (Etype (Entity (Comp)))
+ and then not Is_OK_Static_Expression (Expr)
+ then
+ Set_Do_Range_Check (Expr);
end if;
+ end if;
- Next (Assoc);
- end loop;
- end if;
- end;
+ Next (Assoc);
+ end loop;
+ end if;
+ end Update;
---------
-- Val --
diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads
index a8fa47139e..38463ff6df 100644
--- a/gcc/ada/sem_attr.ads
+++ b/gcc/ada/sem_attr.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -242,6 +242,16 @@ package Sem_Attr is
-- enumeration value. Constraint_Error is raised if no value of the
-- enumeration type corresponds to the given integer value.
+ -----------------------
+ -- Finalization_Size --
+ -----------------------
+
+ Attribute_Finalization_Size => True,
+ -- For every object or non-class-wide-type, Finalization_Size returns
+ -- the size of the hidden header used for finalization purposes as if
+ -- the object or type was allocated on the heap. The size of the header
+ -- does take into account any extra padding due to alignment issues.
+
-----------------
-- Fixed_Value --
-----------------
@@ -392,7 +402,7 @@ package Sem_Attr is
-- fixed-point types and discrete types. For fixed-point types and
-- discrete types, this attribute gives the size used for default
-- allocation of objects and components of the size. See section in
- -- Einfo ("Handling of type'Size values") for further details.
+ -- Einfo ("Handling of Type'Size values") for further details.
-------------------------
-- Passed_By_Reference --
@@ -605,6 +615,44 @@ package Sem_Attr is
others => False);
+ -- The following table lists all attributes that yield a result of a
+ -- universal type.
+
+ Universal_Type_Attribute : constant array (Attribute_Id) of Boolean :=
+ (Attribute_Aft => True,
+ Attribute_Alignment => True,
+ Attribute_Component_Size => True,
+ Attribute_Count => True,
+ Attribute_Delta => True,
+ Attribute_Digits => True,
+ Attribute_Exponent => True,
+ Attribute_First_Bit => True,
+ Attribute_Fore => True,
+ Attribute_Last_Bit => True,
+ Attribute_Length => True,
+ Attribute_Machine_Emax => True,
+ Attribute_Machine_Emin => True,
+ Attribute_Machine_Mantissa => True,
+ Attribute_Machine_Radix => True,
+ Attribute_Max_Alignment_For_Allocation => True,
+ Attribute_Max_Size_In_Storage_Elements => True,
+ Attribute_Model_Emin => True,
+ Attribute_Model_Epsilon => True,
+ Attribute_Model_Mantissa => True,
+ Attribute_Model_Small => True,
+ Attribute_Modulus => True,
+ Attribute_Pos => True,
+ Attribute_Position => True,
+ Attribute_Safe_First => True,
+ Attribute_Safe_Last => True,
+ Attribute_Scale => True,
+ Attribute_Size => True,
+ Attribute_Small => True,
+ Attribute_Wide_Wide_Width => True,
+ Attribute_Wide_Width => True,
+ Attribute_Width => True,
+ others => False);
+
-----------------
-- Subprograms --
-----------------
diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb
index f704f93d5d..0ba4598155 100644
--- a/gcc/ada/sem_aux.adb
+++ b/gcc/ada/sem_aux.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -438,42 +438,24 @@ package body Sem_Aux is
function Get_Binary_Nkind (Op : Entity_Id) return Node_Kind is
begin
case Chars (Op) is
- when Name_Op_Add =>
- return N_Op_Add;
- when Name_Op_Concat =>
- return N_Op_Concat;
- when Name_Op_Expon =>
- return N_Op_Expon;
- when Name_Op_Subtract =>
- return N_Op_Subtract;
- when Name_Op_Mod =>
- return N_Op_Mod;
- when Name_Op_Multiply =>
- return N_Op_Multiply;
- when Name_Op_Divide =>
- return N_Op_Divide;
- when Name_Op_Rem =>
- return N_Op_Rem;
- when Name_Op_And =>
- return N_Op_And;
- when Name_Op_Eq =>
- return N_Op_Eq;
- when Name_Op_Ge =>
- return N_Op_Ge;
- when Name_Op_Gt =>
- return N_Op_Gt;
- when Name_Op_Le =>
- return N_Op_Le;
- when Name_Op_Lt =>
- return N_Op_Lt;
- when Name_Op_Ne =>
- return N_Op_Ne;
- when Name_Op_Or =>
- return N_Op_Or;
- when Name_Op_Xor =>
- return N_Op_Xor;
- when others =>
- raise Program_Error;
+ when Name_Op_Add => return N_Op_Add;
+ when Name_Op_Concat => return N_Op_Concat;
+ when Name_Op_Expon => return N_Op_Expon;
+ when Name_Op_Subtract => return N_Op_Subtract;
+ when Name_Op_Mod => return N_Op_Mod;
+ when Name_Op_Multiply => return N_Op_Multiply;
+ when Name_Op_Divide => return N_Op_Divide;
+ when Name_Op_Rem => return N_Op_Rem;
+ when Name_Op_And => return N_Op_And;
+ when Name_Op_Eq => return N_Op_Eq;
+ when Name_Op_Ge => return N_Op_Ge;
+ when Name_Op_Gt => return N_Op_Gt;
+ when Name_Op_Le => return N_Op_Le;
+ when Name_Op_Lt => return N_Op_Lt;
+ when Name_Op_Ne => return N_Op_Ne;
+ when Name_Op_Or => return N_Op_Or;
+ when Name_Op_Xor => return N_Op_Xor;
+ when others => raise Program_Error;
end case;
end Get_Binary_Nkind;
@@ -510,9 +492,10 @@ package body Sem_Aux is
if Nkind (N) = N_Pragma
and then
- (Pragma_Name (N) = Nam
+ (Pragma_Name_Unmapped (N) = Nam
or else (Nam = Name_Priority
- and then Pragma_Name (N) = Name_Interrupt_Priority)
+ and then Pragma_Name (N) =
+ Name_Interrupt_Priority)
or else (Nam = Name_Interrupt_Priority
and then Pragma_Name (N) = Name_Priority))
then
@@ -611,11 +594,9 @@ package body Sem_Aux is
Nam : Name_Id;
Check_Parents : Boolean := True) return Node_Id
is
- N : Node_Id;
+ N : constant Node_Id := Get_Rep_Item (E, Nam, Check_Parents);
begin
- N := Get_Rep_Item (E, Nam, Check_Parents);
-
if Present (N) and then Nkind (N) = N_Pragma then
return N;
end if;
@@ -664,16 +645,11 @@ package body Sem_Aux is
function Get_Unary_Nkind (Op : Entity_Id) return Node_Kind is
begin
case Chars (Op) is
- when Name_Op_Abs =>
- return N_Op_Abs;
- when Name_Op_Subtract =>
- return N_Op_Minus;
- when Name_Op_Not =>
- return N_Op_Not;
- when Name_Op_Add =>
- return N_Op_Plus;
- when others =>
- raise Program_Error;
+ when Name_Op_Abs => return N_Op_Abs;
+ when Name_Op_Subtract => return N_Op_Minus;
+ when Name_Op_Not => return N_Op_Not;
+ when Name_Op_Add => return N_Op_Plus;
+ when others => raise Program_Error;
end case;
end Get_Unary_Nkind;
@@ -710,6 +686,29 @@ package body Sem_Aux is
return Present (Get_Rep_Item (E, Nam1, Nam2, Check_Parents));
end Has_Rep_Item;
+ function Has_Rep_Item (E : Entity_Id; N : Node_Id) return Boolean is
+ Item : Node_Id;
+
+ begin
+ pragma Assert
+ (Nkind_In (N, N_Aspect_Specification,
+ N_Attribute_Definition_Clause,
+ N_Enumeration_Representation_Clause,
+ N_Pragma,
+ N_Record_Representation_Clause));
+
+ Item := First_Rep_Item (E);
+ while Present (Item) loop
+ if Item = N then
+ return True;
+ end if;
+
+ Item := Next_Rep_Item (Item);
+ end loop;
+
+ return False;
+ end Has_Rep_Item;
+
--------------------
-- Has_Rep_Pragma --
--------------------
@@ -912,8 +911,12 @@ package body Sem_Aux is
declare
Ftyp : constant Entity_Id := Full_View (Btype);
begin
+ -- Return true for a tagged incomplete type built as a shadow
+ -- entity in Build_Limited_Views. It can appear in the profile
+ -- of a thunk and the back end needs to know how it is passed.
+
if No (Ftyp) then
- return False;
+ return Is_Tagged_Type (Btype);
else
return Is_By_Reference_Type (Ftyp);
end if;
@@ -1381,12 +1384,10 @@ package body Sem_Aux is
-----------------------
function Number_Components (Typ : Entity_Id) return Nat is
- N : Int;
+ N : Nat := 0;
Comp : Entity_Id;
begin
- N := 0;
-
-- We do not call Einfo.First_Component_Or_Discriminant, as this
-- function does not skip completely hidden discriminants, which we
-- want to skip here.
@@ -1410,12 +1411,10 @@ package body Sem_Aux is
--------------------------
function Number_Discriminants (Typ : Entity_Id) return Pos is
- N : Int;
- Discr : Entity_Id;
+ N : Nat := 0;
+ Discr : Entity_Id := First_Discriminant (Typ);
begin
- N := 0;
- Discr := First_Discriminant (Typ);
while Present (Discr) loop
N := N + 1;
Discr := Next_Discriminant (Discr);
@@ -1521,13 +1520,10 @@ package body Sem_Aux is
----------------------------
function Subprogram_Body_Entity (E : Entity_Id) return Entity_Id is
- N : Node_Id;
+ N : constant Node_Id := Parent (Subprogram_Specification (E));
+ -- Declaration for E
begin
- -- Retrieve the declaration for E
-
- N := Parent (Subprogram_Specification (E));
-
-- If this declaration is not a subprogram body, then it must be a
-- subprogram declaration or body stub, from which we can retrieve the
-- entity for the corresponding subprogram body if any, or an abstract
@@ -1537,7 +1533,9 @@ package body Sem_Aux is
when N_Subprogram_Body =>
return E;
- when N_Subprogram_Declaration | N_Subprogram_Body_Stub =>
+ when N_Subprogram_Body_Stub
+ | N_Subprogram_Declaration
+ =>
return Corresponding_Body (N);
when others =>
@@ -1550,13 +1548,10 @@ package body Sem_Aux is
---------------------
function Subprogram_Spec (E : Entity_Id) return Node_Id is
- N : Node_Id;
+ N : constant Node_Id := Parent (Subprogram_Specification (E));
+ -- Declaration for E
begin
- -- Retrieve the declaration for E
-
- N := Parent (Subprogram_Specification (E));
-
-- This declaration is either subprogram declaration or a subprogram
-- body, in which case return Empty.
diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads
index ba60284daa..97a4f142d0 100644
--- a/gcc/ada/sem_aux.ads
+++ b/gcc/ada/sem_aux.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -246,6 +246,10 @@ package Sem_Aux is
-- not inherited from its parents, if any). If found then True is returned,
-- otherwise False indicates that no matching entry was found.
+ function Has_Rep_Item (E : Entity_Id; N : Node_Id) return Boolean;
+ -- Determine whether the Rep_Item chain of arbitrary entity E contains item
+ -- N. N must denote a valid rep item.
+
function Has_Rep_Pragma
(E : Entity_Id;
Nam : Name_Id;
diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb
index a23358afe2..3b3820e46b 100644
--- a/gcc/ada/sem_case.adb
+++ b/gcc/ada/sem_case.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -114,10 +114,12 @@ package body Sem_Case is
Others_Present : Boolean;
Case_Node : Node_Id)
is
- Predicate_Error : Boolean;
+ Predicate_Error : Boolean := False;
-- Flag to prevent cascaded errors when a static predicate is known to
-- be violated by one choice.
+ Num_Choices : constant Nat := Choice_Table'Last;
+
procedure Check_Against_Predicate
(Pred : in out Node_Id;
Choice : Choice_Bounds;
@@ -130,6 +132,10 @@ package body Sem_Case is
-- choice that covered a predicate set. Error denotes whether the check
-- found an illegal intersection.
+ procedure Check_Duplicates;
+ -- Check for duplicate choices, and call Dup_Choice if there are any
+ -- such errors. Note that predicates are irrelevant here.
+
procedure Dup_Choice (Lo, Hi : Uint; C : Node_Id);
-- Post message "duplication of choice value(s) bla bla at xx". Message
-- is posted at location C. Caller sets Error_Msg_Sloc for xx.
@@ -236,8 +242,7 @@ package body Sem_Case is
Val : Uint) return Boolean
is
begin
- return
- Val = Lo or else Val = Hi or else (Lo < Val and then Val < Hi);
+ return Lo <= Val and then Val <= Hi;
end Inside_Range;
-- Local variables
@@ -276,14 +281,12 @@ package body Sem_Case is
return;
end if;
- -- Step 1: Detect duplicate choices
-
- if Inside_Range (Choice_Lo, Choice_Hi, Prev_Lo) then
- Dup_Choice (Prev_Lo, UI_Min (Prev_Hi, Choice_Hi), LocN);
- Error := True;
+ -- Step 1: Ignore duplicate choices, other than to set the flag,
+ -- because these were already detected by Check_Duplicates.
- elsif Inside_Range (Choice_Lo, Choice_Hi, Prev_Hi) then
- Dup_Choice (UI_Max (Choice_Lo, Prev_Lo), Prev_Hi, LocN);
+ if Inside_Range (Choice_Lo, Choice_Hi, Prev_Lo)
+ or else Inside_Range (Choice_Lo, Choice_Hi, Prev_Hi)
+ then
Error := True;
-- Step 2: Detect full coverage
@@ -447,6 +450,56 @@ package body Sem_Case is
end if;
end Check_Against_Predicate;
+ ----------------------
+ -- Check_Duplicates --
+ ----------------------
+
+ procedure Check_Duplicates is
+ Choice : Node_Id;
+ Choice_Hi : Uint;
+ Choice_Lo : Uint;
+ Prev_Choice : Node_Id;
+ Prev_Hi : Uint;
+
+ begin
+ Prev_Hi := Expr_Value (Choice_Table (1).Hi);
+
+ for Outer_Index in 2 .. Num_Choices loop
+ Choice_Lo := Expr_Value (Choice_Table (Outer_Index).Lo);
+ Choice_Hi := Expr_Value (Choice_Table (Outer_Index).Hi);
+
+ -- Choices overlap; this is an error
+
+ if Choice_Lo <= Prev_Hi then
+ Choice := Choice_Table (Outer_Index).Node;
+
+ -- Find first previous choice that overlaps
+
+ for Inner_Index in 1 .. Outer_Index - 1 loop
+ if Choice_Lo <=
+ Expr_Value (Choice_Table (Inner_Index).Hi)
+ then
+ Prev_Choice := Choice_Table (Inner_Index).Node;
+ exit;
+ end if;
+ end loop;
+
+ if Sloc (Prev_Choice) <= Sloc (Choice) then
+ Error_Msg_Sloc := Sloc (Prev_Choice);
+ Dup_Choice (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Choice);
+ else
+ Error_Msg_Sloc := Sloc (Choice);
+ Dup_Choice
+ (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Prev_Choice);
+ end if;
+ end if;
+
+ if Choice_Hi > Prev_Hi then
+ Prev_Hi := Choice_Hi;
+ end if;
+ end loop;
+ end Check_Duplicates;
+
----------------
-- Dup_Choice --
----------------
@@ -575,9 +628,11 @@ package body Sem_Case is
-- Otherwise the expression is not static, even if the bounds of the
-- type are, or else there are missing alternatives. If both, the
- -- additional information may be redundant but harmless.
+ -- additional information may be redundant but harmless. Examine
+ -- whether original node is an entity, because it may have been
+ -- constant-folded to a literal if value is known.
- elsif not Is_Entity_Name (Expr) then
+ elsif not Is_Entity_Name (Original_Node (Expr)) then
Error_Msg_N
("subtype of expression is not static, "
& "alternatives must cover base type!", Expr);
@@ -709,17 +764,13 @@ package body Sem_Case is
Bounds_Hi : constant Node_Id := Type_High_Bound (Bounds_Type);
Bounds_Lo : constant Node_Id := Type_Low_Bound (Bounds_Type);
- Num_Choices : constant Nat := Choice_Table'Last;
Has_Predicate : constant Boolean :=
Is_OK_Static_Subtype (Bounds_Type)
and then Has_Static_Predicate (Bounds_Type);
- Choice : Node_Id;
Choice_Hi : Uint;
Choice_Lo : Uint;
- Error : Boolean;
Pred : Node_Id;
- Prev_Choice : Node_Id;
Prev_Lo : Uint;
Prev_Hi : Uint;
@@ -735,8 +786,6 @@ package body Sem_Case is
return;
end if;
- Predicate_Error := False;
-
-- Choice_Table must start at 0 which is an unused location used by the
-- sorting algorithm. However the first valid position for a discrete
-- choice is 1.
@@ -756,16 +805,22 @@ package body Sem_Case is
Sorting.Sort (Positive (Choice_Table'Last));
- -- The type covered by the list of choices is actually a static subtype
- -- subject to a static predicate. The predicate defines subsets of legal
- -- values and requires finer grained analysis.
+ -- First check for duplicates. This involved the choices; predicates, if
+ -- any, are irrelevant.
+
+ Check_Duplicates;
+
+ -- Then check for overlaps
+
+ -- If the subtype has a static predicate, the predicate defines subsets
+ -- of legal values and requires finer-grained analysis.
-- Note that in GNAT the predicate is considered static if the predicate
-- expression is static, independently of whether the aspect mentions
-- Static explicitly.
if Has_Predicate then
- Pred := First (Static_Discrete_Predicate (Bounds_Type));
+ Pred := First (Static_Discrete_Predicate (Bounds_Type));
-- Make initial value smaller than 'First of type, so that first
-- range comparison succeeds. This applies both to integer types
@@ -774,28 +829,30 @@ package body Sem_Case is
Prev_Lo := Expr_Value (Type_Low_Bound (Bounds_Type)) - 1;
Prev_Hi := Prev_Lo;
- Error := False;
-
- for Index in 1 .. Num_Choices loop
- Check_Against_Predicate
- (Pred => Pred,
- Choice => Choice_Table (Index),
- Prev_Lo => Prev_Lo,
- Prev_Hi => Prev_Hi,
- Error => Error);
-
- -- The analysis detected an illegal intersection between a choice
- -- and a static predicate set. Do not examine other choices unless
- -- all errors are requested.
-
- if Error then
- Predicate_Error := True;
-
- if not All_Errors_Mode then
- return;
+ declare
+ Error : Boolean := False;
+ begin
+ for Index in 1 .. Num_Choices loop
+ Check_Against_Predicate
+ (Pred => Pred,
+ Choice => Choice_Table (Index),
+ Prev_Lo => Prev_Lo,
+ Prev_Hi => Prev_Hi,
+ Error => Error);
+
+ -- The analysis detected an illegal intersection between a
+ -- choice and a static predicate set. Do not examine other
+ -- choices unless all errors are requested.
+
+ if Error then
+ Predicate_Error := True;
+
+ if not All_Errors_Mode then
+ return;
+ end if;
end if;
- end if;
- end loop;
+ end loop;
+ end;
if Predicate_Error then
return;
@@ -826,35 +883,11 @@ package body Sem_Case is
end if;
end if;
- for Outer_Index in 2 .. Num_Choices loop
- Choice_Lo := Expr_Value (Choice_Table (Outer_Index).Lo);
- Choice_Hi := Expr_Value (Choice_Table (Outer_Index).Hi);
-
- if Choice_Lo <= Prev_Hi then
- Choice := Choice_Table (Outer_Index).Node;
-
- -- Find first previous choice that overlaps
-
- for Inner_Index in 1 .. Outer_Index - 1 loop
- if Choice_Lo <=
- Expr_Value (Choice_Table (Inner_Index).Hi)
- then
- Prev_Choice := Choice_Table (Inner_Index).Node;
- exit;
- end if;
- end loop;
+ for Index in 2 .. Num_Choices loop
+ Choice_Lo := Expr_Value (Choice_Table (Index).Lo);
+ Choice_Hi := Expr_Value (Choice_Table (Index).Hi);
- if Sloc (Prev_Choice) <= Sloc (Choice) then
- Error_Msg_Sloc := Sloc (Prev_Choice);
- Dup_Choice
- (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Choice);
- else
- Error_Msg_Sloc := Sloc (Choice);
- Dup_Choice
- (Choice_Lo, UI_Min (Choice_Hi, Prev_Hi), Prev_Choice);
- end if;
-
- elsif not Others_Present and then Choice_Lo /= Prev_Hi + 1 then
+ if Choice_Lo > Prev_Hi + 1 and then not Others_Present then
Missing_Choice (Prev_Hi + 1, Choice_Lo - 1);
end if;
@@ -1126,9 +1159,10 @@ package body Sem_Case is
-----------
procedure No_OP (C : Node_Id) is
- pragma Warnings (Off, C);
begin
- null;
+ if Nkind (C) = N_Range and then Warn_On_Redundant_Constructs then
+ Error_Msg_N ("choice is an empty range?r?", C);
+ end if;
end No_OP;
-----------------------------
@@ -1330,6 +1364,15 @@ package body Sem_Case is
-- later entry into the choices table so that they can be sorted
-- later on.
+ procedure Handle_Static_Predicate
+ (Typ : Entity_Id;
+ Lo : Node_Id;
+ Hi : Node_Id);
+ -- If the type of the alternative has predicates, we must examine
+ -- each subset of the predicate rather than the bounds of the type
+ -- itself. This is relevant when the choice is a subtype mark or a
+ -- subtype indication.
+
-----------
-- Check --
-----------
@@ -1442,6 +1485,56 @@ package body Sem_Case is
Num_Choices := Num_Choices + 1;
end Check;
+ -----------------------------
+ -- Handle_Static_Predicate --
+ -----------------------------
+
+ procedure Handle_Static_Predicate
+ (Typ : Entity_Id;
+ Lo : Node_Id;
+ Hi : Node_Id)
+ is
+ P : Node_Id;
+ C : Node_Id;
+
+ begin
+ -- Loop through entries in predicate list, checking each entry.
+ -- Note that if the list is empty, corresponding to a False
+ -- predicate, then no choices are checked. If the choice comes
+ -- from a subtype indication, the given range may have bounds
+ -- that narrow the predicate choices themselves, so we must
+ -- consider only those entries within the range of the given
+ -- subtype indication..
+
+ P := First (Static_Discrete_Predicate (Typ));
+ while Present (P) loop
+
+ -- Check that part of the predicate choice is included in the
+ -- given bounds.
+
+ if Expr_Value (High_Bound (P)) >= Expr_Value (Lo)
+ and then Expr_Value (Low_Bound (P)) <= Expr_Value (Hi)
+ then
+ C := New_Copy (P);
+ Set_Sloc (C, Sloc (Choice));
+
+ if Expr_Value (Low_Bound (C)) < Expr_Value (Lo) then
+ Set_Low_Bound (C, Lo);
+ end if;
+
+ if Expr_Value (High_Bound (C)) > Expr_Value (Hi) then
+ Set_High_Bound (C, Hi);
+ end if;
+
+ Check (C, Low_Bound (C), High_Bound (C));
+ end if;
+
+ Next (P);
+ end loop;
+
+ Set_Has_SP_Choice (Alt);
+ end Handle_Static_Predicate;
+
-- Start of processing for Check_Choices
begin
@@ -1550,29 +1643,12 @@ package body Sem_Case is
& "predicate as case alternative",
Choice, E, Suggest_Static => True);
- -- Static predicate case
+ -- Static predicate case. The bounds are those of
+ -- the given subtype.
else
- declare
- P : Node_Id;
- C : Node_Id;
-
- begin
- -- Loop through entries in predicate list,
- -- checking each entry. Note that if the
- -- list is empty, corresponding to a False
- -- predicate, then no choices are checked.
-
- P := First (Static_Discrete_Predicate (E));
- while Present (P) loop
- C := New_Copy (P);
- Set_Sloc (C, Sloc (Choice));
- Check (C, Low_Bound (C), High_Bound (C));
- Next (P);
- end loop;
- end;
-
- Set_Has_SP_Choice (Alt);
+ Handle_Static_Predicate (E,
+ Type_Low_Bound (E), Type_High_Bound (E));
end if;
-- Not predicated subtype case
@@ -1626,7 +1702,15 @@ package body Sem_Case is
end if;
end if;
- Check (Choice, L, H);
+ -- Check applicable predicate values within the
+ -- bounds of the given range.
+
+ if Has_Static_Predicate (E) then
+ Handle_Static_Predicate (E, L, H);
+
+ else
+ Check (Choice, L, H);
+ end if;
end if;
end;
end if;
diff --git a/gcc/ada/sem_case.ads b/gcc/ada/sem_case.ads
index c6917f0683..9e9e82833c 100644
--- a/gcc/ada/sem_case.ads
+++ b/gcc/ada/sem_case.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1996-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -86,9 +86,10 @@ with Types; use Types;
package Sem_Case is
procedure No_OP (C : Node_Id);
- -- The no-operation routine. Does absolutely nothing. Can be used
+ -- The no-operation routine. Does mostly nothing. Can be used
-- in the following generics for the parameters Process_Empty_Choice,
- -- or Process_Associated_Node.
+ -- or Process_Associated_Node. In the case of an empty range choice,
+ -- routine emits a warning when Warn_On_Redundant_Constructs is enabled.
generic
with procedure Process_Associated_Node (A : Node_Id);
diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb
index 28742e4568..878cab0119 100644
--- a/gcc/ada/sem_cat.adb
+++ b/gcc/ada/sem_cat.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -486,7 +486,6 @@ package body Sem_Cat is
when others =>
null;
-
end case;
end if;
@@ -746,13 +745,17 @@ package body Sem_Cat is
if Nkind (PN) = N_Pragma then
case Get_Pragma_Id (PN) is
- when Pragma_All_Calls_Remote |
- Pragma_Preelaborate |
- Pragma_Pure |
- Pragma_Remote_Call_Interface |
- Pragma_Remote_Types |
- Pragma_Shared_Passive => Analyze (PN);
- when others => null;
+ when Pragma_All_Calls_Remote
+ | Pragma_Preelaborate
+ | Pragma_Pure
+ | Pragma_Remote_Call_Interface
+ | Pragma_Remote_Types
+ | Pragma_Shared_Passive
+ =>
+ Analyze (PN);
+
+ when others =>
+ null;
end case;
end if;
@@ -774,8 +777,13 @@ package body Sem_Cat is
Specification : Node_Id := Empty;
begin
- Set_Is_Pure
- (E, Is_Pure (Scop) and then Is_Library_Level_Entity (E));
+ -- Do not modify the purity of an internally generated entity if it has
+ -- been explicitly marked as pure for optimization purposes.
+
+ if not Has_Pragma_Pure_Function (E) then
+ Set_Is_Pure
+ (E, Is_Pure (Scop) and then Is_Library_Level_Entity (E));
+ end if;
if not Is_Remote_Call_Interface (E) then
if Ekind (E) in Subprogram_Kind then
@@ -1007,17 +1015,23 @@ package body Sem_Cat is
Item := First (Context_Items (P));
while Present (Item) loop
if Nkind (Item) = N_With_Clause
- and then not (Implicit_With (Item)
- or else Limited_Present (Item)
+ and then
+ not (Implicit_With (Item)
+ or else Limited_Present (Item)
- -- Skip if error already posted on the WITH
- -- clause (in which case the Name attribute
- -- may be invalid). In particular, this fixes
- -- the problem of hanging in the presence of a
- -- WITH clause on a child that is an illegal
- -- generic instantiation.
+ -- Skip if error already posted on the WITH clause (in
+ -- which case the Name attribute may be invalid). In
+ -- particular, this fixes the problem of hanging in the
+ -- presence of a WITH clause on a child that is an
+ -- illegal generic instantiation.
- or else Error_Posted (Item))
+ or else Error_Posted (Item))
+ and then
+ not (Try_Semantics
+
+ -- Skip processing malformed trees
+
+ and then Nkind (Name (Item)) not in N_Has_Entity)
then
Entity_Of_Withed := Entity (Name (Item));
Check_Categorization_Dependencies
@@ -2089,30 +2103,37 @@ package body Sem_Cat is
begin
case K is
- when N_Op | N_Membership_Test =>
- return True;
-
when N_Aggregate
| N_Component_Association
- | N_Index_Or_Discriminant_Constraint =>
+ | N_Index_Or_Discriminant_Constraint
+ | N_Membership_Test
+ | N_Op
+ =>
return True;
when N_Attribute_Reference =>
- return Attribute_Name (Parent (N)) /= Name_Address
- and then Attribute_Name (Parent (N)) /= Name_Access
- and then Attribute_Name (Parent (N)) /= Name_Unchecked_Access
- and then
- Attribute_Name (Parent (N)) /= Name_Unrestricted_Access;
+ declare
+ Attr : constant Name_Id := Attribute_Name (Parent (N));
+
+ begin
+ return Attr /= Name_Address
+ and then Attr /= Name_Access
+ and then Attr /= Name_Unchecked_Access
+ and then Attr /= Name_Unrestricted_Access;
+ end;
when N_Indexed_Component =>
- return (N /= Prefix (Parent (N))
- or else Is_Primary (Parent (N)));
+ return N /= Prefix (Parent (N)) or else Is_Primary (Parent (N));
- when N_Qualified_Expression | N_Type_Conversion =>
+ when N_Qualified_Expression
+ | N_Type_Conversion
+ =>
return Is_Primary (Parent (N));
- when N_Assignment_Statement | N_Object_Declaration =>
- return (N = Expression (Parent (N)));
+ when N_Assignment_Statement
+ | N_Object_Declaration
+ =>
+ return N = Expression (Parent (N));
when N_Selected_Component =>
return Is_Primary (Parent (N));
@@ -2156,11 +2177,14 @@ package body Sem_Cat is
-- Error if the name is a primary in an expression. The parent must not
-- be an operator, or a selected component or an indexed component that
-- is itself a primary. Entities that are actuals do not need to be
- -- checked, because the call itself will be diagnosed.
+ -- checked, because the call itself will be diagnosed. Entities in a
+ -- generic unit or within a preanalyzed expression are not checked:
+ -- only their use in executable code matters.
if Is_Primary (N)
and then (not Inside_A_Generic
or else Present (Enclosing_Generic_Body (N)))
+ and then not In_Spec_Expression
then
if Ekind (Entity (N)) = E_Variable
or else Ekind (Entity (N)) in Formal_Object_Kind
diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb
index b6116afcf4..f4268a0d90 100644
--- a/gcc/ada/sem_ch10.adb
+++ b/gcc/ada/sem_ch10.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -34,6 +34,7 @@ with Elists; use Elists;
with Fname; use Fname;
with Fname.UF; use Fname.UF;
with Freeze; use Freeze;
+with Ghost; use Ghost;
with Impunit; use Impunit;
with Inline; use Inline;
with Lib; use Lib;
@@ -84,6 +85,13 @@ package body Sem_Ch10 is
-- required in order to avoid passing non-decorated entities to the
-- back-end. Implements Ada 2005 (AI-50217).
+ procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id);
+ -- Common processing for all stubs (subprograms, tasks, packages, and
+ -- protected cases). N is the stub to be analyzed. Once the subunit name
+ -- is established, load and analyze. Nam is the non-overloadable entity
+ -- for which the proper body provides a completion. Subprogram stubs are
+ -- handled differently because they can be declarations.
+
procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id);
-- Check whether the source for the body of a compilation unit must be
-- included in a standalone library.
@@ -203,13 +211,6 @@ package body Sem_Ch10 is
procedure Unchain (E : Entity_Id);
-- Remove single entity from visibility list
- procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id);
- -- Common processing for all stubs (subprograms, tasks, packages, and
- -- protected cases). N is the stub to be analyzed. Once the subunit name
- -- is established, load and analyze. Nam is the non-overloadable entity
- -- for which the proper body provides a completion. Subprogram stubs are
- -- handled differently because they can be declarations.
-
procedure sm;
-- A dummy procedure, for debugging use, called just before analyzing the
-- main unit (after dealing with any context clauses).
@@ -269,8 +270,8 @@ package body Sem_Ch10 is
procedure Process_Body_Clauses
(Context_List : List_Id;
Clause : Node_Id;
- Used : in out Boolean;
- Used_Type_Or_Elab : in out Boolean);
+ Used : out Boolean;
+ Used_Type_Or_Elab : out Boolean);
-- Examine the context clauses of a package body, trying to match the
-- name entity of Clause with any list element. If the match occurs
-- on a use package clause set Used to True, for a use type clause or
@@ -279,8 +280,8 @@ package body Sem_Ch10 is
procedure Process_Spec_Clauses
(Context_List : List_Id;
Clause : Node_Id;
- Used : in out Boolean;
- Withed : in out Boolean;
+ Used : out Boolean;
+ Withed : out Boolean;
Exit_On_Self : Boolean := False);
-- Examine the context clauses of a package spec, trying to match
-- the name entity of Clause with any list element. If the match
@@ -298,8 +299,8 @@ package body Sem_Ch10 is
procedure Process_Body_Clauses
(Context_List : List_Id;
Clause : Node_Id;
- Used : in out Boolean;
- Used_Type_Or_Elab : in out Boolean)
+ Used : out Boolean;
+ Used_Type_Or_Elab : out Boolean)
is
Nam_Ent : constant Entity_Id := Entity (Name (Clause));
Cont_Item : Node_Id;
@@ -393,8 +394,8 @@ package body Sem_Ch10 is
elsif Nkind (Cont_Item) = N_Pragma
and then
- Nam_In (Pragma_Name (Cont_Item), Name_Elaborate,
- Name_Elaborate_All)
+ Nam_In (Pragma_Name_Unmapped (Cont_Item),
+ Name_Elaborate, Name_Elaborate_All)
and then not Used_Type_Or_Elab
then
Prag_Unit :=
@@ -419,8 +420,8 @@ package body Sem_Ch10 is
procedure Process_Spec_Clauses
(Context_List : List_Id;
Clause : Node_Id;
- Used : in out Boolean;
- Withed : in out Boolean;
+ Used : out Boolean;
+ Withed : out Boolean;
Exit_On_Self : Boolean := False)
is
Nam_Ent : constant Entity_Id := Entity (Name (Clause));
@@ -515,10 +516,10 @@ package body Sem_Ch10 is
if Present (Spec_Context_Items) then
declare
- Used_In_Body : Boolean := False;
- Used_In_Spec : Boolean := False;
- Used_Type_Or_Elab : Boolean := False;
- Withed_In_Spec : Boolean := False;
+ Used_In_Body : Boolean;
+ Used_In_Spec : Boolean;
+ Used_Type_Or_Elab : Boolean;
+ Withed_In_Spec : Boolean;
begin
Process_Spec_Clauses
@@ -557,7 +558,7 @@ package body Sem_Ch10 is
or else Used_In_Spec)
then
Error_Msg_N -- CODEFIX
- ("redundant with clause in body??", Clause);
+ ("redundant with clause in body?r?", Clause);
end if;
Used_In_Body := False;
@@ -586,7 +587,7 @@ package body Sem_Ch10 is
if Withed then
Error_Msg_N -- CODEFIX
- ("redundant with clause??", Clause);
+ ("redundant with clause?r?", Clause);
end if;
end;
end if;
@@ -612,7 +613,7 @@ package body Sem_Ch10 is
-- If the unit is a subunit whose parent has not been analyzed (which
-- indicates that the main unit is a subunit, either the current one or
- -- one of its descendents) then the subunit is compiled as part of the
+ -- one of its descendants) then the subunit is compiled as part of the
-- analysis of the parent, which we proceed to do. Basically this gets
-- handled from the top down and we don't want to do anything at this
-- level (i.e. this subunit will be handled on the way down from the
@@ -693,7 +694,7 @@ package body Sem_Ch10 is
if Nkind (Unit_Node) = N_Package_Body then
-- If no Lib_Unit, then there was a serious previous error, so just
- -- ignore the entire analysis effort
+ -- ignore the entire analysis effort.
if No (Lib_Unit) then
Check_Error_Detected;
@@ -783,15 +784,15 @@ package body Sem_Ch10 is
begin
Set_Comes_From_Source_Default (False);
- -- Checks for redundant USE TYPE clauses have a special
- -- exception for the synthetic spec we create here. This
- -- special case relies on the two compilation units
- -- sharing the same context clause.
-
- -- Note: We used to do a shallow copy (New_Copy_List),
- -- which defeated those checks and also created malformed
- -- trees (subtype mark shared by two distinct
- -- N_Use_Type_Clause nodes) which crashed the compiler.
+ -- Note: We copy the Context_Items from the explicit body
+ -- to the implicit spec, setting the former to Empty_List
+ -- to preserve the treeish nature of the tree, during
+ -- analysis of the spec. Then we put it back the way it
+ -- was -- copy the Context_Items from the spec to the
+ -- body, and set the spec Context_Items to Empty_List.
+ -- It is necessary to preserve the treeish nature,
+ -- because otherwise we will call End_Use_* twice on the
+ -- same thing.
Lib_Unit :=
Make_Compilation_Unit (Loc,
@@ -804,6 +805,7 @@ package body Sem_Ch10 is
Aux_Decls_Node =>
Make_Compilation_Unit_Aux (Loc));
+ Set_Context_Items (N, Empty_List);
Set_Library_Unit (N, Lib_Unit);
Set_Parent_Spec (Unit (Lib_Unit), Cunit (Unum));
Make_Child_Decl_Unit (N);
@@ -816,6 +818,11 @@ package body Sem_Ch10 is
Set_Is_Child_Unit (Defining_Entity (Unit_Node));
Set_Debug_Info_Needed (Defining_Entity (Unit (Lib_Unit)));
Set_Comes_From_Source_Default (SCS);
+
+ -- Restore Context_Items to the body
+
+ Set_Context_Items (N, Context_Items (Lib_Unit));
+ Set_Context_Items (Lib_Unit, Empty_List);
end;
end if;
end if;
@@ -879,7 +886,7 @@ package body Sem_Ch10 is
end if;
-- All components of the context: with-clauses, library unit, ancestors
- -- if any, (and their context) are analyzed and installed.
+ -- if any, (and their context) are analyzed and installed.
-- Call special debug routine sm if this is the main unit
@@ -1126,6 +1133,48 @@ package body Sem_Ch10 is
Style_Check := Save_Style_Check;
end;
+
+ -- In GNATprove mode, force the loading of a Interrupt_Priority when
+ -- processing compilation units with potentially "main" subprograms.
+ -- This is required for the ceiling priority protocol checks, which
+ -- are trigerred by these subprograms.
+
+ if GNATprove_Mode
+ and then Nkind_In (Unit_Node, N_Subprogram_Body,
+ N_Procedure_Instantiation,
+ N_Function_Instantiation)
+ then
+ declare
+ Spec : Node_Id;
+ Unused : Entity_Id;
+
+ begin
+ case Nkind (Unit_Node) is
+ when N_Subprogram_Body =>
+ Spec := Specification (Unit_Node);
+
+ when N_Subprogram_Instantiation =>
+ Spec :=
+ Subprogram_Specification (Entity (Name (Unit_Node)));
+
+ when others =>
+ raise Program_Error;
+ end case;
+
+ pragma Assert (Nkind (Spec) in N_Subprogram_Specification);
+
+ -- Only subprogram with no parameters can act as "main", and if
+ -- it is a function, it needs to return an integer.
+
+ if No (Parameter_Specifications (Spec))
+ and then (Nkind (Spec) = N_Procedure_Specification
+ or else
+ Is_Integer_Type (Etype (Result_Definition (Spec))))
+ then
+ Unused := RTE (RE_Interrupt_Priority);
+ end if;
+ end;
+ end if;
end if;
-- Deal with creating elaboration counter if needed. We create an
@@ -1489,7 +1538,7 @@ package body Sem_Ch10 is
-- Check if the named package (or some ancestor)
-- leaves visible the full-view of the unit given
- -- in the limited-with clause
+ -- in the limited-with clause.
loop
if Designate_Same_Unit (Lim_Unit_Name,
@@ -1584,6 +1633,7 @@ package body Sem_Ch10 is
Set_Has_Completion (Nam);
Set_Scope (Defining_Entity (N), Current_Scope);
+ Set_Ekind (Defining_Entity (N), E_Package_Body);
Set_Corresponding_Spec_Of_Stub (N, Nam);
Generate_Reference (Nam, Id, 'b');
Analyze_Proper_Body (N, Nam);
@@ -1828,9 +1878,8 @@ package body Sem_Ch10 is
-- Give message if we did not get the unit Emit warning even if
-- missing subunit is not within main unit, to simplify debugging.
- if Original_Operating_Mode = Generate_Code
- and then Unum = No_Unit
- then
+ pragma Assert (Original_Operating_Mode = Generate_Code);
+ if Unum = No_Unit then
Error_Msg_Unit_1 := Subunit_Name;
Error_Msg_File_1 :=
Get_File_Name (Subunit_Name, Subunit => True);
@@ -1926,6 +1975,7 @@ package body Sem_Ch10 is
else
Set_Scope (Defining_Entity (N), Current_Scope);
+ Set_Ekind (Defining_Entity (N), E_Protected_Body);
Set_Has_Completion (Etype (Nam));
Set_Corresponding_Spec_Of_Stub (N, Nam);
Generate_Reference (Nam, Defining_Identifier (N), 'b');
@@ -2008,7 +2058,7 @@ package body Sem_Ch10 is
Par_Unit : constant Entity_Id := Current_Scope;
Lib_Spec : Node_Id := Library_Unit (Lib_Unit);
- Num_Scopes : Int := 0;
+ Num_Scopes : Nat := 0;
Use_Clauses : array (1 .. Scope_Stack.Last) of Node_Id;
Enclosing_Child : Entity_Id := Empty;
Svg : constant Suppress_Record := Scope_Suppress;
@@ -2379,6 +2429,7 @@ package body Sem_Ch10 is
else
Set_Scope (Defining_Entity (N), Current_Scope);
+ Set_Ekind (Defining_Entity (N), E_Task_Body);
Generate_Reference (Nam, Defining_Identifier (N), 'b');
Set_Corresponding_Spec_Of_Stub (N, Nam);
@@ -2524,21 +2575,7 @@ package body Sem_Ch10 is
Set_Analyzed (N);
end if;
- -- If the library unit is a predefined unit, and we are in high
- -- integrity mode, then temporarily reset Configurable_Run_Time_Mode
- -- for the analysis of the with'ed unit. This mode does not prevent
- -- explicit with'ing of run-time units.
-
- if Configurable_Run_Time_Mode
- and then Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (U)))
- then
- Configurable_Run_Time_Mode := False;
- Semantics (Library_Unit (N));
- Configurable_Run_Time_Mode := True;
-
- else
- Semantics (Library_Unit (N));
- end if;
+ Semantics (Library_Unit (N));
Intunit := Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit));
@@ -2832,6 +2869,8 @@ package body Sem_Ch10 is
Set_Fatal_Error (Current_Sem_Unit, Error_Ignored);
end if;
end case;
+
+ Mark_Ghost_Clause (N);
end Analyze_With_Clause;
------------------------------
@@ -3670,10 +3709,11 @@ package body Sem_Ch10 is
-- Protect the frontend against previous critical errors
case Nkind (Unit (Library_Unit (W))) is
- when N_Subprogram_Declaration |
- N_Package_Declaration |
- N_Generic_Subprogram_Declaration |
- N_Generic_Package_Declaration =>
+ when N_Generic_Package_Declaration
+ | N_Generic_Subprogram_Declaration
+ | N_Package_Declaration
+ | N_Subprogram_Declaration
+ =>
null;
when others =>
@@ -4207,13 +4247,18 @@ package body Sem_Ch10 is
-- Do not install private_with_clauses declaration, unless unit
-- is itself a private child unit, or is a body. Note that for a
- -- subprogram body the private_with_clause does not take effect until
- -- after the specification.
+ -- subprogram body the private_with_clause does not take effect
+ -- until after the specification.
if Nkind (Item) /= N_With_Clause
or else Implicit_With (Item)
or else Limited_Present (Item)
or else Error_Posted (Item)
+
+ -- Skip processing malformed trees
+
+ or else (Try_Semantics
+ and then Nkind (Name (Item)) not in N_Has_Entity)
then
null;
@@ -5613,12 +5658,10 @@ package body Sem_Ch10 is
procedure Decorate_State (Ent : Entity_Id; Scop : Entity_Id) is
begin
- Set_Ekind (Ent, E_Abstract_State);
- Set_Etype (Ent, Standard_Void_Type);
- Set_Scope (Ent, Scop);
- Set_Encapsulating_State (Ent, Empty);
- Set_Refinement_Constituents (Ent, New_Elmt_List);
- Set_Part_Of_Constituents (Ent, New_Elmt_List);
+ Set_Ekind (Ent, E_Abstract_State);
+ Set_Etype (Ent, Standard_Void_Type);
+ Set_Scope (Ent, Scop);
+ Set_Encapsulating_State (Ent, Empty);
end Decorate_State;
-------------------
@@ -5635,15 +5678,19 @@ package body Sem_Ch10 is
begin
-- An unanalyzed type or a shadow entity of a type is treated as an
- -- incomplete type.
-
- Set_Ekind (Ent, E_Incomplete_Type);
- Set_Etype (Ent, Ent);
- Set_Scope (Ent, Scop);
- Set_Is_First_Subtype (Ent);
- Set_Stored_Constraint (Ent, No_Elist);
- Set_Full_View (Ent, Empty);
- Init_Size_Align (Ent);
+ -- incomplete type, and carries the corresponding attributes.
+
+ Set_Ekind (Ent, E_Incomplete_Type);
+ Set_Etype (Ent, Ent);
+ Set_Full_View (Ent, Empty);
+ Set_Is_First_Subtype (Ent);
+ Set_Scope (Ent, Scop);
+ Set_Stored_Constraint (Ent, No_Elist);
+ Init_Size_Align (Ent);
+
+ if From_Limited_With (Ent) then
+ Set_Private_Dependents (Ent, New_Elmt_List);
+ end if;
-- A tagged type and its corresponding shadow entity share one common
-- class-wide type. The list of primitive operations for the shadow
@@ -5670,16 +5717,16 @@ package body Sem_Ch10 is
Set_Parent (CW_Typ, Parent (Ent));
Set_Ekind (CW_Typ, E_Class_Wide_Type);
- Set_Etype (CW_Typ, Ent);
- Set_Scope (CW_Typ, Scop);
- Set_Is_Tagged_Type (CW_Typ);
- Set_Is_First_Subtype (CW_Typ);
- Init_Size_Align (CW_Typ);
- Set_Has_Unknown_Discriminants (CW_Typ);
Set_Class_Wide_Type (CW_Typ, CW_Typ);
+ Set_Etype (CW_Typ, Ent);
Set_Equivalent_Type (CW_Typ, Empty);
Set_From_Limited_With (CW_Typ, From_Limited_With (Ent));
+ Set_Has_Unknown_Discriminants (CW_Typ);
+ Set_Is_First_Subtype (CW_Typ);
+ Set_Is_Tagged_Type (CW_Typ);
Set_Materialize_Entity (CW_Typ, Materialize);
+ Set_Scope (CW_Typ, Scop);
+ Init_Size_Align (CW_Typ);
end if;
end Decorate_Type;
@@ -6007,8 +6054,9 @@ package body Sem_Ch10 is
Error_Msg_N ("subprograms not allowed in limited with_clauses", N);
return;
- when N_Generic_Package_Declaration |
- N_Generic_Subprogram_Declaration =>
+ when N_Generic_Package_Declaration
+ | N_Generic_Subprogram_Declaration
+ =>
Error_Msg_N ("generics not allowed in limited with_clauses", N);
return;
@@ -6118,6 +6166,14 @@ package body Sem_Ch10 is
if Nkind (CI) = N_With_Clause
and then not
No_Elab_Code_All (Get_Source_Unit (Library_Unit (CI)))
+
+ -- In GNATprove mode, some runtime units are implicitly
+ -- loaded to make their entities available for analysis. In
+ -- this case, ignore violations of No_Elaboration_Code_All
+ -- for this special analysis mode.
+
+ and then not
+ (GNATprove_Mode and then Implicit_With (CI))
then
Error_Msg_Sloc := Sloc (No_Elab_Code_All_Pragma);
Error_Msg_N
@@ -6138,15 +6194,14 @@ package body Sem_Ch10 is
-------------------------------
procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id) is
-
function Entity_Needs_Body (E : Entity_Id) return Boolean;
-- Determine whether use of entity E might require the presence of its
-- body. For a package this requires a recursive traversal of all nested
-- declarations.
- ---------------------------
- -- Entity_Needed_For_SAL --
- ---------------------------
+ -----------------------
+ -- Entity_Needs_Body --
+ -----------------------
function Entity_Needs_Body (E : Entity_Id) return Boolean is
Ent : Entity_Id;
@@ -6156,7 +6211,18 @@ package body Sem_Ch10 is
return True;
elsif Ekind_In (E, E_Generic_Function, E_Generic_Procedure) then
- return True;
+
+ -- A generic subprogram always requires the presence of its
+ -- body because an instantiation needs both templates. The only
+ -- exceptions is a generic subprogram renaming. In this case the
+ -- body is needed only when the template is declared outside the
+ -- compilation unit being checked.
+
+ if Present (Renamed_Entity (E)) then
+ return not Within_Scope (E, Unit_Name);
+ else
+ return True;
+ end if;
elsif Ekind (E) = E_Generic_Package
and then
@@ -6370,6 +6436,13 @@ package body Sem_Ch10 is
-- Limited_Withed_Unit.
else
+ -- If the limited_with_clause is in some other unit in the context
+ -- then it is not visible in the main unit.
+
+ if not In_Extended_Main_Source_Unit (N) then
+ Set_Is_Immediately_Visible (P, False);
+ end if;
+
-- Real entities that are type or subtype declarations were hidden
-- from visibility at the point of installation of the limited-view.
-- Now we recover the previous value of the hidden attribute.
diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb
index 0b9f8ef829..3e71b543c9 100644
--- a/gcc/ada/sem_ch11.adb
+++ b/gcc/ada/sem_ch11.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -27,7 +27,6 @@ with Atree; use Atree;
with Checks; use Checks;
with Einfo; use Einfo;
with Errout; use Errout;
-with Ghost; use Ghost;
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
with Namet; use Namet;
@@ -67,13 +66,6 @@ package body Sem_Ch11 is
Set_Is_Statically_Allocated (Id);
Set_Is_Pure (Id, PF);
- -- An exception declared within a Ghost region is automatically Ghost
- -- (SPARK RM 6.9(2)).
-
- if Ghost_Mode > None then
- Set_Is_Ghost_Entity (Id);
- end if;
-
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, Id);
end if;
@@ -214,6 +206,7 @@ package body Sem_Ch11 is
H_Scope :=
New_Internal_Entity
(E_Block, Current_Scope, Sloc (Choice), 'E');
+ Set_Is_Exception_Handler (H_Scope);
end if;
Push_Scope (H_Scope);
@@ -318,11 +311,11 @@ package body Sem_Ch11 is
N_Formal_Package_Declaration
then
Error_Msg_NE
- ("exception& is declared in " &
- "generic formal package", Id, Ent);
+ ("exception& is declared in generic formal "
+ & "package", Id, Ent);
Error_Msg_N
- ("\and therefore cannot appear in " &
- "handler (RM 11.2(8))", Id);
+ ("\and therefore cannot appear in handler "
+ & "(RM 11.2(8))", Id);
exit;
-- If the exception is declared in an inner
@@ -362,8 +355,8 @@ package body Sem_Ch11 is
Analyze_Statements (Statements (Handler));
- -- If a choice was present, we created a special scope for it,
- -- so this is where we pop that special scope to get rid of it.
+ -- If a choice was present, we created a special scope for it, so
+ -- this is where we pop that special scope to get rid of it.
if Present (Choice) then
End_Scope;
@@ -416,14 +409,15 @@ package body Sem_Ch11 is
Analyze_Statements (Statements (N));
- -- If the current scope is a subprogram, then this is the right place to
- -- check for hanging useless assignments from the statement sequence of
- -- the subprogram body. Skip this in the body of a postcondition,
- -- since in that case there are no source references, and we need to
- -- preserve deferred references from the enclosing scope.
+ -- If the current scope is a subprogram, entry or task body or declare
+ -- block then this is the right place to check for hanging useless
+ -- assignments from the statement sequence. Skip this in the body of a
+ -- postcondition, since in that case there are no source references, and
+ -- we need to preserve deferred references from the enclosing scope.
- if Is_Subprogram (Current_Scope)
- and then Chars (Current_Scope) /= Name_uPostconditions
+ if ((Is_Subprogram (Current_Scope) or else Is_Entry (Current_Scope))
+ and then Chars (Current_Scope) /= Name_uPostconditions)
+ or else Ekind_In (Current_Scope, E_Block, E_Task_Type)
then
Warn_On_Useless_Assignments (Current_Scope);
end if;
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index 8fdd700659..c43533603b 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -513,7 +513,7 @@ package body Sem_Ch12 is
-- If the generic is a local entity and the corresponding body has not
-- been seen yet, flag enclosing packages to indicate that it will be
-- elaborated after the generic body. Subprograms declared in the same
- -- package cannot be inlined by the front-end because front-end inlining
+ -- package cannot be inlined by the front end because front-end inlining
-- requires a strict linear order of elaboration.
function Check_Hidden_Primitives (Assoc_List : List_Id) return Elist_Id;
@@ -713,7 +713,10 @@ package body Sem_Ch12 is
-- body. Early instantiations can also appear if generic, instance and
-- body are all in the declarative part of a subprogram or entry. Entities
-- of packages that are early instantiations are delayed, and their freeze
- -- node appears after the generic body.
+ -- node appears after the generic body. This rather complex machinery is
+ -- needed when nested instantiations are present, because the source does
+ -- not carry any indication of where the corresponding instance bodies must
+ -- be installed and frozen.
procedure Install_Formal_Packages (Par : Entity_Id);
-- Install the visible part of any formal of the parent that is a formal
@@ -1027,6 +1030,40 @@ package body Sem_Ch12 is
raise Instantiation_Error;
end Abandon_Instantiation;
+ --------------------------------
+ -- Add_Pending_Instantiation --
+ --------------------------------
+
+ procedure Add_Pending_Instantiation (Inst : Node_Id; Act_Decl : Node_Id) is
+ begin
+
+ -- Add to the instantiation node and the corresponding unit declaration
+ -- the current values of global flags to be used when analyzing the
+ -- instance body.
+
+ Pending_Instantiations.Append
+ ((Inst_Node => Inst,
+ Act_Decl => Act_Decl,
+ Expander_Status => Expander_Active,
+ Current_Sem_Unit => Current_Sem_Unit,
+ Scope_Suppress => Scope_Suppress,
+ Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
+ Version => Ada_Version,
+ Version_Pragma => Ada_Version_Pragma,
+ Warnings => Save_Warnings,
+ SPARK_Mode => SPARK_Mode,
+ SPARK_Mode_Pragma => SPARK_Mode_Pragma));
+ end Add_Pending_Instantiation;
+
+ ----------------------------------
+ -- Adjust_Inherited_Pragma_Sloc --
+ ----------------------------------
+
+ procedure Adjust_Inherited_Pragma_Sloc (N : Node_Id) is
+ begin
+ Adjust_Instantiation_Sloc (N, S_Adjustment);
+ end Adjust_Inherited_Pragma_Sloc;
+
--------------------------
-- Analyze_Associations --
--------------------------
@@ -1063,14 +1100,20 @@ package body Sem_Ch12 is
-- name of the formal.
Is_Named_Assoc : Boolean;
- Num_Matched : Int := 0;
- Num_Actuals : Int := 0;
+ Num_Matched : Nat := 0;
+ Num_Actuals : Nat := 0;
Others_Present : Boolean := False;
Others_Choice : Node_Id := Empty;
-- In Ada 2005, indicates partial parameterization of a formal
-- package. As usual an other association must be last in the list.
+ procedure Check_Fixed_Point_Actual (Actual : Node_Id);
+ -- Warn if an actual fixed-point type has user-defined arithmetic
+ -- operations, but there is no corresponding formal in the generic,
+ -- in which case the predefined operations will be used. This merits
+ -- a warning because of the special semantics of fixed point ops.
+
procedure Check_Overloaded_Formal_Subprogram (Formal : Entity_Id);
-- Apply RM 12.3(9): if a formal subprogram is overloaded, the instance
-- cannot have a named association for it. AI05-0025 extends this rule
@@ -1087,7 +1130,7 @@ package body Sem_Ch12 is
-- Find actual that corresponds to a given a formal parameter. If the
-- actuals are positional, return the next one, if any. If the actuals
-- are named, scan the parameter associations to find the right one.
- -- A_F is the corresponding entity in the analyzed generic,which is
+ -- A_F is the corresponding entity in the analyzed generic, which is
-- placed on the selector name for ASIS use.
--
-- In Ada 2005, a named association may be given with a box, in which
@@ -1153,6 +1196,52 @@ package body Sem_Ch12 is
end Check_Overloaded_Formal_Subprogram;
-------------------------------
+ -- Check_Fixed_Point_Actual --
+ -------------------------------
+
+ procedure Check_Fixed_Point_Actual (Actual : Node_Id) is
+ Typ : constant Entity_Id := Entity (Actual);
+ Prims : constant Elist_Id := Collect_Primitive_Operations (Typ);
+ Elem : Elmt_Id;
+ Formal : Node_Id;
+
+ begin
+ -- Locate primitive operations of the type that are arithmetic
+ -- operations.
+
+ Elem := First_Elmt (Prims);
+ while Present (Elem) loop
+ if Nkind (Node (Elem)) = N_Defining_Operator_Symbol then
+
+ -- Check whether the generic unit has a formal subprogram of
+ -- the same name. This does not check types but is good enough
+ -- to justify a warning.
+
+ Formal := First_Non_Pragma (Formals);
+ while Present (Formal) loop
+ if Nkind (Formal) = N_Formal_Concrete_Subprogram_Declaration
+ and then Chars (Defining_Entity (Formal)) =
+ Chars (Node (Elem))
+ then
+ exit;
+ end if;
+
+ Next (Formal);
+ end loop;
+
+ if No (Formal) then
+ Error_Msg_Sloc := Sloc (Node (Elem));
+ Error_Msg_NE
+ ("?instance does not use primitive operation&#",
+ Actual, Node (Elem));
+ end if;
+ end if;
+
+ Next_Elmt (Elem);
+ end loop;
+ end Check_Fixed_Point_Actual;
+
+ -------------------------------
-- Has_Fully_Defined_Profile --
-------------------------------
@@ -1232,7 +1321,7 @@ package body Sem_Ch12 is
elsif No (Selector_Name (Actual)) then
Found_Assoc := Actual;
- Act := Explicit_Generic_Actual_Parameter (Actual);
+ Act := Explicit_Generic_Actual_Parameter (Actual);
Num_Matched := Num_Matched + 1;
Next (Actual);
@@ -1246,12 +1335,17 @@ package body Sem_Ch12 is
Prev := Empty;
while Present (Actual) loop
- if Chars (Selector_Name (Actual)) = Chars (F) then
+ if Nkind (Actual) = N_Others_Choice then
+ Found_Assoc := Empty;
+ Act := Empty;
+
+ elsif Chars (Selector_Name (Actual)) = Chars (F) then
Set_Entity (Selector_Name (Actual), A_F);
Set_Etype (Selector_Name (Actual), Etype (A_F));
Generate_Reference (A_F, Selector_Name (Actual));
+
Found_Assoc := Actual;
- Act := Explicit_Generic_Actual_Parameter (Actual);
+ Act := Explicit_Generic_Actual_Parameter (Actual);
Num_Matched := Num_Matched + 1;
exit;
end if;
@@ -1299,7 +1393,7 @@ package body Sem_Ch12 is
-- Process_Default --
---------------------
- procedure Process_Default (F : Entity_Id) is
+ procedure Process_Default (F : Entity_Id) is
Loc : constant Source_Ptr := Sloc (I_Node);
F_Id : constant Entity_Id := Defining_Entity (F);
Decl : Node_Id;
@@ -1365,7 +1459,6 @@ package body Sem_Ch12 is
Kind := Nkind (Analyzed_Formal);
case Nkind (Formal) is
-
when N_Formal_Subprogram_Declaration =>
exit when Kind in N_Formal_Subprogram_Declaration
and then
@@ -1379,7 +1472,10 @@ package body Sem_Ch12 is
N_Generic_Package_Declaration,
N_Package_Declaration);
- when N_Use_Package_Clause | N_Use_Type_Clause => exit;
+ when N_Use_Package_Clause
+ | N_Use_Type_Clause
+ =>
+ exit;
when others =>
@@ -1471,10 +1567,12 @@ package body Sem_Ch12 is
-- A named association may lack an actual parameter, if it was
-- introduced for a default subprogram that turns out to be local
- -- to the outer instantiation.
+ -- to the outer instantiation. If it has a box association it must
+ -- correspond to some formal in the generic.
if Nkind (Named) /= N_Others_Choice
- and then Present (Explicit_Generic_Actual_Parameter (Named))
+ and then (Present (Explicit_Generic_Actual_Parameter (Named))
+ or else Box_Present (Named))
then
Num_Actuals := Num_Actuals + 1;
end if;
@@ -1572,6 +1670,10 @@ package body Sem_Ch12 is
(Formal, Match, Analyzed_Formal, Assoc),
Assoc);
+ if Is_Fixed_Point_Type (Entity (Match)) then
+ Check_Fixed_Point_Actual (Match);
+ end if;
+
-- An instantiation is a freeze point for the actuals,
-- unless this is a rewritten formal package, or the
-- formal is an Ada 2012 formal incomplete type.
@@ -1755,8 +1857,9 @@ package body Sem_Ch12 is
-- they belong (we mustn't recopy them since this would mess up
-- the Sloc values).
- when N_Use_Package_Clause |
- N_Use_Type_Clause =>
+ when N_Use_Package_Clause
+ | N_Use_Type_Clause
+ =>
if Nkind (Original_Node (I_Node)) =
N_Formal_Package_Declaration
then
@@ -1768,7 +1871,6 @@ package body Sem_Ch12 is
when others =>
raise Program_Error;
-
end case;
Formal := Saved_Formal;
@@ -2556,13 +2658,13 @@ package body Sem_Ch12 is
-- continue analysis to minimize cascaded errors.
Error_Msg_N
- ("generic parent cannot be used as formal package "
- & "of a child unit", Gen_Id);
+ ("generic parent cannot be used as formal package of a child "
+ & "unit", Gen_Id);
else
Error_Msg_N
- ("generic package cannot be used as a formal package "
- & "within itself", Gen_Id);
+ ("generic package cannot be used as a formal package within "
+ & "itself", Gen_Id);
Restore_Env;
goto Leave;
end if;
@@ -2609,7 +2711,7 @@ package body Sem_Ch12 is
end if;
Formal := New_Copy (Pack_Id);
- Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
+ Create_Instantiation_Source (N, Gen_Unit, S_Adjustment);
-- Make local generic without formals. The formals will be replaced with
-- internal declarations.
@@ -3035,56 +3137,56 @@ package body Sem_Ch12 is
-- Enter the new name, and branch to specific routine
case Nkind (Def) is
- when N_Formal_Private_Type_Definition =>
+ when N_Formal_Private_Type_Definition =>
Analyze_Formal_Private_Type (N, T, Def);
- when N_Formal_Derived_Type_Definition =>
+ when N_Formal_Derived_Type_Definition =>
Analyze_Formal_Derived_Type (N, T, Def);
- when N_Formal_Incomplete_Type_Definition =>
+ when N_Formal_Incomplete_Type_Definition =>
Analyze_Formal_Incomplete_Type (T, Def);
- when N_Formal_Discrete_Type_Definition =>
+ when N_Formal_Discrete_Type_Definition =>
Analyze_Formal_Discrete_Type (T, Def);
- when N_Formal_Signed_Integer_Type_Definition =>
+ when N_Formal_Signed_Integer_Type_Definition =>
Analyze_Formal_Signed_Integer_Type (T, Def);
- when N_Formal_Modular_Type_Definition =>
+ when N_Formal_Modular_Type_Definition =>
Analyze_Formal_Modular_Type (T, Def);
- when N_Formal_Floating_Point_Definition =>
+ when N_Formal_Floating_Point_Definition =>
Analyze_Formal_Floating_Type (T, Def);
when N_Formal_Ordinary_Fixed_Point_Definition =>
Analyze_Formal_Ordinary_Fixed_Point_Type (T, Def);
- when N_Formal_Decimal_Fixed_Point_Definition =>
+ when N_Formal_Decimal_Fixed_Point_Definition =>
Analyze_Formal_Decimal_Fixed_Point_Type (T, Def);
when N_Array_Type_Definition =>
Analyze_Formal_Array_Type (T, Def);
- when N_Access_To_Object_Definition |
- N_Access_Function_Definition |
- N_Access_Procedure_Definition =>
+ when N_Access_Function_Definition
+ | N_Access_Procedure_Definition
+ | N_Access_To_Object_Definition
+ =>
Analyze_Generic_Access_Type (T, Def);
-- Ada 2005: a interface declaration is encoded as an abstract
-- record declaration or a abstract type derivation.
- when N_Record_Definition =>
+ when N_Record_Definition =>
Analyze_Formal_Interface_Type (N, T, Def);
- when N_Derived_Type_Definition =>
+ when N_Derived_Type_Definition =>
Analyze_Formal_Derived_Interface_Type (N, T, Def);
- when N_Error =>
+ when N_Error =>
null;
- when others =>
+ when others =>
raise Program_Error;
-
end case;
Set_Is_Generic_Type (T);
@@ -3231,13 +3333,6 @@ package body Sem_Ch12 is
Set_Ekind (Id, E_Generic_Package);
Set_Etype (Id, Standard_Void_Type);
- -- A generic package declared within a Ghost region is rendered Ghost
- -- (SPARK RM 6.9(2)).
-
- if Ghost_Mode > None then
- Set_Is_Ghost_Entity (Id);
- end if;
-
-- Analyze aspects now, so that generated pragmas appear in the
-- declarations before building and analyzing the generic copy.
@@ -3448,13 +3543,6 @@ package body Sem_Ch12 is
Set_Etype (Id, Standard_Void_Type);
end if;
- -- A generic subprogram declared within a Ghost region is rendered Ghost
- -- (SPARK RM 6.9(2)).
-
- if Ghost_Mode > None then
- Set_Is_Ghost_Entity (Id);
- end if;
-
-- For a library unit, we have reconstructed the entity for the unit,
-- and must reset it in the library tables. We also make sure that
-- Body_Required is set properly in the original compilation unit node.
@@ -3487,6 +3575,10 @@ package body Sem_Ch12 is
-- Analyze_Package_Instantiation --
-----------------------------------
+ -- WARNING: This routine manages Ghost regions. Return statements must be
+ -- replaced by gotos which jump to the end of the routine and restore the
+ -- Ghost mode.
+
procedure Analyze_Package_Instantiation (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Gen_Id : constant Node_Id := Name (N);
@@ -3576,6 +3668,9 @@ package body Sem_Ch12 is
-- Local declarations
+ Mode : Ghost_Mode_Type;
+ Mode_Set : Boolean := False;
+
Vis_Prims_List : Elist_Id := No_Elist;
-- List of primitives made temporarily visible in the instantiation
-- to match the visibility of the formal type
@@ -3594,12 +3689,6 @@ package body Sem_Ch12 is
Instantiation_Node := N;
- -- Turn off style checking in instances. If the check is enabled on the
- -- generic unit, a warning in an instance would just be noise. If not
- -- enabled on the generic, then a warning in an instance is just wrong.
-
- Style_Check := False;
-
-- Case of instantiation of a generic package
if Nkind (N) = N_Package_Instantiation then
@@ -3632,6 +3721,12 @@ package body Sem_Ch12 is
Preanalyze_Actuals (N, Act_Decl_Id);
+ -- Turn off style checking in instances. If the check is enabled on the
+ -- generic unit, a warning in an instance would just be noise. If not
+ -- enabled on the generic, then a warning in an instance is just wrong.
+
+ Style_Check := False;
+
Init_Env;
Env_Installed := True;
@@ -3646,6 +3741,14 @@ package body Sem_Ch12 is
Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
Gen_Unit := Entity (Gen_Id);
+ -- A package instantiation is Ghost when it is subject to pragma Ghost
+ -- or the generic template is Ghost. Set the mode now to ensure that
+ -- any nodes generated during analysis and expansion are marked as
+ -- Ghost.
+
+ Mark_And_Set_Ghost_Instantiation (N, Gen_Unit, Mode);
+ Mode_Set := True;
+
-- Verify that it is the name of a generic package
-- A visibility glitch: if the instance is a child unit and the generic
@@ -3754,7 +3857,7 @@ package body Sem_Ch12 is
-- validate an actual package, the instantiation environment is that
-- of the enclosing instance.
- Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
+ Create_Instantiation_Source (N, Gen_Unit, S_Adjustment);
-- Copy original generic tree, to produce text for instantiation
@@ -4138,18 +4241,7 @@ package body Sem_Ch12 is
-- Make entry in table
- Pending_Instantiations.Append
- ((Inst_Node => N,
- Act_Decl => Act_Decl,
- Expander_Status => Expander_Active,
- Current_Sem_Unit => Current_Sem_Unit,
- Scope_Suppress => Scope_Suppress,
- Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
- Version => Ada_Version,
- Version_Pragma => Ada_Version_Pragma,
- Warnings => Save_Warnings,
- SPARK_Mode => SPARK_Mode,
- SPARK_Mode_Pragma => SPARK_Mode_Pragma));
+ Add_Pending_Instantiation (N, Act_Decl);
end if;
end if;
@@ -4326,10 +4418,6 @@ package body Sem_Ch12 is
SPARK_Mode_Pragma := Save_SMP;
Style_Check := Save_Style_Check;
- if SPARK_Mode = On then
- Dynamic_Elaboration_Checks := False;
- end if;
-
-- Check that if N is an instantiation of System.Dim_Float_IO or
-- System.Dim_Integer_IO, the formal type has a dimension system.
@@ -4352,6 +4440,10 @@ package body Sem_Ch12 is
Analyze_Aspect_Specifications (N, Act_Decl_Id);
end if;
+ if Mode_Set then
+ Restore_Ghost_Mode (Mode);
+ end if;
+
exception
when Instantiation_Error =>
if Parent_Installed then
@@ -4367,8 +4459,8 @@ package body Sem_Ch12 is
SPARK_Mode_Pragma := Save_SMP;
Style_Check := Save_Style_Check;
- if SPARK_Mode = On then
- Dynamic_Elaboration_Checks := False;
+ if Mode_Set then
+ Restore_Ghost_Mode (Mode);
end if;
end Analyze_Package_Instantiation;
@@ -4392,7 +4484,7 @@ package body Sem_Ch12 is
-- to provide a clean environment for analysis of the inlined body will
-- eliminate any previously set SPARK_Mode.
- Scope_Stack_Depth : constant Int :=
+ Scope_Stack_Depth : constant Pos :=
Scope_Stack.Last - Scope_Stack.First + 1;
Use_Clauses : array (1 .. Scope_Stack_Depth) of Node_Id;
@@ -4400,9 +4492,9 @@ package body Sem_Ch12 is
Inner_Scopes : array (1 .. Scope_Stack_Depth) of Entity_Id;
Curr_Scope : Entity_Id := Empty;
List : Elist_Id;
- Num_Inner : Int := 0;
- Num_Scopes : Int := 0;
- N_Instances : Int := 0;
+ Num_Inner : Nat := 0;
+ Num_Scopes : Nat := 0;
+ N_Instances : Nat := 0;
Removed : Boolean := False;
S : Entity_Id;
Vis : Boolean;
@@ -4745,18 +4837,7 @@ package body Sem_Ch12 is
and then not Is_Eliminated (Subp)
then
- Pending_Instantiations.Append
- ((Inst_Node => N,
- Act_Decl => Unit_Declaration_Node (Subp),
- Expander_Status => Expander_Active,
- Current_Sem_Unit => Current_Sem_Unit,
- Scope_Suppress => Scope_Suppress,
- Local_Suppress_Stack_Top => Local_Suppress_Stack_Top,
- Version => Ada_Version,
- Version_Pragma => Ada_Version_Pragma,
- Warnings => Save_Warnings,
- SPARK_Mode => SPARK_Mode,
- SPARK_Mode_Pragma => SPARK_Mode_Pragma));
+ Add_Pending_Instantiation (N, Unit_Declaration_Node (Subp));
return True;
-- Here if not inlined, or we ignore the inlining
@@ -4770,6 +4851,10 @@ package body Sem_Ch12 is
-- Analyze_Subprogram_Instantiation --
--------------------------------------
+ -- WARNING: This routine manages Ghost regions. Return statements must be
+ -- replaced by gotos which jump to the end of the routine and restore the
+ -- Ghost mode.
+
procedure Analyze_Subprogram_Instantiation
(N : Node_Id;
K : Entity_Kind)
@@ -4920,14 +5005,6 @@ package body Sem_Ch12 is
Set_Comes_From_Source (Act_Decl_Id, Comes_From_Source (Gen_Unit));
- -- The signature may involve types that are not frozen yet, but the
- -- subprogram will be frozen at the point the wrapper package is
- -- frozen, so it does not need its own freeze node. In fact, if one
- -- is created, it might conflict with the freezing actions from the
- -- wrapper package.
-
- Set_Has_Delayed_Freeze (Anon_Id, False);
-
-- If the instance is a child unit, mark the Id accordingly. Mark
-- the anonymous entity as well, which is the real subprogram and
-- which is used when the instance appears in a context clause.
@@ -4952,9 +5029,13 @@ package body Sem_Ch12 is
Set_Cunit_Entity (Current_Sem_Unit, Pack_Id);
end if;
- -- The instance is not a freezing point for the new subprogram
+ -- The instance is not a freezing point for the new subprogram.
+ -- The anonymous subprogram may have a freeze node, created for
+ -- some delayed aspects. This freeze node must not be inherited
+ -- by the visible subprogram entity.
- Set_Is_Frozen (Act_Decl_Id, False);
+ Set_Is_Frozen (Act_Decl_Id, False);
+ Set_Freeze_Node (Act_Decl_Id, Empty);
if Nkind (Defining_Entity (N)) = N_Defining_Operator_Symbol then
Valid_Operator_Definition (Act_Decl_Id);
@@ -5025,6 +5106,9 @@ package body Sem_Ch12 is
Save_SMP : constant Node_Id := SPARK_Mode_Pragma;
-- Save the SPARK_Mode-related data for restore on exit
+ Mode : Ghost_Mode_Type;
+ Mode_Set : Boolean := False;
+
Vis_Prims_List : Elist_Id := No_Elist;
-- List of primitives made temporarily visible in the instantiation
-- to match the visibility of the formal type
@@ -5060,6 +5144,14 @@ package body Sem_Ch12 is
Check_Generic_Child_Unit (Gen_Id, Parent_Installed);
Gen_Unit := Entity (Gen_Id);
+ -- A subprogram instantiation is Ghost when it is subject to pragma
+ -- Ghost or the generic template is Ghost. Set the mode now to ensure
+ -- that any nodes generated during analysis and expansion are marked as
+ -- Ghost.
+
+ Mark_And_Set_Ghost_Instantiation (N, Gen_Unit, Mode);
+ Mode_Set := True;
+
Generate_Reference (Gen_Unit, Gen_Id);
if Nkind (Gen_Id) = N_Identifier
@@ -5071,7 +5163,7 @@ package body Sem_Ch12 is
if Etype (Gen_Unit) = Any_Type then
Restore_Env;
- return;
+ goto Leave;
end if;
-- Verify that it is a generic subprogram of the right kind, and that
@@ -5132,7 +5224,7 @@ package body Sem_Ch12 is
Generic_Renamings.Set_Last (0);
Generic_Renamings_HTable.Reset;
- Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
+ Create_Instantiation_Source (N, Gen_Unit, S_Adjustment);
-- Copy original generic tree, to produce text for instantiation
@@ -5256,8 +5348,8 @@ package body Sem_Ch12 is
Error_Msg_NE
("access parameter& is controlling,", N, Formal);
Error_Msg_NE
- ("\corresponding parameter of & must be "
- & "explicitly null-excluding", N, Gen_Id);
+ ("\corresponding parameter of & must be explicitly "
+ & "null-excluding", N, Gen_Id);
end if;
Next_Formal (Formal);
@@ -5313,10 +5405,6 @@ package body Sem_Ch12 is
Ignore_Pragma_SPARK_Mode := Save_IPSM;
SPARK_Mode := Save_SM;
SPARK_Mode_Pragma := Save_SMP;
-
- if SPARK_Mode = On then
- Dynamic_Elaboration_Checks := False;
- end if;
end if;
<<Leave>>
@@ -5324,6 +5412,10 @@ package body Sem_Ch12 is
Analyze_Aspect_Specifications (N, Act_Decl_Id);
end if;
+ if Mode_Set then
+ Restore_Ghost_Mode (Mode);
+ end if;
+
exception
when Instantiation_Error =>
if Parent_Installed then
@@ -5338,8 +5430,8 @@ package body Sem_Ch12 is
SPARK_Mode := Save_SM;
SPARK_Mode_Pragma := Save_SMP;
- if SPARK_Mode = On then
- Dynamic_Elaboration_Checks := False;
+ if Mode_Set then
+ Restore_Ghost_Mode (Mode);
end if;
end Analyze_Subprogram_Instantiation;
@@ -5729,8 +5821,9 @@ package body Sem_Ch12 is
(Formal_Pack : Entity_Id;
Actual_Pack : Entity_Id)
is
- E1 : Entity_Id := First_Entity (Actual_Pack);
- E2 : Entity_Id := First_Entity (Formal_Pack);
+ E1 : Entity_Id := First_Entity (Actual_Pack);
+ E2 : Entity_Id := First_Entity (Formal_Pack);
+ Prev_E1 : Entity_Id;
Expr1 : Node_Id;
Expr2 : Node_Id;
@@ -5760,7 +5853,11 @@ package body Sem_Ch12 is
--------------------
procedure Check_Mismatch (B : Boolean) is
- Kind : constant Node_Kind := Nkind (Parent (E2));
+ -- A Formal_Type_Declaration for a derived private type is rewritten
+ -- as a private extension decl. (see Analyze_Formal_Derived_Type),
+ -- which is why we examine the original node.
+
+ Kind : constant Node_Kind := Nkind (Original_Node (Parent (E2)));
begin
if Kind = N_Formal_Type_Declaration then
@@ -5892,6 +5989,7 @@ package body Sem_Ch12 is
-- Start of processing for Check_Formal_Package_Instance
begin
+ Prev_E1 := E1;
while Present (E1) and then Present (E2) loop
exit when Ekind (E1) = E_Package
and then Renamed_Entity (E1) = Renamed_Entity (Actual_Pack);
@@ -5921,10 +6019,28 @@ package body Sem_Ch12 is
if No (E1) then
return;
+ -- Entities may be declared without full declaration, such as
+ -- itypes and predefined operators (concatenation for arrays, eg).
+ -- Skip it and keep the formal entity to find a later match for it.
+
+ elsif No (Parent (E2)) and then Ekind (E1) /= Ekind (E2) then
+ E1 := Prev_E1;
+ goto Next_E;
+
-- If the formal entity comes from a formal declaration, it was
-- defaulted in the formal package, and no check is needed on it.
- elsif Nkind (Parent (E2)) = N_Formal_Object_Declaration then
+ elsif Nkind_In (Original_Node (Parent (E2)),
+ N_Formal_Object_Declaration,
+ N_Formal_Type_Declaration)
+ then
+ -- If the formal is a tagged type the corresponding class-wide
+ -- type has been generated as well, and it must be skipped.
+
+ if Is_Type (E2) and then Is_Tagged_Type (E2) then
+ Next_Entity (E2);
+ end if;
+
goto Next_E;
-- Ditto for defaulted formal subprograms.
@@ -6079,6 +6195,7 @@ package body Sem_Ch12 is
end if;
<<Next_E>>
+ Prev_E1 := E1;
Next_Entity (E1);
Next_Entity (E2);
end loop;
@@ -6255,8 +6372,7 @@ package body Sem_Ch12 is
Set_Is_Generic_Actual_Type (E, True);
Set_Is_Hidden (E, False);
- Set_Is_Potentially_Use_Visible (E,
- In_Use (Instance));
+ Set_Is_Potentially_Use_Visible (E, In_Use (Instance));
-- We constructed the generic actual type as a subtype of the
-- supplied type. This means that it normally would not inherit
@@ -6689,17 +6805,23 @@ package body Sem_Ch12 is
elsif Nkind (Gen_Id) = N_Expanded_Name then
- -- Entity already present, analyze prefix, whose meaning may be
- -- an instance in the current context. If it is an instance of
- -- a relative within another, the proper parent may still have
- -- to be installed, if they are not of the same generation.
+ -- Entity already present, analyze prefix, whose meaning may be an
+ -- instance in the current context. If it is an instance of a
+ -- relative within another, the proper parent may still have to be
+ -- installed, if they are not of the same generation.
Analyze (Prefix (Gen_Id));
- -- In the unlikely case that a local declaration hides the name
- -- of the parent package, locate it on the homonym chain. If the
- -- context is an instance of the parent, the renaming entity is
- -- flagged as such.
+ -- Prevent cascaded errors
+
+ if Etype (Prefix (Gen_Id)) = Any_Type then
+ return;
+ end if;
+
+ -- In the unlikely case that a local declaration hides the name of
+ -- the parent package, locate it on the homonym chain. If the context
+ -- is an instance of the parent, the renaming entity is flagged as
+ -- such.
Inst_Par := Entity (Prefix (Gen_Id));
while Present (Inst_Par)
@@ -7298,6 +7420,20 @@ package body Sem_Ch12 is
Set_Entity (New_N, Entity (Assoc));
Check_Private_View (N);
+ -- The node is a reference to a global type and acts as the
+ -- subtype mark of a qualified expression created in order
+ -- to aid resolution of accidental overloading in instances.
+ -- Since N is a reference to a type, the Associated_Node of
+ -- N denotes an entity rather than another identifier. See
+ -- Qualify_Universal_Operands for details.
+
+ elsif Nkind (N) = N_Identifier
+ and then Nkind (Parent (N)) = N_Qualified_Expression
+ and then Subtype_Mark (Parent (N)) = N
+ and then Is_Qualified_Universal_Literal (Parent (N))
+ then
+ Set_Entity (New_N, Assoc);
+
-- The name in the call may be a selected component if the
-- call has not been analyzed yet, as may be the case for
-- pre/post conditions in a generic unit.
@@ -7619,7 +7755,6 @@ package body Sem_Ch12 is
Create_Instantiation_Source
(Instantiation_Node,
Defining_Entity (N),
- False,
S_Adjustment);
end if;
@@ -7638,14 +7773,20 @@ package body Sem_Ch12 is
-- Do not copy Comment or Ident pragmas their content is relevant to
-- the generic unit, not to the instantiating unit.
- if Nam_In (Pragma_Name (N), Name_Comment, Name_Ident) then
+ if Nam_In (Pragma_Name_Unmapped (N), Name_Comment, Name_Ident) then
New_N := Make_Null_Statement (Sloc (N));
-- Do not copy pragmas generated from aspects because the pragmas do
-- not carry any semantic information, plus they will be regenerated
-- in the instance.
- elsif From_Aspect_Specification (N) then
+ -- However, generating C we need to copy them since postconditions
+ -- are inlined by the front end, and the front-end inlining machinery
+ -- relies on this routine to perform inlining.
+
+ elsif From_Aspect_Specification (N)
+ and then not Modify_Tree_For_C
+ then
New_N := Make_Null_Statement (Sloc (N));
else
@@ -7681,6 +7822,18 @@ package body Sem_Ch12 is
end if;
end if;
+ -- Propagate dimensions if present, so that they are reflected in the
+ -- instance.
+
+ if Nkind (N) in N_Has_Etype
+ and then (Nkind (N) in N_Op or else Is_Entity_Name (N))
+ and then Present (Etype (N))
+ and then Is_Floating_Point_Type (Etype (N))
+ and then Has_Dimension_System (Etype (N))
+ then
+ Copy_Dimensions (N, New_N);
+ end if;
+
return New_N;
end Copy_Generic_Node;
@@ -7883,7 +8036,7 @@ package body Sem_Ch12 is
end loop;
-- Expanded code usually shares the source location of the original
- -- construct it was generated for. This however may not necessarely
+ -- construct it was generated for. This however may not necessarily
-- reflect the true location of the code within the tree.
-- Before comparing the slocs of the two nodes, make sure that we are
@@ -8828,22 +8981,12 @@ package body Sem_Ch12 is
Gen_Body : Node_Id;
Gen_Decl : Node_Id)
is
- Act_Id : constant Entity_Id := Corresponding_Spec (Act_Body);
- Act_Unit : constant Node_Id := Unit (Cunit (Get_Source_Unit (N)));
- Gen_Id : constant Entity_Id := Corresponding_Spec (Gen_Body);
- Par : constant Entity_Id := Scope (Gen_Id);
- Gen_Unit : constant Node_Id :=
- Unit (Cunit (Get_Source_Unit (Gen_Decl)));
- Orig_Body : Node_Id := Gen_Body;
- F_Node : Node_Id;
- Body_Unit : Node_Id;
+ function In_Same_Scope (Gen_Id, Act_Id : Node_Id) return Boolean;
+ -- Check if the generic definition and the instantiation come from
+ -- a common scope, in which case the instance must be frozen after
+ -- the generic body.
- Must_Delay : Boolean;
-
- function In_Same_Enclosing_Subp return Boolean;
- -- Check whether instance and generic body are within same subprogram.
-
- function True_Sloc (N : Node_Id) return Source_Ptr;
+ function True_Sloc (N, Act_Unit : Node_Id) return Source_Ptr;
-- If the instance is nested inside a generic unit, the Sloc of the
-- instance indicates the place of the original definition, not the
-- point of the current enclosing instance. Pending a better usage of
@@ -8851,51 +8994,40 @@ package body Sem_Ch12 is
-- origin of a node by finding the maximum sloc of any ancestor node.
-- Why is this not equivalent to Top_Level_Location ???
- ----------------------------
- -- In_Same_Enclosing_Subp --
- ----------------------------
+ -------------------
+ -- In_Same_Scope --
+ -------------------
- function In_Same_Enclosing_Subp return Boolean is
- Scop : Entity_Id;
- Subp : Entity_Id;
+ function In_Same_Scope (Gen_Id, Act_Id : Node_Id) return Boolean is
+ Act_Scop : Entity_Id := Scope (Act_Id);
+ Gen_Scop : Entity_Id := Scope (Gen_Id);
begin
- Scop := Scope (Act_Id);
- while Scop /= Standard_Standard
- and then not Is_Overloadable (Scop)
+ while Act_Scop /= Standard_Standard
+ and then Gen_Scop /= Standard_Standard
loop
- Scop := Scope (Scop);
- end loop;
-
- if Scop = Standard_Standard then
- return False;
- else
- Subp := Scop;
- end if;
-
- Scop := Scope (Gen_Id);
- while Scop /= Standard_Standard loop
- if Scop = Subp then
+ if Act_Scop = Gen_Scop then
return True;
- else
- Scop := Scope (Scop);
end if;
+
+ Act_Scop := Scope (Act_Scop);
+ Gen_Scop := Scope (Gen_Scop);
end loop;
return False;
- end In_Same_Enclosing_Subp;
+ end In_Same_Scope;
---------------
-- True_Sloc --
---------------
- function True_Sloc (N : Node_Id) return Source_Ptr is
- Res : Source_Ptr;
+ function True_Sloc (N, Act_Unit : Node_Id) return Source_Ptr is
N1 : Node_Id;
+ Res : Source_Ptr;
begin
Res := Sloc (N);
- N1 := N;
+ N1 := N;
while Present (N1) and then N1 /= Act_Unit loop
if Sloc (N1) > Res then
Res := Sloc (N1);
@@ -8907,6 +9039,18 @@ package body Sem_Ch12 is
return Res;
end True_Sloc;
+ Act_Id : constant Entity_Id := Corresponding_Spec (Act_Body);
+ Act_Unit : constant Node_Id := Unit (Cunit (Get_Source_Unit (N)));
+ Gen_Id : constant Entity_Id := Corresponding_Spec (Gen_Body);
+ Par : constant Entity_Id := Scope (Gen_Id);
+ Gen_Unit : constant Node_Id :=
+ Unit (Cunit (Get_Source_Unit (Gen_Decl)));
+
+ Body_Unit : Node_Id;
+ F_Node : Node_Id;
+ Must_Delay : Boolean;
+ Orig_Body : Node_Id := Gen_Body;
+
-- Start of processing for Install_Body
begin
@@ -8968,13 +9112,13 @@ package body Sem_Ch12 is
Must_Delay :=
(Gen_Unit = Act_Unit
- and then (Nkind_In (Gen_Unit, N_Package_Declaration,
- N_Generic_Package_Declaration)
+ and then (Nkind_In (Gen_Unit, N_Generic_Package_Declaration,
+ N_Package_Declaration)
or else (Gen_Unit = Body_Unit
- and then True_Sloc (N) < Sloc (Orig_Body)))
- and then Is_In_Main_Unit (Gen_Unit)
- and then (Scope (Act_Id) = Scope (Gen_Id)
- or else In_Same_Enclosing_Subp));
+ and then True_Sloc (N, Act_Unit)
+ < Sloc (Orig_Body)))
+ and then Is_In_Main_Unit (Original_Node (Gen_Unit))
+ and then In_Same_Scope (Gen_Id, Act_Id));
-- If this is an early instantiation, the freeze node is placed after
-- the generic body. Otherwise, if the generic appears in an instance,
@@ -9530,18 +9674,20 @@ package body Sem_Ch12 is
begin
case Nkind (Original_Node (F)) is
- when N_Formal_Object_Declaration |
- N_Formal_Type_Declaration =>
+ when N_Formal_Object_Declaration
+ | N_Formal_Type_Declaration
+ =>
Formal_Ent := Defining_Identifier (F);
while Chars (Act) /= Chars (Formal_Ent) loop
Next_Entity (Act);
end loop;
- when N_Formal_Subprogram_Declaration |
- N_Formal_Package_Declaration |
- N_Package_Declaration |
- N_Generic_Package_Declaration =>
+ when N_Formal_Package_Declaration
+ | N_Formal_Subprogram_Declaration
+ | N_Generic_Package_Declaration
+ | N_Package_Declaration
+ =>
Formal_Ent := Defining_Entity (F);
while Chars (Act) /= Chars (Formal_Ent) loop
@@ -9635,19 +9781,19 @@ package body Sem_Ch12 is
Kind : constant Node_Kind := Nkind (Original_Node (N));
begin
case Kind is
- when N_Formal_Object_Declaration =>
+ when N_Formal_Object_Declaration =>
return Defining_Identifier (N);
- when N_Formal_Type_Declaration =>
+ when N_Formal_Type_Declaration =>
return Defining_Identifier (N);
when N_Formal_Subprogram_Declaration =>
return Defining_Unit_Name (Specification (N));
- when N_Formal_Package_Declaration =>
+ when N_Formal_Package_Declaration =>
return Defining_Identifier (Original_Node (N));
- when N_Generic_Package_Declaration =>
+ when N_Generic_Package_Declaration =>
return Defining_Identifier (Original_Node (N));
-- All other declarations are introduced by semantic analysis and
@@ -10644,10 +10790,11 @@ package body Sem_Ch12 is
-- An effectively volatile object cannot be used as an actual in a
-- generic instantiation (SPARK RM 7.1.3(7)). The following check is
-- relevant only when SPARK_Mode is on as it is not a standard Ada
- -- legality rule.
+ -- legality rule, and also verifies that the actual is an object.
if SPARK_Mode = On
and then Present (Actual)
+ and then Is_Object_Reference (Actual)
and then Is_Effectively_Volatile_Object (Actual)
then
Error_Msg_N
@@ -10662,38 +10809,27 @@ package body Sem_Ch12 is
-- Instantiate_Package_Body --
------------------------------
+ -- WARNING: This routine manages Ghost regions. Return statements must be
+ -- replaced by gotos which jump to the end of the routine and restore the
+ -- Ghost mode.
+
procedure Instantiate_Package_Body
(Body_Info : Pending_Body_Info;
Inlined_Body : Boolean := False;
Body_Optional : Boolean := False)
is
Act_Decl : constant Node_Id := Body_Info.Act_Decl;
+ Act_Decl_Id : constant Entity_Id := Defining_Entity (Act_Decl);
+ Act_Spec : constant Node_Id := Specification (Act_Decl);
Inst_Node : constant Node_Id := Body_Info.Inst_Node;
- Loc : constant Source_Ptr := Sloc (Inst_Node);
-
Gen_Id : constant Node_Id := Name (Inst_Node);
Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node);
Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit);
- Act_Spec : constant Node_Id := Specification (Act_Decl);
- Act_Decl_Id : constant Entity_Id := Defining_Entity (Act_Spec);
+ Loc : constant Source_Ptr := Sloc (Inst_Node);
Save_IPSM : constant Boolean := Ignore_Pragma_SPARK_Mode;
Save_Style_Check : constant Boolean := Style_Check;
- Act_Body : Node_Id;
- Act_Body_Id : Entity_Id;
- Act_Body_Name : Node_Id;
- Gen_Body : Node_Id;
- Gen_Body_Id : Node_Id;
- Par_Ent : Entity_Id := Empty;
- Par_Vis : Boolean := False;
-
- Parent_Installed : Boolean := False;
-
- Vis_Prims_List : Elist_Id := No_Elist;
- -- List of primitives made temporarily visible in the instantiation
- -- to match the visibility of the formal type
-
procedure Check_Initialized_Types;
-- In a generic package body, an entity of a generic private type may
-- appear uninitialized. This is suspicious, unless the actual is a
@@ -10762,6 +10898,23 @@ package body Sem_Ch12 is
end loop;
end Check_Initialized_Types;
+ -- Local variables
+
+ Act_Body : Node_Id;
+ Act_Body_Id : Entity_Id;
+ Act_Body_Name : Node_Id;
+ Gen_Body : Node_Id;
+ Gen_Body_Id : Node_Id;
+ Mode : Ghost_Mode_Type;
+ Par_Ent : Entity_Id := Empty;
+ Par_Vis : Boolean := False;
+
+ Parent_Installed : Boolean := False;
+
+ Vis_Prims_List : Elist_Id := No_Elist;
+ -- List of primitives made temporarily visible in the instantiation
+ -- to match the visibility of the formal type.
+
-- Start of processing for Instantiate_Package_Body
begin
@@ -10774,6 +10927,12 @@ package body Sem_Ch12 is
return;
end if;
+ -- The package being instantiated may be subject to pragma Ghost. Set
+ -- the mode now to ensure that any nodes generated during instantiation
+ -- are properly marked as Ghost.
+
+ Set_Ghost_Mode (Act_Decl_Id, Mode);
+
Expander_Mode_Save_And_Set (Body_Info.Expander_Status);
-- Re-establish the state of information on which checks are suppressed.
@@ -10799,7 +10958,7 @@ package body Sem_Ch12 is
if not Unit_Requires_Body (Defining_Entity (Gen_Decl))
and then Body_Optional
then
- return;
+ goto Leave;
else
Load_Parent_Of_Generic
(Inst_Node, Specification (Gen_Decl), Body_Optional);
@@ -10843,7 +11002,7 @@ package body Sem_Ch12 is
Gen_Body := Unit_Declaration_Node (Gen_Body_Id);
Create_Instantiation_Source
- (Inst_Node, Gen_Body_Id, False, S_Adjustment);
+ (Inst_Node, Gen_Body_Id, S_Adjustment);
Act_Body :=
Copy_Generic_Node
@@ -10888,6 +11047,7 @@ package body Sem_Ch12 is
E := First_Entity (Act_Decl_Id);
while Present (E) loop
if Is_Type (E)
+ and then not Is_Itype (E)
and then Is_Generic_Actual_Type (E)
and then Is_Tagged_Type (E)
then
@@ -10969,8 +11129,12 @@ package body Sem_Ch12 is
-- Note that we do NOT apply this criterion to children of GNAT
-- The latter units must suppress checks explicitly if needed.
- if Is_Predefined_File_Name
- (Unit_File_Name (Get_Source_Unit (Gen_Decl)))
+ -- We also do not suppress checks in CodePeer mode where we are
+ -- interested in finding possible runtime errors.
+
+ if not CodePeer_Mode
+ and then Is_Predefined_File_Name
+ (Unit_File_Name (Get_Source_Unit (Gen_Decl)))
then
Analyze (Act_Body, Suppress => All_Checks);
else
@@ -11058,24 +11222,30 @@ package body Sem_Ch12 is
end if;
Expander_Mode_Restore;
+
+ <<Leave>>
+ Restore_Ghost_Mode (Mode);
end Instantiate_Package_Body;
---------------------------------
-- Instantiate_Subprogram_Body --
---------------------------------
+ -- WARNING: This routine manages Ghost regions. Return statements must be
+ -- replaced by gotos which jump to the end of the routine and restore the
+ -- Ghost mode.
+
procedure Instantiate_Subprogram_Body
(Body_Info : Pending_Body_Info;
Body_Optional : Boolean := False)
is
Act_Decl : constant Node_Id := Body_Info.Act_Decl;
+ Act_Decl_Id : constant Entity_Id := Defining_Entity (Act_Decl);
Inst_Node : constant Node_Id := Body_Info.Inst_Node;
- Loc : constant Source_Ptr := Sloc (Inst_Node);
Gen_Id : constant Node_Id := Name (Inst_Node);
Gen_Unit : constant Entity_Id := Get_Generic_Entity (Inst_Node);
Gen_Decl : constant Node_Id := Unit_Declaration_Node (Gen_Unit);
- Act_Decl_Id : constant Entity_Id :=
- Defining_Unit_Name (Specification (Act_Decl));
+ Loc : constant Source_Ptr := Sloc (Inst_Node);
Pack_Id : constant Entity_Id :=
Defining_Unit_Name (Parent (Act_Decl));
@@ -11087,6 +11257,7 @@ package body Sem_Ch12 is
Act_Body_Id : Entity_Id;
Gen_Body : Node_Id;
Gen_Body_Id : Node_Id;
+ Mode : Ghost_Mode_Type;
Pack_Body : Node_Id;
Par_Ent : Entity_Id := Empty;
Par_Vis : Boolean := False;
@@ -11105,6 +11276,12 @@ package body Sem_Ch12 is
return;
end if;
+ -- The subprogram being instantiated may be subject to pragma Ghost. Set
+ -- the mode now to ensure that any nodes generated during instantiation
+ -- are properly marked as Ghost.
+
+ Set_Ghost_Mode (Act_Decl_Id, Mode);
+
Expander_Mode_Save_And_Set (Body_Info.Expander_Status);
-- Re-establish the state of information on which checks are suppressed.
@@ -11131,7 +11308,7 @@ package body Sem_Ch12 is
Set_Interface_Name (Act_Decl_Id, Interface_Name (Gen_Unit));
Set_Convention (Act_Decl_Id, Convention (Gen_Unit));
Set_Has_Completion (Act_Decl_Id);
- return;
+ goto Leave;
-- For other cases, compile the body
@@ -11156,12 +11333,11 @@ package body Sem_Ch12 is
if Expander_Active
and then Operating_Mode = Generate_Code
then
- Error_Msg_N
- ("missing proper body for instantiation", Gen_Body);
+ Error_Msg_N ("missing proper body for instantiation", Gen_Body);
end if;
Set_Has_Completion (Act_Decl_Id);
- return;
+ goto Leave;
end if;
Save_Env (Gen_Unit, Act_Decl_Id);
@@ -11180,7 +11356,6 @@ package body Sem_Ch12 is
Create_Instantiation_Source
(Inst_Node,
Gen_Body_Id,
- False,
S_Adjustment);
Act_Body :=
@@ -11294,27 +11469,25 @@ package body Sem_Ch12 is
and then Nkind (Parent (Inst_Node)) /= N_Compilation_Unit
then
if Body_Optional then
- return;
+ goto Leave;
elsif Ekind (Act_Decl_Id) = E_Procedure then
Act_Body :=
Make_Subprogram_Body (Loc,
- Specification =>
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, Chars (Act_Decl_Id)),
- Parameter_Specifications =>
- New_Copy_List
- (Parameter_Specifications (Parent (Act_Decl_Id)))),
-
- Declarations => Empty_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements =>
- New_List (
- Make_Raise_Program_Error (Loc,
- Reason =>
- PE_Access_Before_Elaboration))));
+ Specification =>
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc, Chars (Act_Decl_Id)),
+ Parameter_Specifications =>
+ New_Copy_List
+ (Parameter_Specifications (Parent (Act_Decl_Id)))),
+
+ Declarations => Empty_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Access_Before_Elaboration))));
else
Ret_Expr :=
@@ -11328,9 +11501,9 @@ package body Sem_Ch12 is
Make_Subprogram_Body (Loc,
Specification =>
Make_Function_Specification (Loc,
- Defining_Unit_Name =>
+ Defining_Unit_Name =>
Make_Defining_Identifier (Loc, Chars (Act_Decl_Id)),
- Parameter_Specifications =>
+ Parameter_Specifications =>
New_Copy_List
(Parameter_Specifications (Parent (Act_Decl_Id))),
Result_Definition =>
@@ -11339,9 +11512,8 @@ package body Sem_Ch12 is
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements =>
- New_List
- (Make_Simple_Return_Statement (Loc, Ret_Expr))));
+ Statements => New_List (
+ Make_Simple_Return_Statement (Loc, Ret_Expr))));
end if;
Pack_Body :=
@@ -11355,6 +11527,9 @@ package body Sem_Ch12 is
end if;
Expander_Mode_Restore;
+
+ <<Leave>>
+ Restore_Ghost_Mode (Mode);
end Instantiate_Subprogram_Body;
----------------------
@@ -11603,15 +11778,15 @@ package body Sem_Ch12 is
I2 : Node_Id;
T2 : Entity_Id;
- function Formal_Dimensions return Int;
+ function Formal_Dimensions return Nat;
-- Count number of dimensions in array type formal
-----------------------
-- Formal_Dimensions --
-----------------------
- function Formal_Dimensions return Int is
- Num : Int := 0;
+ function Formal_Dimensions return Nat is
+ Num : Nat := 0;
Index : Node_Id;
begin
@@ -12655,19 +12830,19 @@ package body Sem_Ch12 is
when N_Access_To_Object_Definition =>
Validate_Access_Type_Instance;
- when N_Access_Function_Definition |
- N_Access_Procedure_Definition =>
+ when N_Access_Function_Definition
+ | N_Access_Procedure_Definition
+ =>
Validate_Access_Subprogram_Instance;
- when N_Record_Definition =>
+ when N_Record_Definition =>
Validate_Interface_Type_Instance;
- when N_Derived_Type_Definition =>
+ when N_Derived_Type_Definition =>
Validate_Derived_Interface_Type_Instance;
when others =>
raise Program_Error;
-
end case;
end if;
@@ -12808,11 +12983,12 @@ package body Sem_Ch12 is
-- or in the declaration of the main unit, which in this last case must
-- be a body.
- return Unum = Main_Unit
- or else Current_Unit = Cunit (Main_Unit)
- or else Current_Unit = Library_Unit (Cunit (Main_Unit))
- or else (Present (Library_Unit (Current_Unit))
- and then Is_In_Main_Unit (Library_Unit (Current_Unit)));
+ return
+ Current_Unit = Cunit (Main_Unit)
+ or else Current_Unit = Library_Unit (Cunit (Main_Unit))
+ or else (Present (Current_Unit)
+ and then Present (Library_Unit (Current_Unit))
+ and then Is_In_Main_Unit (Library_Unit (Current_Unit)));
end Is_In_Main_Unit;
----------------------------
@@ -13080,18 +13256,23 @@ package body Sem_Ch12 is
-- The instance_spec is in the wrapper package,
-- usually followed by its local renaming
-- declaration. See Build_Subprogram_Renaming
- -- for details.
+ -- for details. If the instance carries aspects,
+ -- these result in the corresponding pragmas,
+ -- inserted after the subprogram declaration.
+ -- They must be skipped as well when retrieving
+ -- the desired spec. A direct link would be
+ -- more robust ???
declare
Decl : Node_Id :=
(Last (Visible_Declarations
(Specification (Info.Act_Decl))));
begin
- if Nkind (Decl) =
- N_Subprogram_Renaming_Declaration
- then
+ while Nkind_In (Decl,
+ N_Subprogram_Renaming_Declaration, N_Pragma)
+ loop
Decl := Prev (Decl);
- end if;
+ end loop;
Info.Act_Decl := Decl;
end;
@@ -13345,7 +13526,7 @@ package body Sem_Ch12 is
procedure Preanalyze_Actuals (N : Node_Id; Inst : Entity_Id := Empty) is
Assoc : Node_Id;
Act : Node_Id;
- Errs : constant Int := Serious_Errors_Detected;
+ Errs : constant Nat := Serious_Errors_Detected;
Cur : Entity_Id := Empty;
-- Current homograph of the instance name
@@ -13853,6 +14034,19 @@ package body Sem_Ch12 is
-- global because it is used to denote a specific compilation unit at
-- the time the instantiations will be analyzed.
+ procedure Qualify_Universal_Operands
+ (Op : Node_Id;
+ Func_Call : Node_Id);
+ -- Op denotes a binary or unary operator in generic template Templ. Node
+ -- Func_Call is the function call alternative of the operator within the
+ -- the analyzed copy of the template. Change each operand which yields a
+ -- universal type by wrapping it into a qualified expression
+ --
+ -- Actual_Typ'(Operand)
+ --
+ -- where Actual_Typ is the type of corresponding actual parameter of
+ -- Operand in Func_Call.
+
procedure Reset_Entity (N : Node_Id);
-- Save semantic information on global entity so that it is not resolved
-- again at instantiation time.
@@ -13880,7 +14074,7 @@ package body Sem_Ch12 is
-- so that it can be properly resolved in a subsequent instantiation.
procedure Save_Global_Descendant (D : Union_Id);
- -- Apply Save_References recursively to the descendents of node D
+ -- Apply Save_References recursively to the descendants of node D
procedure Save_References (N : Node_Id);
-- This is the recursive procedure that does the work, once the
@@ -13943,6 +14137,119 @@ package body Sem_Ch12 is
end if;
end Is_Global;
+ --------------------------------
+ -- Qualify_Universal_Operands --
+ --------------------------------
+
+ procedure Qualify_Universal_Operands
+ (Op : Node_Id;
+ Func_Call : Node_Id)
+ is
+ procedure Qualify_Operand (Opnd : Node_Id; Actual : Node_Id);
+ -- Rewrite operand Opnd as a qualified expression of the form
+ --
+ -- Actual_Typ'(Opnd)
+ --
+ -- where Actual is the corresponding actual parameter of Opnd in
+ -- function call Func_Call.
+
+ function Qualify_Type
+ (Loc : Source_Ptr;
+ Typ : Entity_Id) return Node_Id;
+ -- Qualify type Typ by creating a selected component of the form
+ --
+ -- Scope_Of_Typ.Typ
+
+ ---------------------
+ -- Qualify_Operand --
+ ---------------------
+
+ procedure Qualify_Operand (Opnd : Node_Id; Actual : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Opnd);
+ Typ : constant Entity_Id := Etype (Actual);
+ Mark : Node_Id;
+ Qual : Node_Id;
+
+ begin
+ -- Qualify the operand when it is of a universal type. Note that
+ -- the template is unanalyzed and it is not possible to directly
+ -- query the type. This transformation is not done when the type
+ -- of the actual is internally generated because the type will be
+ -- regenerated in the instance.
+
+ if Yields_Universal_Type (Opnd)
+ and then Comes_From_Source (Typ)
+ and then not Is_Hidden (Typ)
+ then
+ -- The type of the actual may be a global reference. Save this
+ -- information by creating a reference to it.
+
+ if Is_Global (Typ) then
+ Mark := New_Occurrence_Of (Typ, Loc);
+
+ -- Otherwise rely on resolution to find the proper type within
+ -- the instance.
+
+ else
+ Mark := Qualify_Type (Loc, Typ);
+ end if;
+
+ Qual :=
+ Make_Qualified_Expression (Loc,
+ Subtype_Mark => Mark,
+ Expression => Relocate_Node (Opnd));
+
+ -- Mark the qualification to distinguish it from other source
+ -- constructs and signal the instantiation mechanism that this
+ -- node requires special processing. See Copy_Generic_Node for
+ -- details.
+
+ Set_Is_Qualified_Universal_Literal (Qual);
+
+ Rewrite (Opnd, Qual);
+ end if;
+ end Qualify_Operand;
+
+ ------------------
+ -- Qualify_Type --
+ ------------------
+
+ function Qualify_Type
+ (Loc : Source_Ptr;
+ Typ : Entity_Id) return Node_Id
+ is
+ Scop : constant Entity_Id := Scope (Typ);
+ Result : Node_Id;
+
+ begin
+ Result := Make_Identifier (Loc, Chars (Typ));
+
+ if Present (Scop) and then not Is_Generic_Unit (Scop) then
+ Result :=
+ Make_Selected_Component (Loc,
+ Prefix => Make_Identifier (Loc, Chars (Scop)),
+ Selector_Name => Result);
+ end if;
+
+ return Result;
+ end Qualify_Type;
+
+ -- Local variables
+
+ Actuals : constant List_Id := Parameter_Associations (Func_Call);
+
+ -- Start of processing for Qualify_Universal_Operands
+
+ begin
+ if Nkind (Op) in N_Binary_Op then
+ Qualify_Operand (Left_Opnd (Op), First (Actuals));
+ Qualify_Operand (Right_Opnd (Op), Next (First (Actuals)));
+
+ elsif Nkind (Op) in N_Unary_Op then
+ Qualify_Operand (Right_Opnd (Op), First (Actuals));
+ end if;
+ end Qualify_Universal_Operands;
+
------------------
-- Reset_Entity --
------------------
@@ -14005,6 +14312,12 @@ package body Sem_Ch12 is
Set_Etype (N2, Full_View (Typ));
end if;
end if;
+
+ if Is_Floating_Point_Type (Typ)
+ and then Has_Dimension_System (Typ)
+ then
+ Copy_Dimensions (N2, N);
+ end if;
end Set_Global_Type;
------------------
@@ -14080,7 +14393,7 @@ package body Sem_Ch12 is
if Is_Global (Entity (Original_Node (N2))) then
N2 := Original_Node (N2);
Set_Associated_Node (N, N2);
- Set_Global_Type (N, N2);
+ Set_Global_Type (N, N2);
-- Renaming is local, and will be resolved in instance
@@ -14122,7 +14435,7 @@ package body Sem_Ch12 is
if Is_Global (Entity (Parent (N2))) then
Change_Selected_Component_To_Expanded_Name (Parent (N));
Set_Associated_Node (Parent (N), Parent (N2));
- Set_Global_Type (Parent (N), Parent (N2));
+ Set_Global_Type (Parent (N), Parent (N2));
Save_Entity_Descendants (N);
-- If this is a reference to the current generic entity, replace
@@ -14181,7 +14494,7 @@ package body Sem_Ch12 is
if Is_Global (Entity (Name (Parent (N2)))) then
Change_Selected_Component_To_Expanded_Name (Parent (N));
Set_Associated_Node (Parent (N), Name (Parent (N2)));
- Set_Global_Type (Parent (N), Name (Parent (N2)));
+ Set_Global_Type (Parent (N), Name (Parent (N2)));
Save_Entity_Descendants (N);
else
@@ -14225,14 +14538,16 @@ package body Sem_Ch12 is
when N_Unary_Op =>
Save_Global_Descendant (Union_Id (Right_Opnd (N)));
- when N_Expanded_Name |
- N_Selected_Component =>
+ when N_Expanded_Name
+ | N_Selected_Component
+ =>
Save_Global_Descendant (Union_Id (Prefix (N)));
Save_Global_Descendant (Union_Id (Selector_Name (N)));
- when N_Identifier |
- N_Character_Literal |
- N_Operator_Symbol =>
+ when N_Character_Literal
+ | N_Identifier
+ | N_Operator_Symbol
+ =>
null;
when others =>
@@ -14390,7 +14705,10 @@ package body Sem_Ch12 is
end if;
elsif D in List_Range then
- if D = Union_Id (No_List) or else Is_Empty_List (List_Id (D)) then
+ pragma Assert (D /= Union_Id (No_List));
+ -- Because No_List = Empty, which is in Node_Range above
+
+ if Is_Empty_List (List_Id (D)) then
null;
else
@@ -14615,14 +14933,41 @@ package body Sem_Ch12 is
-- The node did not undergo a transformation
if Nkind (N) = Nkind (Get_Associated_Node (N)) then
+ declare
+ Aux_N2 : constant Node_Id := Get_Associated_Node (N);
+ Orig_N2_Parent : constant Node_Id :=
+ Original_Node (Parent (Aux_N2));
+ begin
+ -- The parent of this identifier is a selected component
+ -- which denotes a named number that was constant folded.
+ -- Preserve the original name for ASIS and link the parent
+ -- with its expanded name. The constant folding will be
+ -- repeated in the instance.
+
+ if Nkind (Parent (N)) = N_Selected_Component
+ and then Nkind_In (Parent (Aux_N2), N_Integer_Literal,
+ N_Real_Literal)
+ and then Is_Entity_Name (Orig_N2_Parent)
+ and then Ekind (Entity (Orig_N2_Parent)) in Named_Kind
+ and then Is_Global (Entity (Orig_N2_Parent))
+ then
+ N2 := Aux_N2;
+ Set_Associated_Node
+ (Parent (N), Original_Node (Parent (N2)));
- -- If this is a discriminant reference, always save it. It is
- -- used in the instance to find the corresponding discriminant
- -- positionally rather than by name.
+ -- Common case
- Set_Original_Discriminant
- (N, Original_Discriminant (Get_Associated_Node (N)));
- Reset_Entity (N);
+ else
+ -- If this is a discriminant reference, always save it.
+ -- It is used in the instance to find the corresponding
+ -- discriminant positionally rather than by name.
+
+ Set_Original_Discriminant
+ (N, Original_Discriminant (Get_Associated_Node (N)));
+ end if;
+
+ Reset_Entity (N);
+ end;
-- The analysis of the generic copy transformed the identifier
-- into another construct. Propagate the changes to the template.
@@ -14721,7 +15066,8 @@ package body Sem_Ch12 is
Reset_Entity (N);
-- The analysis of the generic copy transformed the operator into
- -- some other construct. Propagate the changes to the template.
+ -- some other construct. Propagate the changes to the template if
+ -- applicable.
else
N2 := Get_Associated_Node (N);
@@ -14729,13 +15075,21 @@ package body Sem_Ch12 is
-- The operator resoved to a function call
if Nkind (N2) = N_Function_Call then
+
+ -- Add explicit qualifications in the generic template for
+ -- all operands of universal type. This aids resolution by
+ -- preserving the actual type of a literal or an attribute
+ -- that yields a universal result.
+
+ Qualify_Universal_Operands (N, N2);
+
E := Entity (Name (N2));
if Present (E) and then Is_Global (E) then
Set_Etype (N, Etype (N2));
else
Set_Associated_Node (N, Empty);
- Set_Etype (N, Empty);
+ Set_Etype (N, Empty);
end if;
-- The operator was folded into a literal
@@ -14943,13 +15297,31 @@ package body Sem_Ch12 is
end loop;
end Save_Global_References_In_Aspects;
+ ------------------------------------------
+ -- Set_Copied_Sloc_For_Inherited_Pragma --
+ ------------------------------------------
+
+ procedure Set_Copied_Sloc_For_Inherited_Pragma
+ (N : Node_Id;
+ E : Entity_Id)
+ is
+ begin
+ Create_Instantiation_Source (N, E,
+ Inlined_Body => False,
+ Inherited_Pragma => True,
+ Factor => S_Adjustment);
+ end Set_Copied_Sloc_For_Inherited_Pragma;
+
--------------------------------------
-- Set_Copied_Sloc_For_Inlined_Body --
--------------------------------------
procedure Set_Copied_Sloc_For_Inlined_Body (N : Node_Id; E : Entity_Id) is
begin
- Create_Instantiation_Source (N, E, True, S_Adjustment);
+ Create_Instantiation_Source (N, E,
+ Inlined_Body => True,
+ Inherited_Pragma => False,
+ Factor => S_Adjustment);
end Set_Copied_Sloc_For_Inlined_Body;
---------------------
@@ -15026,12 +15398,6 @@ package body Sem_Ch12 is
SPARK_Mode := Save_SPARK_Mode;
SPARK_Mode_Pragma := Save_SPARK_Mode_Pragma;
-
- -- Make sure dynamic elaboration checks are off in SPARK Mode
-
- if SPARK_Mode = On then
- Dynamic_Elaboration_Checks := False;
- end if;
end if;
Current_Instantiated_Parent :=
@@ -15114,7 +15480,7 @@ package body Sem_Ch12 is
T : constant Entity_Id := Entity (Prefix (Def));
Is_Fun : constant Boolean := (Ekind (Nam) = E_Function);
F : Entity_Id;
- Num_F : Int;
+ Num_F : Nat;
OK : Boolean;
begin
@@ -15130,27 +15496,43 @@ package body Sem_Ch12 is
end loop;
case Attr_Id is
- when Attribute_Adjacent | Attribute_Ceiling | Attribute_Copy_Sign |
- Attribute_Floor | Attribute_Fraction | Attribute_Machine |
- Attribute_Model | Attribute_Remainder | Attribute_Rounding |
- Attribute_Unbiased_Rounding =>
+ when Attribute_Adjacent
+ | Attribute_Ceiling
+ | Attribute_Copy_Sign
+ | Attribute_Floor
+ | Attribute_Fraction
+ | Attribute_Machine
+ | Attribute_Model
+ | Attribute_Remainder
+ | Attribute_Rounding
+ | Attribute_Unbiased_Rounding
+ =>
OK := Is_Fun
and then Num_F = 1
and then Is_Floating_Point_Type (T);
- when Attribute_Image | Attribute_Pred | Attribute_Succ |
- Attribute_Value | Attribute_Wide_Image |
- Attribute_Wide_Value =>
- OK := (Is_Fun and then Num_F = 1 and then Is_Scalar_Type (T));
+ when Attribute_Image
+ | Attribute_Pred
+ | Attribute_Succ
+ | Attribute_Value
+ | Attribute_Wide_Image
+ | Attribute_Wide_Value
+ =>
+ OK := Is_Fun and then Num_F = 1 and then Is_Scalar_Type (T);
- when Attribute_Max | Attribute_Min =>
- OK := (Is_Fun and then Num_F = 2 and then Is_Scalar_Type (T));
+ when Attribute_Max
+ | Attribute_Min
+ =>
+ OK := Is_Fun and then Num_F = 2 and then Is_Scalar_Type (T);
when Attribute_Input =>
OK := (Is_Fun and then Num_F = 1);
- when Attribute_Output | Attribute_Read | Attribute_Write =>
- OK := (not Is_Fun and then Num_F = 2);
+ when Attribute_Output
+ | Attribute_Read
+ | Attribute_Write
+ =>
+ OK := not Is_Fun and then Num_F = 2;
when others =>
OK := False;
diff --git a/gcc/ada/sem_ch12.ads b/gcc/ada/sem_ch12.ads
index c54d7359de..82a093afae 100644
--- a/gcc/ada/sem_ch12.ads
+++ b/gcc/ada/sem_ch12.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -37,6 +37,10 @@ package Sem_Ch12 is
procedure Analyze_Formal_Subprogram_Declaration (N : Node_Id);
procedure Analyze_Formal_Package_Declaration (N : Node_Id);
+ procedure Add_Pending_Instantiation (Inst : Node_Id; Act_Decl : Node_Id);
+ -- Add an entry in the table of instance bodies that must be analyzed
+ -- when inlining requires its body or the body of a nested instance.
+
function Build_Function_Wrapper
(Formal_Subp : Entity_Id;
Actual_Subp : Entity_Id) return Node_Id;
@@ -100,7 +104,7 @@ package Sem_Ch12 is
Body_Optional : Boolean := False);
-- Called after semantic analysis, to complete the instantiation of
-- package instances. The flag Inlined_Body is set if the body is
- -- being instantiated on the fly for inlined purposes.
+ -- being instantiated on the fly for inlining purposes.
--
-- The flag Body_Optional indicates that the call is for an instance
-- that precedes the current instance in the same declarative part.
@@ -112,13 +116,13 @@ package Sem_Ch12 is
-- appears in the context of some other unit P that contains an instance
-- of G, we compile the body of I2, but not that of I1. However, when we
-- compile U as the main unit, we compile both bodies. This will lead to
- -- lead to link-time errors if the compilation of I1 generates public
- -- symbols, because those in I2 will receive different names in both
- -- cases. This forces us to analyze the body of I1 even when U is not the
- -- main unit. We don't want this additional mechanism to generate an error
- -- when the body of the generic for I1 is not present, and this is the
- -- reason for the presence of the flag Body_Optional, which is exchanged
- -- between the current procedure and Load_Parent_Of_Generic.
+ -- link-time errors if the compilation of I1 generates public symbols,
+ -- because those in I2 will receive different names in both cases. This
+ -- forces us to analyze the body of I1 even when U is not the main unit.
+ -- We don't want this additional mechanism to generate an error when the
+ -- body of the generic for I1 is not present, and this is the reason for
+ -- the presence of the flag Body_Optional, which is exchanged between the
+ -- current procedure and Load_Parent_Of_Generic.
procedure Instantiate_Subprogram_Body
(Body_Info : Pending_Body_Info;
@@ -168,6 +172,32 @@ package Sem_Ch12 is
-- saved as part of the internal state of the Sem_Ch12 package for use
-- in subsequent calls to copy nodes.
+ procedure Set_Copied_Sloc_For_Inherited_Pragma
+ (N : Node_Id;
+ E : Entity_Id);
+ -- This procedure is used when a class-wide pre- or postcondition is
+ -- inherited. This process shares the same circuitry as the creation of
+ -- an instantiated copy of a generic template. The call to this procedure
+ -- establishes a new source file entry representing the inherited pragma
+ -- as an instantiation, marked as an inherited pragma (so that errout can
+ -- distinguish cases for generating error messages, otherwise the treatment
+ -- is identical). In this call, N is the subprogram declaration from
+ -- which the pragma is inherited and E is the defining identifier of
+ -- the overriding subprogram (when the subprogram is redefined) or the
+ -- defining identifier of the extension type (when the subprogram is
+ -- inherited). The resulting Sloc adjustment factor is saved as part of the
+ -- internal state of the Sem_Ch12 package for use in subsequent calls to
+ -- copy nodes.
+
+ procedure Adjust_Inherited_Pragma_Sloc (N : Node_Id);
+ -- This procedure is used when a class-wide pre- or postcondition
+ -- is inherited. It is called on each node of the pragma expression
+ -- to adjust its sloc. These call should be preceded by a call to
+ -- Set_Copied_Sloc_For_Inherited_Pragma that sets the required sloc
+ -- adjustment. This is done directly, instead of using Copy_Generic_Node
+ -- to copy nodes and adjust slocs, as Copy_Generic_Node expects a specific
+ -- structure to be in place, which is not the case for inherited pragmas.
+
procedure Save_Env
(Gen_Unit : Entity_Id;
Act_Unit : Entity_Id);
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 688861e7e9..ac1e02cfee 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -30,6 +30,7 @@ with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
+with Expander; use Expander;
with Exp_Disp; use Exp_Disp;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
@@ -58,11 +59,10 @@ with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
+with Sinfo; use Sinfo;
with Sinput; use Sinput;
with Snames; use Snames;
with Stand; use Stand;
-with Sinfo; use Sinfo;
-with Stringt; use Stringt;
with Targparm; use Targparm;
with Ttypes; use Ttypes;
with Tbuild; use Tbuild;
@@ -80,6 +80,10 @@ package body Sem_Ch13 is
-- Local Subprograms --
-----------------------
+ procedure Adjust_Record_For_Reverse_Bit_Order_Ada_95 (R : Entity_Id);
+ -- Helper routine providing the original (pre-AI95-0133) behavior for
+ -- Adjust_Record_For_Reverse_Bit_Order.
+
procedure Alignment_Check_For_Size_Change (Typ : Entity_Id; Size : Uint);
-- This routine is called after setting one of the sizes of type entity
-- Typ to Size. The purpose is to deal with the situation of a derived
@@ -101,17 +105,31 @@ package body Sem_Ch13 is
-- list is stored in Static_Discrete_Predicate (Typ), and the Expr is
-- rewritten as a canonicalized membership operation.
+ function Build_Export_Import_Pragma
+ (Asp : Node_Id;
+ Id : Entity_Id) return Node_Id;
+ -- Create the corresponding pragma for aspect Export or Import denoted by
+ -- Asp. Id is the related entity subject to the aspect. Return Empty when
+ -- the expression of aspect Asp evaluates to False or is erroneous.
+
+ function Build_Predicate_Function_Declaration
+ (Typ : Entity_Id) return Node_Id;
+ -- Build the declaration for a predicate function. The declaration is built
+ -- at the end of the declarative part containing the type definition, which
+ -- may be before the freeze point of the type. The predicate expression is
+ -- pre-analyzed at this point, to catch visibility errors.
+
procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id);
-- If Typ has predicates (indicated by Has_Predicates being set for Typ),
-- then either there are pragma Predicate entries on the rep chain for the
-- type (note that Predicate aspects are converted to pragma Predicate), or
-- there are inherited aspects from a parent type, or ancestor subtypes.
- -- This procedure builds the spec and body for the Predicate function that
- -- tests these predicates. N is the freeze node for the type. The spec of
- -- the function is inserted before the freeze node, and the body of the
- -- function is inserted after the freeze node. If the predicate expression
- -- has at least one Raise_Expression, then this procedure also builds the
- -- M version of the predicate function for use in membership tests.
+ -- This procedure builds body for the Predicate function that tests these
+ -- predicates. N is the freeze node for the type. The spec of the function
+ -- is inserted before the freeze node, and the body of the function is
+ -- inserted after the freeze node. If the predicate expression has a least
+ -- one Raise_Expression, then this procedure also builds the M version of
+ -- the predicate function for use in membership tests.
procedure Check_Pool_Size_Clash (Ent : Entity_Id; SP, SS : Node_Id);
-- Called if both Storage_Pool and Storage_Size attribute definition
@@ -129,6 +147,27 @@ package body Sem_Ch13 is
-- Uint value. If the value is inappropriate, then error messages are
-- posted as required, and a value of No_Uint is returned.
+ procedure Get_Interfacing_Aspects
+ (Iface_Asp : Node_Id;
+ Conv_Asp : out Node_Id;
+ EN_Asp : out Node_Id;
+ Expo_Asp : out Node_Id;
+ Imp_Asp : out Node_Id;
+ LN_Asp : out Node_Id;
+ Do_Checks : Boolean := False);
+ -- Given a single interfacing aspect Iface_Asp, retrieve other interfacing
+ -- aspects that apply to the same related entity. The aspects considered by
+ -- this routine are as follows:
+ --
+ -- Conv_Asp - aspect Convention
+ -- EN_Asp - aspect External_Name
+ -- Expo_Asp - aspect Export
+ -- Imp_Asp - aspect Import
+ -- LN_Asp - aspect Link_Name
+ --
+ -- When flag Do_Checks is set, this routine will flag duplicate uses of
+ -- aspects.
+
function Is_Operational_Item (N : Node_Id) return Boolean;
-- A specification for a stream attribute is allowed before the full type
-- is declared, as explained in AI-00137 and the corrigendum. Attributes
@@ -201,6 +240,41 @@ package body Sem_Ch13 is
-- is True. This warning inserts the string Msg to describe the construct
-- causing biasing.
+ ---------------------------------------------------
+ -- Table for Validate_Compile_Time_Warning_Error --
+ ---------------------------------------------------
+
+ -- The following table collects pragmas Compile_Time_Error and Compile_
+ -- Time_Warning for validation. Entries are made by calls to subprogram
+ -- Validate_Compile_Time_Warning_Error, and the call to the procedure
+ -- Validate_Compile_Time_Warning_Errors does the actual error checking
+ -- and posting of warning and error messages. The reason for this delayed
+ -- processing is to take advantage of back-annotations of attributes size
+ -- and alignment values performed by the back end.
+
+ -- Note: the reason we store a Source_Ptr value instead of a Node_Id is
+ -- that by the time Validate_Unchecked_Conversions is called, Sprint will
+ -- already have modified all Sloc values if the -gnatD option is set.
+
+ type CTWE_Entry is record
+ Eloc : Source_Ptr;
+ -- Source location used in warnings and error messages
+
+ Prag : Node_Id;
+ -- Pragma Compile_Time_Error or Compile_Time_Warning
+
+ Scope : Node_Id;
+ -- The scope which encloses the pragma
+ end record;
+
+ package Compile_Time_Warnings_Errors is new Table.Table (
+ Table_Component_Type => CTWE_Entry,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 1,
+ Table_Initial => 50,
+ Table_Increment => 200,
+ Table_Name => "Compile_Time_Warnings_Errors");
+
----------------------------------------------
-- Table for Validate_Unchecked_Conversions --
----------------------------------------------
@@ -239,9 +313,10 @@ package body Sem_Ch13 is
-- for X'Address use Expr
- -- where Expr is of the form Y'Address or recursively is a reference to a
- -- constant of either of these forms, and X and Y are entities of objects,
- -- then if Y has a smaller alignment than X, that merits a warning about
+ -- where Expr has a value known at compile time or is of the form Y'Address
+ -- or recursively is a reference to a constant initialized with either of
+ -- these forms, and the value of Expr is not a multiple of X's alignment,
+ -- or if Y has a smaller alignment than X, then that merits a warning about
-- possible bad alignment. The following table collects address clauses of
-- this kind. We put these in a table so that they can be checked after the
-- back end has completed annotation of the alignments of objects, since we
@@ -252,13 +327,16 @@ package body Sem_Ch13 is
-- The address clause
X : Entity_Id;
- -- The entity of the object overlaying Y
+ -- The entity of the object subject to the address clause
+
+ A : Uint;
+ -- The value of the address in the first case
Y : Entity_Id;
- -- The entity of the object being overlaid
+ -- The entity of the object being overlaid in the second case
Off : Boolean;
- -- Whether the address is offset within Y
+ -- Whether the address is offset within Y in the second case
end record;
package Address_Clause_Checks is new Table.Table (
@@ -274,375 +352,402 @@ package body Sem_Ch13 is
-----------------------------------------
procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id) is
- Comp : Node_Id;
- CC : Node_Id;
+ Max_Machine_Scalar_Size : constant Uint :=
+ UI_From_Int
+ (Standard_Long_Long_Integer_Size);
+ -- We use this as the maximum machine scalar size
- begin
- -- Processing depends on version of Ada
+ SSU : constant Uint := UI_From_Int (System_Storage_Unit);
- -- For Ada 95, we just renumber bits within a storage unit. We do the
- -- same for Ada 83 mode, since we recognize the Bit_Order attribute in
- -- Ada 83, and are free to add this extension.
+ CC : Node_Id;
+ Comp : Node_Id;
+ Num_CC : Natural;
- if Ada_Version < Ada_2005 then
- Comp := First_Component_Or_Discriminant (R);
- while Present (Comp) loop
- CC := Component_Clause (Comp);
+ begin
+ -- Processing here used to depend on Ada version: the behavior was
+ -- changed by AI95-0133. However this AI is a Binding interpretation,
+ -- so we now implement it even in Ada 95 mode. The original behavior
+ -- from unamended Ada 95 is still available for compatibility under
+ -- debugging switch -gnatd.
+
+ if Ada_Version < Ada_2005 and then Debug_Flag_Dot_P then
+ Adjust_Record_For_Reverse_Bit_Order_Ada_95 (R);
+ return;
+ end if;
- -- If component clause is present, then deal with the non-default
- -- bit order case for Ada 95 mode.
+ -- For Ada 2005, we do machine scalar processing, as fully described In
+ -- AI-133. This involves gathering all components which start at the
+ -- same byte offset and processing them together. Same approach is still
+ -- valid in later versions including Ada 2012.
- -- We only do this processing for the base type, and in fact that
- -- is important, since otherwise if there are record subtypes, we
- -- could reverse the bits once for each subtype, which is wrong.
+ -- This first loop through components does two things. First it deals
+ -- with the case of components with component clauses whose length is
+ -- greater than the maximum machine scalar size (either accepting them
+ -- or rejecting as needed). Second, it counts the number of components
+ -- with component clauses whose length does not exceed this maximum for
+ -- later processing.
- if Present (CC) and then Ekind (R) = E_Record_Type then
- declare
- CFB : constant Uint := Component_Bit_Offset (Comp);
- CSZ : constant Uint := Esize (Comp);
- CLC : constant Node_Id := Component_Clause (Comp);
- Pos : constant Node_Id := Position (CLC);
- FB : constant Node_Id := First_Bit (CLC);
+ Num_CC := 0;
+ Comp := First_Component_Or_Discriminant (R);
+ while Present (Comp) loop
+ CC := Component_Clause (Comp);
- Storage_Unit_Offset : constant Uint :=
- CFB / System_Storage_Unit;
+ if Present (CC) then
+ declare
+ Fbit : constant Uint := Static_Integer (First_Bit (CC));
+ Lbit : constant Uint := Static_Integer (Last_Bit (CC));
- Start_Bit : constant Uint :=
- CFB mod System_Storage_Unit;
+ begin
+ -- Case of component with last bit >= max machine scalar
- begin
- -- Cases where field goes over storage unit boundary
+ if Lbit >= Max_Machine_Scalar_Size then
- if Start_Bit + CSZ > System_Storage_Unit then
+ -- This is allowed only if first bit is zero, and last bit
+ -- + 1 is a multiple of storage unit size.
- -- Allow multi-byte field but generate warning
+ if Fbit = 0 and then (Lbit + 1) mod SSU = 0 then
- if Start_Bit mod System_Storage_Unit = 0
- and then CSZ mod System_Storage_Unit = 0
- then
+ -- This is the case to give a warning if enabled
+
+ if Warn_On_Reverse_Bit_Order then
Error_Msg_N
("info: multi-byte field specified with "
- & "non-standard Bit_Order?V?", CLC);
+ & "non-standard Bit_Order?V?", CC);
if Bytes_Big_Endian then
Error_Msg_N
("\bytes are not reversed "
- & "(component is big-endian)?V?", CLC);
+ & "(component is big-endian)?V?", CC);
else
Error_Msg_N
("\bytes are not reversed "
- & "(component is little-endian)?V?", CLC);
+ & "(component is little-endian)?V?", CC);
end if;
+ end if;
+
+ -- Give error message for RM 13.5.1(10) violation
+
+ else
+ Error_Msg_FE
+ ("machine scalar rules not followed for&",
+ First_Bit (CC), Comp);
+
+ Error_Msg_Uint_1 := Lbit + 1;
+ Error_Msg_Uint_2 := Max_Machine_Scalar_Size;
+ Error_Msg_F
+ ("\last bit + 1 (^) exceeds maximum machine scalar "
+ & "size (^)", First_Bit (CC));
- -- Do not allow non-contiguous field
+ if (Lbit + 1) mod SSU /= 0 then
+ Error_Msg_Uint_1 := SSU;
+ Error_Msg_F
+ ("\and is not a multiple of Storage_Unit (^) "
+ & "(RM 13.5.1(10))", First_Bit (CC));
else
- Error_Msg_N
- ("attempt to specify non-contiguous field "
- & "not permitted", CLC);
- Error_Msg_N
- ("\caused by non-standard Bit_Order "
- & "specified", CLC);
- Error_Msg_N
- ("\consider possibility of using "
- & "Ada 2005 mode here", CLC);
+ Error_Msg_Uint_1 := Fbit;
+ Error_Msg_F
+ ("\and first bit (^) is non-zero "
+ & "(RM 13.4.1(10))", First_Bit (CC));
end if;
+ end if;
- -- Case where field fits in one storage unit
+ -- OK case of machine scalar related component clause. For now,
+ -- just count them.
- else
- -- Give warning if suspicious component clause
+ else
+ Num_CC := Num_CC + 1;
+ end if;
+ end;
+ end if;
- if Intval (FB) >= System_Storage_Unit
- and then Warn_On_Reverse_Bit_Order
- then
- Error_Msg_N
- ("info: Bit_Order clause does not affect " &
- "byte ordering?V?", Pos);
- Error_Msg_Uint_1 :=
- Intval (Pos) + Intval (FB) /
- System_Storage_Unit;
- Error_Msg_N
- ("info: position normalized to ^ before bit " &
- "order interpreted?V?", Pos);
- end if;
+ Next_Component_Or_Discriminant (Comp);
+ end loop;
- -- Here is where we fix up the Component_Bit_Offset value
- -- to account for the reverse bit order. Some examples of
- -- what needs to be done are:
+ -- We need to sort the component clauses on the basis of the Position
+ -- values in the clause, so we can group clauses with the same Position
+ -- together to determine the relevant machine scalar size.
- -- First_Bit .. Last_Bit Component_Bit_Offset
- -- old new old new
+ Sort_CC : declare
+ Comps : array (0 .. Num_CC) of Entity_Id;
+ -- Array to collect component and discriminant entities. The data
+ -- starts at index 1, the 0'th entry is for the sort routine.
- -- 0 .. 0 7 .. 7 0 7
- -- 0 .. 1 6 .. 7 0 6
- -- 0 .. 2 5 .. 7 0 5
- -- 0 .. 7 0 .. 7 0 4
+ function CP_Lt (Op1, Op2 : Natural) return Boolean;
+ -- Compare routine for Sort
- -- 1 .. 1 6 .. 6 1 6
- -- 1 .. 4 3 .. 6 1 3
- -- 4 .. 7 0 .. 3 4 0
+ procedure CP_Move (From : Natural; To : Natural);
+ -- Move routine for Sort
- -- The rule is that the first bit is is obtained by
- -- subtracting the old ending bit from storage_unit - 1.
+ package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt);
- Set_Component_Bit_Offset
- (Comp,
- (Storage_Unit_Offset * System_Storage_Unit) +
- (System_Storage_Unit - 1) -
- (Start_Bit + CSZ - 1));
+ MaxL : Uint;
+ -- Maximum last bit value of any component in this set
- Set_Normalized_First_Bit
- (Comp,
- Component_Bit_Offset (Comp) mod
- System_Storage_Unit);
- end if;
- end;
- end if;
+ MSS : Uint;
+ -- Corresponding machine scalar size
- Next_Component_Or_Discriminant (Comp);
- end loop;
+ Start : Natural;
+ Stop : Natural;
+ -- Start and stop positions in the component list of the set of
+ -- components with the same starting position (that constitute
+ -- components in a single machine scalar).
- -- For Ada 2005, we do machine scalar processing, as fully described In
- -- AI-133. This involves gathering all components which start at the
- -- same byte offset and processing them together. Same approach is still
- -- valid in later versions including Ada 2012.
+ -----------
+ -- CP_Lt --
+ -----------
- else
- declare
- Max_Machine_Scalar_Size : constant Uint :=
- UI_From_Int
- (Standard_Long_Long_Integer_Size);
- -- We use this as the maximum machine scalar size
+ function CP_Lt (Op1, Op2 : Natural) return Boolean is
+ begin
+ return
+ Position (Component_Clause (Comps (Op1))) <
+ Position (Component_Clause (Comps (Op2)));
+ end CP_Lt;
- Num_CC : Natural;
- SSU : constant Uint := UI_From_Int (System_Storage_Unit);
+ -------------
+ -- CP_Move --
+ -------------
+ procedure CP_Move (From : Natural; To : Natural) is
begin
- -- This first loop through components does two things. First it
- -- deals with the case of components with component clauses whose
- -- length is greater than the maximum machine scalar size (either
- -- accepting them or rejecting as needed). Second, it counts the
- -- number of components with component clauses whose length does
- -- not exceed this maximum for later processing.
-
- Num_CC := 0;
- Comp := First_Component_Or_Discriminant (R);
- while Present (Comp) loop
- CC := Component_Clause (Comp);
+ Comps (To) := Comps (From);
+ end CP_Move;
- if Present (CC) then
- declare
- Fbit : constant Uint := Static_Integer (First_Bit (CC));
- Lbit : constant Uint := Static_Integer (Last_Bit (CC));
+ -- Start of processing for Sort_CC
- begin
- -- Case of component with last bit >= max machine scalar
+ begin
+ -- Collect the machine scalar relevant component clauses
- if Lbit >= Max_Machine_Scalar_Size then
+ Num_CC := 0;
+ Comp := First_Component_Or_Discriminant (R);
+ while Present (Comp) loop
+ declare
+ CC : constant Node_Id := Component_Clause (Comp);
- -- This is allowed only if first bit is zero, and
- -- last bit + 1 is a multiple of storage unit size.
+ begin
+ -- Collect only component clauses whose last bit is less than
+ -- machine scalar size. Any component clause whose last bit
+ -- exceeds this value does not take part in machine scalar
+ -- layout considerations. The test for Error_Posted makes sure
+ -- we exclude component clauses for which we already posted an
+ -- error.
+
+ if Present (CC)
+ and then not Error_Posted (Last_Bit (CC))
+ and then Static_Integer (Last_Bit (CC)) <
+ Max_Machine_Scalar_Size
+ then
+ Num_CC := Num_CC + 1;
+ Comps (Num_CC) := Comp;
+ end if;
+ end;
- if Fbit = 0 and then (Lbit + 1) mod SSU = 0 then
+ Next_Component_Or_Discriminant (Comp);
+ end loop;
- -- This is the case to give a warning if enabled
+ -- Sort by ascending position number
+
+ Sorting.Sort (Num_CC);
+
+ -- We now have all the components whose size does not exceed the max
+ -- machine scalar value, sorted by starting position. In this loop we
+ -- gather groups of clauses starting at the same position, to process
+ -- them in accordance with AI-133.
+
+ Stop := 0;
+ while Stop < Num_CC loop
+ Start := Stop + 1;
+ Stop := Start;
+ MaxL :=
+ Static_Integer
+ (Last_Bit (Component_Clause (Comps (Start))));
+ while Stop < Num_CC loop
+ if Static_Integer
+ (Position (Component_Clause (Comps (Stop + 1)))) =
+ Static_Integer
+ (Position (Component_Clause (Comps (Stop))))
+ then
+ Stop := Stop + 1;
+ MaxL :=
+ UI_Max
+ (MaxL,
+ Static_Integer
+ (Last_Bit
+ (Component_Clause (Comps (Stop)))));
+ else
+ exit;
+ end if;
+ end loop;
- if Warn_On_Reverse_Bit_Order then
- Error_Msg_N
- ("info: multi-byte field specified with "
- & " non-standard Bit_Order?V?", CC);
-
- if Bytes_Big_Endian then
- Error_Msg_N
- ("\bytes are not reversed "
- & "(component is big-endian)?V?", CC);
- else
- Error_Msg_N
- ("\bytes are not reversed "
- & "(component is little-endian)?V?", CC);
- end if;
- end if;
+ -- Now we have a group of component clauses from Start to Stop
+ -- whose positions are identical, and MaxL is the maximum last
+ -- bit value of any of these components.
- -- Give error message for RM 13.5.1(10) violation
+ -- We need to determine the corresponding machine scalar size.
+ -- This loop assumes that machine scalar sizes are even, and that
+ -- each possible machine scalar has twice as many bits as the next
+ -- smaller one.
- else
- Error_Msg_FE
- ("machine scalar rules not followed for&",
- First_Bit (CC), Comp);
+ MSS := Max_Machine_Scalar_Size;
+ while MSS mod 2 = 0
+ and then (MSS / 2) >= SSU
+ and then (MSS / 2) > MaxL
+ loop
+ MSS := MSS / 2;
+ end loop;
- Error_Msg_Uint_1 := Lbit + 1;
- Error_Msg_Uint_2 := Max_Machine_Scalar_Size;
- Error_Msg_F
- ("\last bit + 1 (^) exceeds maximum machine "
- & "scalar size (^)",
- First_Bit (CC));
+ -- Here is where we fix up the Component_Bit_Offset value to
+ -- account for the reverse bit order. Some examples of what needs
+ -- to be done for the case of a machine scalar size of 8 are:
- if (Lbit + 1) mod SSU /= 0 then
- Error_Msg_Uint_1 := SSU;
- Error_Msg_F
- ("\and is not a multiple of Storage_Unit (^) "
- & "(RM 13.5.1(10))",
- First_Bit (CC));
+ -- First_Bit .. Last_Bit Component_Bit_Offset
+ -- old new old new
- else
- Error_Msg_Uint_1 := Fbit;
- Error_Msg_F
- ("\and first bit (^) is non-zero "
- & "(RM 13.4.1(10))",
- First_Bit (CC));
- end if;
- end if;
+ -- 0 .. 0 7 .. 7 0 7
+ -- 0 .. 1 6 .. 7 0 6
+ -- 0 .. 2 5 .. 7 0 5
+ -- 0 .. 7 0 .. 7 0 4
- -- OK case of machine scalar related component clause,
- -- For now, just count them.
+ -- 1 .. 1 6 .. 6 1 6
+ -- 1 .. 4 3 .. 6 1 3
+ -- 4 .. 7 0 .. 3 4 0
- else
- Num_CC := Num_CC + 1;
- end if;
- end;
- end if;
+ -- The rule is that the first bit is obtained by subtracting the
+ -- old ending bit from machine scalar size - 1.
- Next_Component_Or_Discriminant (Comp);
- end loop;
+ for C in Start .. Stop loop
+ declare
+ Comp : constant Entity_Id := Comps (C);
+ CC : constant Node_Id := Component_Clause (Comp);
- -- We need to sort the component clauses on the basis of the
- -- Position values in the clause, so we can group clauses with
- -- the same Position together to determine the relevant machine
- -- scalar size.
+ LB : constant Uint := Static_Integer (Last_Bit (CC));
+ NFB : constant Uint := MSS - Uint_1 - LB;
+ NLB : constant Uint := NFB + Esize (Comp) - 1;
+ Pos : constant Uint := Static_Integer (Position (CC));
- Sort_CC : declare
- Comps : array (0 .. Num_CC) of Entity_Id;
- -- Array to collect component and discriminant entities. The
- -- data starts at index 1, the 0'th entry is for the sort
- -- routine.
+ begin
+ if Warn_On_Reverse_Bit_Order then
+ Error_Msg_Uint_1 := MSS;
+ Error_Msg_N
+ ("info: reverse bit order in machine scalar of "
+ & "length^?V?", First_Bit (CC));
+ Error_Msg_Uint_1 := NFB;
+ Error_Msg_Uint_2 := NLB;
- function CP_Lt (Op1, Op2 : Natural) return Boolean;
- -- Compare routine for Sort
+ if Bytes_Big_Endian then
+ Error_Msg_NE
+ ("\big-endian range for component & is ^ .. ^?V?",
+ First_Bit (CC), Comp);
+ else
+ Error_Msg_NE
+ ("\little-endian range for component & is ^ .. ^?V?",
+ First_Bit (CC), Comp);
+ end if;
+ end if;
- procedure CP_Move (From : Natural; To : Natural);
- -- Move routine for Sort
+ Set_Component_Bit_Offset (Comp, Pos * SSU + NFB);
+ Set_Normalized_First_Bit (Comp, NFB mod SSU);
+ end;
+ end loop;
+ end loop;
+ end Sort_CC;
+ end Adjust_Record_For_Reverse_Bit_Order;
- package Sorting is new GNAT.Heap_Sort_G (CP_Move, CP_Lt);
+ ------------------------------------------------
+ -- Adjust_Record_For_Reverse_Bit_Order_Ada_95 --
+ ------------------------------------------------
- Start : Natural;
- Stop : Natural;
- -- Start and stop positions in the component list of the set of
- -- components with the same starting position (that constitute
- -- components in a single machine scalar).
+ procedure Adjust_Record_For_Reverse_Bit_Order_Ada_95 (R : Entity_Id) is
+ CC : Node_Id;
+ Comp : Node_Id;
- MaxL : Uint;
- -- Maximum last bit value of any component in this set
+ begin
+ -- For Ada 95, we just renumber bits within a storage unit. We do the
+ -- same for Ada 83 mode, since we recognize the Bit_Order attribute in
+ -- Ada 83, and are free to add this extension.
- MSS : Uint;
- -- Corresponding machine scalar size
+ Comp := First_Component_Or_Discriminant (R);
+ while Present (Comp) loop
+ CC := Component_Clause (Comp);
- -----------
- -- CP_Lt --
- -----------
+ -- If component clause is present, then deal with the non-default
+ -- bit order case for Ada 95 mode.
- function CP_Lt (Op1, Op2 : Natural) return Boolean is
- begin
- return Position (Component_Clause (Comps (Op1))) <
- Position (Component_Clause (Comps (Op2)));
- end CP_Lt;
+ -- We only do this processing for the base type, and in fact that
+ -- is important, since otherwise if there are record subtypes, we
+ -- could reverse the bits once for each subtype, which is wrong.
- -------------
- -- CP_Move --
- -------------
+ if Present (CC) and then Ekind (R) = E_Record_Type then
+ declare
+ CFB : constant Uint := Component_Bit_Offset (Comp);
+ CSZ : constant Uint := Esize (Comp);
+ CLC : constant Node_Id := Component_Clause (Comp);
+ Pos : constant Node_Id := Position (CLC);
+ FB : constant Node_Id := First_Bit (CLC);
- procedure CP_Move (From : Natural; To : Natural) is
- begin
- Comps (To) := Comps (From);
- end CP_Move;
+ Storage_Unit_Offset : constant Uint :=
+ CFB / System_Storage_Unit;
- -- Start of processing for Sort_CC
+ Start_Bit : constant Uint :=
+ CFB mod System_Storage_Unit;
begin
- -- Collect the machine scalar relevant component clauses
+ -- Cases where field goes over storage unit boundary
- Num_CC := 0;
- Comp := First_Component_Or_Discriminant (R);
- while Present (Comp) loop
- declare
- CC : constant Node_Id := Component_Clause (Comp);
+ if Start_Bit + CSZ > System_Storage_Unit then
- begin
- -- Collect only component clauses whose last bit is less
- -- than machine scalar size. Any component clause whose
- -- last bit exceeds this value does not take part in
- -- machine scalar layout considerations. The test for
- -- Error_Posted makes sure we exclude component clauses
- -- for which we already posted an error.
-
- if Present (CC)
- and then not Error_Posted (Last_Bit (CC))
- and then Static_Integer (Last_Bit (CC)) <
- Max_Machine_Scalar_Size
- then
- Num_CC := Num_CC + 1;
- Comps (Num_CC) := Comp;
- end if;
- end;
+ -- Allow multi-byte field but generate warning
- Next_Component_Or_Discriminant (Comp);
- end loop;
+ if Start_Bit mod System_Storage_Unit = 0
+ and then CSZ mod System_Storage_Unit = 0
+ then
+ Error_Msg_N
+ ("info: multi-byte field specified with non-standard "
+ & "Bit_Order?V?", CLC);
- -- Sort by ascending position number
-
- Sorting.Sort (Num_CC);
-
- -- We now have all the components whose size does not exceed
- -- the max machine scalar value, sorted by starting position.
- -- In this loop we gather groups of clauses starting at the
- -- same position, to process them in accordance with AI-133.
-
- Stop := 0;
- while Stop < Num_CC loop
- Start := Stop + 1;
- Stop := Start;
- MaxL :=
- Static_Integer
- (Last_Bit (Component_Clause (Comps (Start))));
- while Stop < Num_CC loop
- if Static_Integer
- (Position (Component_Clause (Comps (Stop + 1)))) =
- Static_Integer
- (Position (Component_Clause (Comps (Stop))))
- then
- Stop := Stop + 1;
- MaxL :=
- UI_Max
- (MaxL,
- Static_Integer
- (Last_Bit
- (Component_Clause (Comps (Stop)))));
+ if Bytes_Big_Endian then
+ Error_Msg_N
+ ("\bytes are not reversed "
+ & "(component is big-endian)?V?", CLC);
else
- exit;
+ Error_Msg_N
+ ("\bytes are not reversed "
+ & "(component is little-endian)?V?", CLC);
end if;
- end loop;
- -- Now we have a group of component clauses from Start to
- -- Stop whose positions are identical, and MaxL is the
- -- maximum last bit value of any of these components.
-
- -- We need to determine the corresponding machine scalar
- -- size. This loop assumes that machine scalar sizes are
- -- even, and that each possible machine scalar has twice
- -- as many bits as the next smaller one.
-
- MSS := Max_Machine_Scalar_Size;
- while MSS mod 2 = 0
- and then (MSS / 2) >= SSU
- and then (MSS / 2) > MaxL
- loop
- MSS := MSS / 2;
- end loop;
+ -- Do not allow non-contiguous field
+
+ else
+ Error_Msg_N
+ ("attempt to specify non-contiguous field not "
+ & "permitted", CLC);
+ Error_Msg_N
+ ("\caused by non-standard Bit_Order specified in "
+ & "legacy Ada 95 mode", CLC);
+ end if;
+
+ -- Case where field fits in one storage unit
+
+ else
+ -- Give warning if suspicious component clause
+
+ if Intval (FB) >= System_Storage_Unit
+ and then Warn_On_Reverse_Bit_Order
+ then
+ Error_Msg_N
+ ("info: Bit_Order clause does not affect byte "
+ & "ordering?V?", Pos);
+ Error_Msg_Uint_1 :=
+ Intval (Pos) + Intval (FB) /
+ System_Storage_Unit;
+ Error_Msg_N
+ ("info: position normalized to ^ before bit order "
+ & "interpreted?V?", Pos);
+ end if;
-- Here is where we fix up the Component_Bit_Offset value
-- to account for the reverse bit order. Some examples of
- -- what needs to be done for the case of a machine scalar
- -- size of 8 are:
+ -- what needs to be done are:
-- First_Bit .. Last_Bit Component_Bit_Offset
-- old new old new
@@ -656,48 +761,23 @@ package body Sem_Ch13 is
-- 1 .. 4 3 .. 6 1 3
-- 4 .. 7 0 .. 3 4 0
- -- The rule is that the first bit is obtained by subtracting
- -- the old ending bit from machine scalar size - 1.
-
- for C in Start .. Stop loop
- declare
- Comp : constant Entity_Id := Comps (C);
- CC : constant Node_Id := Component_Clause (Comp);
-
- LB : constant Uint := Static_Integer (Last_Bit (CC));
- NFB : constant Uint := MSS - Uint_1 - LB;
- NLB : constant Uint := NFB + Esize (Comp) - 1;
- Pos : constant Uint := Static_Integer (Position (CC));
+ -- The rule is that the first bit is is obtained by
+ -- subtracting the old ending bit from storage_unit - 1.
- begin
- if Warn_On_Reverse_Bit_Order then
- Error_Msg_Uint_1 := MSS;
- Error_Msg_N
- ("info: reverse bit order in machine " &
- "scalar of length^?V?", First_Bit (CC));
- Error_Msg_Uint_1 := NFB;
- Error_Msg_Uint_2 := NLB;
+ Set_Component_Bit_Offset (Comp,
+ (Storage_Unit_Offset * System_Storage_Unit) +
+ (System_Storage_Unit - 1) -
+ (Start_Bit + CSZ - 1));
- if Bytes_Big_Endian then
- Error_Msg_NE
- ("\big-endian range for component "
- & "& is ^ .. ^?V?", First_Bit (CC), Comp);
- else
- Error_Msg_NE
- ("\little-endian range for component"
- & "& is ^ .. ^?V?", First_Bit (CC), Comp);
- end if;
- end if;
+ Set_Normalized_First_Bit (Comp,
+ Component_Bit_Offset (Comp) mod System_Storage_Unit);
+ end if;
+ end;
+ end if;
- Set_Component_Bit_Offset (Comp, Pos * SSU + NFB);
- Set_Normalized_First_Bit (Comp, NFB mod SSU);
- end;
- end loop;
- end loop;
- end Sort_CC;
- end;
- end if;
- end Adjust_Record_For_Reverse_Bit_Order;
+ Next_Component_Or_Discriminant (Comp);
+ end loop;
+ end Adjust_Record_For_Reverse_Bit_Order_Ada_95;
-------------------------------------
-- Alignment_Check_For_Size_Change --
@@ -723,10 +803,6 @@ package body Sem_Ch13 is
-------------------------------------
procedure Analyze_Aspects_At_Freeze_Point (E : Entity_Id) is
- ASN : Node_Id;
- A_Id : Aspect_Id;
- Ritem : Node_Id;
-
procedure Analyze_Aspect_Default_Value (ASN : Node_Id);
-- This routine analyzes an Aspect_Default_[Component_]Value denoted by
-- the aspect specification node ASN.
@@ -764,6 +840,7 @@ package body Sem_Ch13 is
----------------------------------
procedure Analyze_Aspect_Default_Value (ASN : Node_Id) is
+ A_Id : constant Aspect_Id := Get_Aspect_Id (ASN);
Ent : constant Entity_Id := Entity (ASN);
Expr : constant Node_Id := Expression (ASN);
Id : constant Node_Id := Identifier (ASN);
@@ -810,7 +887,8 @@ package body Sem_Ch13 is
---------------------------------
procedure Inherit_Delayed_Rep_Aspects (ASN : Node_Id) is
- P : constant Entity_Id := Entity (ASN);
+ A_Id : constant Aspect_Id := Get_Aspect_Id (ASN);
+ P : constant Entity_Id := Entity (ASN);
-- Entithy for parent type
N : Node_Id;
@@ -891,7 +969,9 @@ package body Sem_Ch13 is
-- Object_Size (also Size which also sets Object_Size)
- when Aspect_Object_Size | Aspect_Size =>
+ when Aspect_Object_Size
+ | Aspect_Size
+ =>
if not Has_Size_Clause (E)
and then
No (Get_Attribute_Definition_Clause
@@ -985,7 +1065,6 @@ package body Sem_Ch13 is
when others =>
pragma Assert (Aspect_Delay (A_Id) /= Rep_Aspect);
null;
-
end case;
end if;
end if;
@@ -1006,8 +1085,6 @@ package body Sem_Ch13 is
Expr : constant Node_Id := Expression (ASN);
Loc : constant Source_Ptr := Sloc (ASN);
- Prag : Node_Id;
-
procedure Check_False_Aspect_For_Derived_Type;
-- This procedure checks for the case of a false aspect for a derived
-- type, which improperly tries to cancel an aspect inherited from
@@ -1030,7 +1107,9 @@ package body Sem_Ch13 is
Par := Nearest_Ancestor (E);
case A_Id is
- when Aspect_Atomic | Aspect_Shared =>
+ when Aspect_Atomic
+ | Aspect_Shared
+ =>
if not Is_Atomic (Par) then
return;
end if;
@@ -1081,6 +1160,10 @@ package body Sem_Ch13 is
("derived type& inherits aspect%, cannot cancel", Expr, E);
end Check_False_Aspect_For_Derived_Type;
+ -- Local variables
+
+ Prag : Node_Id;
+
-- Start of processing for Make_Pragma_From_Boolean_Aspect
begin
@@ -1094,12 +1177,11 @@ package body Sem_Ch13 is
else
Prag :=
Make_Pragma (Loc,
+ Pragma_Identifier =>
+ Make_Identifier (Sloc (Ident), Chars (Ident)),
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Sloc (Ident),
- Expression => New_Occurrence_Of (Ent, Sloc (Ident)))),
-
- Pragma_Identifier =>
- Make_Identifier (Sloc (Ident), Chars (Ident)));
+ Expression => New_Occurrence_Of (Ent, Sloc (Ident)))));
Set_From_Aspect_Specification (Prag, True);
Set_Corresponding_Aspect (Prag, ASN);
@@ -1109,6 +1191,12 @@ package body Sem_Ch13 is
end if;
end Make_Pragma_From_Boolean_Aspect;
+ -- Local variables
+
+ A_Id : Aspect_Id;
+ ASN : Node_Id;
+ Ritem : Node_Id;
+
-- Start of processing for Analyze_Aspects_At_Freeze_Point
begin
@@ -1133,16 +1221,34 @@ package body Sem_Ch13 is
-- For aspects whose expression is an optional Boolean, make
-- the corresponding pragma at the freeze point.
- when Boolean_Aspects |
- Library_Unit_Aspects =>
- Make_Pragma_From_Boolean_Aspect (ASN);
+ when Boolean_Aspects
+ | Library_Unit_Aspects
+ =>
+ -- Aspects Export and Import require special handling.
+ -- Both are by definition Boolean and may benefit from
+ -- forward references, however their expressions are
+ -- treated as static. In addition, the syntax of their
+ -- corresponding pragmas requires extra "pieces" which
+ -- may also contain forward references. To account for
+ -- all of this, the corresponding pragma is created by
+ -- Analyze_Aspect_Export_Import, but is not analyzed as
+ -- the complete analysis must happen now.
+
+ if A_Id = Aspect_Export or else A_Id = Aspect_Import then
+ null;
+
+ -- Otherwise create a corresponding pragma
+
+ else
+ Make_Pragma_From_Boolean_Aspect (ASN);
+ end if;
-- Special handling for aspects that don't correspond to
-- pragmas/attributes.
- when Aspect_Default_Value |
- Aspect_Default_Component_Value =>
-
+ when Aspect_Default_Value
+ | Aspect_Default_Component_Value
+ =>
-- Do not inherit aspect for anonymous base type of a
-- scalar or array type, because they apply to the first
-- subtype of the type, and will be processed when that
@@ -1160,10 +1266,11 @@ package body Sem_Ch13 is
-- Ditto for iterator aspects, because the corresponding
-- attributes may not have been analyzed yet.
- when Aspect_Constant_Indexing |
- Aspect_Variable_Indexing |
- Aspect_Default_Iterator |
- Aspect_Iterator_Element =>
+ when Aspect_Constant_Indexing
+ | Aspect_Default_Iterator
+ | Aspect_Iterator_Element
+ | Aspect_Variable_Indexing
+ =>
Analyze (Expression (ASN));
if Etype (Expression (ASN)) = Any_Type then
@@ -1428,8 +1535,9 @@ package body Sem_Ch13 is
-- Insert pragmas/attribute definition clause after this node when no
-- delayed analysis is required.
- -- Start of processing for Analyze_Aspect_Specifications
+ -- Start of processing for Analyze_Aspect_Specifications
+ begin
-- The general processing involves building an attribute definition
-- clause or a pragma node that corresponds to the aspect. Then in order
-- to delay the evaluation of this aspect to the freeze point, we attach
@@ -1449,7 +1557,6 @@ package body Sem_Ch13 is
-- of visibility for the expression analysis. Thus, we just insert
-- the pragma after the node N.
- begin
pragma Assert (Present (L));
-- Loop through aspects
@@ -1471,8 +1578,14 @@ package body Sem_Ch13 is
-- Source location of expression, modified when we split PPC's. It
-- is set below when Expr is present.
- procedure Analyze_Aspect_External_Or_Link_Name;
- -- Perform analysis of the External_Name or Link_Name aspects
+ procedure Analyze_Aspect_Convention;
+ -- Perform analysis of aspect Convention
+
+ procedure Analyze_Aspect_Export_Import;
+ -- Perform analysis of aspects Export or Import
+
+ procedure Analyze_Aspect_External_Link_Name;
+ -- Perform analysis of aspects External_Name or Link_Name
procedure Analyze_Aspect_Implicit_Dereference;
-- Perform analysis of the Implicit_Dereference aspects
@@ -1489,35 +1602,199 @@ package body Sem_Ch13 is
-- True, and sets Corresponding_Aspect to point to the aspect.
-- The resulting pragma is assigned to Aitem.
- ------------------------------------------
- -- Analyze_Aspect_External_Or_Link_Name --
- ------------------------------------------
+ -------------------------------
+ -- Analyze_Aspect_Convention --
+ -------------------------------
+
+ procedure Analyze_Aspect_Convention is
+ Conv : Node_Id;
+ Dummy_1 : Node_Id;
+ Dummy_2 : Node_Id;
+ Dummy_3 : Node_Id;
+ Expo : Node_Id;
+ Imp : Node_Id;
- procedure Analyze_Aspect_External_Or_Link_Name is
begin
- -- Verify that there is an Import/Export aspect defined for the
- -- entity. The processing of that aspect in turn checks that
- -- there is a Convention aspect declared. The pragma is
- -- constructed when processing the Convention aspect.
+ -- Obtain all interfacing aspects that apply to the related
+ -- entity.
+
+ Get_Interfacing_Aspects
+ (Iface_Asp => Aspect,
+ Conv_Asp => Dummy_1,
+ EN_Asp => Dummy_2,
+ Expo_Asp => Expo,
+ Imp_Asp => Imp,
+ LN_Asp => Dummy_3,
+ Do_Checks => True);
+
+ -- The related entity is subject to aspect Export or Import.
+ -- Do not process Convention now because it must be analysed
+ -- as part of Export or Import.
+
+ if Present (Expo) or else Present (Imp) then
+ return;
- declare
- A : Node_Id;
+ -- Otherwise Convention appears by itself
- begin
- A := First (L);
- while Present (A) loop
- exit when Nam_In (Chars (Identifier (A)), Name_Export,
- Name_Import);
- Next (A);
- end loop;
+ else
+ -- The aspect specifies a particular convention
+
+ if Present (Expr) then
+ Conv := New_Copy_Tree (Expr);
+
+ -- Otherwise assume convention Ada
+
+ else
+ Conv := Make_Identifier (Loc, Name_Ada);
+ end if;
+
+ -- Generate:
+ -- pragma Convention (<Conv>, <E>);
+
+ Make_Aitem_Pragma
+ (Pragma_Name => Name_Convention,
+ Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Loc,
+ Expression => Conv),
+ Make_Pragma_Argument_Association (Loc,
+ Expression => New_Occurrence_Of (E, Loc))));
+
+ Decorate (Aspect, Aitem);
+ Insert_Pragma (Aitem);
+ end if;
+ end Analyze_Aspect_Convention;
+
+ ----------------------------------
+ -- Analyze_Aspect_Export_Import --
+ ----------------------------------
+
+ procedure Analyze_Aspect_Export_Import is
+ Dummy_1 : Node_Id;
+ Dummy_2 : Node_Id;
+ Dummy_3 : Node_Id;
+ Expo : Node_Id;
+ Imp : Node_Id;
+
+ begin
+ -- Obtain all interfacing aspects that apply to the related
+ -- entity.
+
+ Get_Interfacing_Aspects
+ (Iface_Asp => Aspect,
+ Conv_Asp => Dummy_1,
+ EN_Asp => Dummy_2,
+ Expo_Asp => Expo,
+ Imp_Asp => Imp,
+ LN_Asp => Dummy_3,
+ Do_Checks => True);
+
+ -- The related entity cannot be subject to both aspects Export
+ -- and Import.
+
+ if Present (Expo) and then Present (Imp) then
+ Error_Msg_N
+ ("incompatible interfacing aspects given for &", E);
+ Error_Msg_Sloc := Sloc (Expo);
+ Error_Msg_N ("\aspect `Export` #", E);
+ Error_Msg_Sloc := Sloc (Imp);
+ Error_Msg_N ("\aspect `Import` #", E);
+ end if;
+
+ -- A variable is most likely modified from the outside. Take
+ -- Take the optimistic approach to avoid spurious errors.
+
+ if Ekind (E) = E_Variable then
+ Set_Never_Set_In_Source (E, False);
+ end if;
+
+ -- Resolve the expression of an Import or Export here, and
+ -- require it to be of type Boolean and static. This is not
+ -- quite right, because in general this should be delayed,
+ -- but that seems tricky for these, because normally Boolean
+ -- aspects are replaced with pragmas at the freeze point in
+ -- Make_Pragma_From_Boolean_Aspect.
+
+ if not Present (Expr)
+ or else Is_True (Static_Boolean (Expr))
+ then
+ if A_Id = Aspect_Import then
+ Set_Has_Completion (E);
+ Set_Is_Imported (E);
+
+ -- An imported object cannot be explicitly initialized
+
+ if Nkind (N) = N_Object_Declaration
+ and then Present (Expression (N))
+ then
+ Error_Msg_N
+ ("imported entities cannot be initialized "
+ & "(RM B.1(24))", Expression (N));
+ end if;
+
+ else
+ pragma Assert (A_Id = Aspect_Export);
+ Set_Is_Exported (E);
+ end if;
+
+ -- Create the proper form of pragma Export or Import taking
+ -- into account Conversion, External_Name, and Link_Name.
- if No (A) then
+ Aitem := Build_Export_Import_Pragma (Aspect, E);
+
+ -- Otherwise the expression is either False or erroneous. There
+ -- is no corresponding pragma.
+
+ else
+ Aitem := Empty;
+ end if;
+ end Analyze_Aspect_Export_Import;
+
+ ---------------------------------------
+ -- Analyze_Aspect_External_Link_Name --
+ ---------------------------------------
+
+ procedure Analyze_Aspect_External_Link_Name is
+ Dummy_1 : Node_Id;
+ Dummy_2 : Node_Id;
+ Dummy_3 : Node_Id;
+ Expo : Node_Id;
+ Imp : Node_Id;
+
+ begin
+ -- Obtain all interfacing aspects that apply to the related
+ -- entity.
+
+ Get_Interfacing_Aspects
+ (Iface_Asp => Aspect,
+ Conv_Asp => Dummy_1,
+ EN_Asp => Dummy_2,
+ Expo_Asp => Expo,
+ Imp_Asp => Imp,
+ LN_Asp => Dummy_3,
+ Do_Checks => True);
+
+ -- Ensure that aspect External_Name applies to aspect Export or
+ -- Import.
+
+ if A_Id = Aspect_External_Name then
+ if No (Expo) and then No (Imp) then
Error_Msg_N
- ("missing Import/Export for Link/External name",
- Aspect);
+ ("aspect `External_Name` requires aspect `Import` or "
+ & "`Export`", Aspect);
end if;
- end;
- end Analyze_Aspect_External_Or_Link_Name;
+
+ -- Otherwise ensure that aspect Link_Name applies to aspect
+ -- Export or Import.
+
+ else
+ pragma Assert (A_Id = Aspect_Link_Name);
+ if No (Expo) and then No (Imp) then
+ Error_Msg_N
+ ("aspect `Link_Name` requires aspect `Import` or "
+ & "`Export`", Aspect);
+ end if;
+ end if;
+ end Analyze_Aspect_External_Link_Name;
-----------------------------------------
-- Analyze_Aspect_Implicit_Dereference --
@@ -1537,11 +1814,17 @@ package body Sem_Ch13 is
("aspect must name a discriminant of current type", Expr);
else
+ -- Discriminant type be an anonymous access type or an
+ -- anonymous access to subprogram.
+
+ -- Missing synchronized types???
+
Disc := First_Discriminant (E);
while Present (Disc) loop
if Chars (Expr) = Chars (Disc)
- and then Ekind (Etype (Disc)) =
- E_Anonymous_Access_Type
+ and then Ekind_In (Etype (Disc),
+ E_Anonymous_Access_Subprogram_Type,
+ E_Anonymous_Access_Type)
then
Set_Has_Implicit_Dereference (E);
Set_Has_Implicit_Dereference (Disc);
@@ -1554,8 +1837,7 @@ package body Sem_Ch13 is
-- Error if no proper access discriminant
if No (Disc) then
- Error_Msg_NE
- ("not an access discriminant of&", Expr, E);
+ Error_Msg_NE ("not an access discriminant of&", Expr, E);
return;
end if;
end if;
@@ -1571,8 +1853,9 @@ package body Sem_Ch13 is
if Present (Parent_Disc)
and then Corresponding_Discriminant (Disc) /= Parent_Disc
then
- Error_Msg_N ("reference discriminant does not match " &
- "discriminant of parent type", Expr);
+ Error_Msg_N
+ ("reference discriminant does not match discriminant "
+ & "of parent type", Expr);
end if;
end if;
end Analyze_Aspect_Implicit_Dereference;
@@ -1667,8 +1950,25 @@ package body Sem_Ch13 is
Set_Analyzed (Aspect);
Set_Entity (Aspect, E);
+
+ -- Build the reference to E that will be used in the built pragmas
+
Ent := New_Occurrence_Of (E, Sloc (Id));
+ if A_Id = Aspect_Attach_Handler
+ or else A_Id = Aspect_Interrupt_Handler
+ then
+ -- Decorate the reference as comming from the sources and force
+ -- its reanalysis to generate the reference to E; required to
+ -- avoid reporting spurious warning on E as unreferenced entity
+ -- (because aspects are not fully analyzed).
+
+ Set_Comes_From_Source (Ent, Comes_From_Source (Id));
+ Set_Entity (Ent, Empty);
+
+ Analyze (Ent);
+ end if;
+
-- Check for duplicate aspect. Note that the Comes_From_Source
-- test allows duplicate Pre/Post's that we generate internally
-- to escape being flagged here.
@@ -1706,9 +2006,11 @@ package body Sem_Ch13 is
if not Implementation_Defined_Aspect (A_Id) then
Error_Msg_Name_1 := Nam;
- -- Not allowed for renaming declarations
+ -- Not allowed for renaming declarations. Examine the original
+ -- node because a subprogram renaming may have been rewritten
+ -- as a body.
- if Nkind (N) in N_Renaming_Declaration then
+ if Nkind (Original_Node (N)) in N_Renaming_Declaration then
Error_Msg_N
("aspect % not allowed for renaming declaration",
Aspect);
@@ -1748,9 +2050,12 @@ package body Sem_Ch13 is
if A_Id in Boolean_Aspects and then No (Expr) then
Delay_Required := False;
- -- For non-Boolean aspects, don't delay if integer literal
+ -- For non-Boolean aspects, don't delay if integer literal,
+ -- unless the aspect is Alignment, which affects the
+ -- freezing of an initialized object.
elsif A_Id not in Boolean_Aspects
+ and then A_Id /= Aspect_Alignment
and then Present (Expr)
and then Nkind (Expr) = N_Integer_Literal
then
@@ -1778,31 +2083,32 @@ package body Sem_Ch13 is
-- Case 1: Aspects corresponding to attribute definition
-- clauses.
- when Aspect_Address |
- Aspect_Alignment |
- Aspect_Bit_Order |
- Aspect_Component_Size |
- Aspect_Constant_Indexing |
- Aspect_Default_Iterator |
- Aspect_Dispatching_Domain |
- Aspect_External_Tag |
- Aspect_Input |
- Aspect_Iterable |
- Aspect_Iterator_Element |
- Aspect_Machine_Radix |
- Aspect_Object_Size |
- Aspect_Output |
- Aspect_Read |
- Aspect_Scalar_Storage_Order |
- Aspect_Size |
- Aspect_Small |
- Aspect_Simple_Storage_Pool |
- Aspect_Storage_Pool |
- Aspect_Stream_Size |
- Aspect_Value_Size |
- Aspect_Variable_Indexing |
- Aspect_Write =>
-
+ when Aspect_Address
+ | Aspect_Alignment
+ | Aspect_Bit_Order
+ | Aspect_Component_Size
+ | Aspect_Constant_Indexing
+ | Aspect_Default_Iterator
+ | Aspect_Dispatching_Domain
+ | Aspect_External_Tag
+ | Aspect_Input
+ | Aspect_Iterable
+ | Aspect_Iterator_Element
+ | Aspect_Machine_Radix
+ | Aspect_Object_Size
+ | Aspect_Output
+ | Aspect_Read
+ | Aspect_Scalar_Storage_Order
+ | Aspect_Secondary_Stack_Size
+ | Aspect_Simple_Storage_Pool
+ | Aspect_Size
+ | Aspect_Small
+ | Aspect_Storage_Pool
+ | Aspect_Stream_Size
+ | Aspect_Value_Size
+ | Aspect_Variable_Indexing
+ | Aspect_Write
+ =>
-- Indexing aspects apply only to tagged type
if (A_Id = Aspect_Constant_Indexing
@@ -1883,10 +2189,10 @@ package body Sem_Ch13 is
-- Linker_Section/Suppress/Unsuppress
- when Aspect_Linker_Section |
- Aspect_Suppress |
- Aspect_Unsuppress =>
-
+ when Aspect_Linker_Section
+ | Aspect_Suppress
+ | Aspect_Unsuppress
+ =>
Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
@@ -1927,10 +2233,10 @@ package body Sem_Ch13 is
-- Dynamic_Predicate, Predicate, Static_Predicate
- when Aspect_Dynamic_Predicate |
- Aspect_Predicate |
- Aspect_Static_Predicate =>
-
+ when Aspect_Dynamic_Predicate
+ | Aspect_Predicate
+ | Aspect_Static_Predicate
+ =>
-- These aspects apply only to subtypes
if not Is_Type (E) then
@@ -1965,6 +2271,13 @@ package body Sem_Ch13 is
if A_Id = Aspect_Dynamic_Predicate then
Set_Has_Dynamic_Predicate_Aspect (E);
+
+ -- If the entity has a dynamic predicate, any inherited
+ -- static predicate becomes dynamic as well, and the
+ -- predicate function includes the conjunction of both.
+
+ Set_Has_Static_Predicate_Aspect (E, False);
+
elsif A_Id = Aspect_Static_Predicate then
Set_Has_Static_Predicate_Aspect (E);
end if;
@@ -2033,101 +2346,17 @@ package body Sem_Ch13 is
-- Convention
- when Aspect_Convention =>
-
- -- The aspect may be part of the specification of an import
- -- or export pragma. Scan the aspect list to gather the
- -- other components, if any. The name of the generated
- -- pragma is one of Convention/Import/Export.
-
- declare
- Args : constant List_Id := New_List (
- Make_Pragma_Argument_Association (Sloc (Expr),
- Expression => Relocate_Node (Expr)),
- Make_Pragma_Argument_Association (Sloc (Ent),
- Expression => Ent));
-
- Imp_Exp_Seen : Boolean := False;
- -- Flag set when aspect Import or Export has been seen
-
- Imp_Seen : Boolean := False;
- -- Flag set when aspect Import has been seen
-
- Asp : Node_Id;
- Asp_Nam : Name_Id;
- Extern_Arg : Node_Id;
- Link_Arg : Node_Id;
- Prag_Nam : Name_Id;
-
- begin
- Extern_Arg := Empty;
- Link_Arg := Empty;
- Prag_Nam := Chars (Id);
-
- Asp := First (L);
- while Present (Asp) loop
- Asp_Nam := Chars (Identifier (Asp));
-
- -- Aspects Import and Export take precedence over
- -- aspect Convention. As a result the generated pragma
- -- must carry the proper interfacing aspect's name.
-
- if Nam_In (Asp_Nam, Name_Import, Name_Export) then
- if Imp_Exp_Seen then
- Error_Msg_N ("conflicting", Asp);
- else
- Imp_Exp_Seen := True;
-
- if Asp_Nam = Name_Import then
- Imp_Seen := True;
- end if;
- end if;
-
- Prag_Nam := Asp_Nam;
-
- -- Aspect External_Name adds an extra argument to the
- -- generated pragma.
-
- elsif Asp_Nam = Name_External_Name then
- Extern_Arg :=
- Make_Pragma_Argument_Association (Loc,
- Chars => Asp_Nam,
- Expression => Relocate_Node (Expression (Asp)));
-
- -- Aspect Link_Name adds an extra argument to the
- -- generated pragma.
-
- elsif Asp_Nam = Name_Link_Name then
- Link_Arg :=
- Make_Pragma_Argument_Association (Loc,
- Chars => Asp_Nam,
- Expression => Relocate_Node (Expression (Asp)));
- end if;
-
- Next (Asp);
- end loop;
-
- -- Assemble the full argument list
-
- if Present (Extern_Arg) then
- Append_To (Args, Extern_Arg);
- end if;
-
- if Present (Link_Arg) then
- Append_To (Args, Link_Arg);
- end if;
-
- Make_Aitem_Pragma
- (Pragma_Argument_Associations => Args,
- Pragma_Name => Prag_Nam);
+ when Aspect_Convention =>
+ Analyze_Aspect_Convention;
+ goto Continue;
- -- Store the generated pragma Import in the related
- -- subprogram.
+ -- External_Name, Link_Name
- if Imp_Seen and then Is_Subprogram (E) then
- Set_Import_Pragma (E, Aitem);
- end if;
- end;
+ when Aspect_External_Name
+ | Aspect_Link_Name
+ =>
+ Analyze_Aspect_External_Link_Name;
+ goto Continue;
-- CPU, Interrupt_Priority, Priority
@@ -2144,10 +2373,10 @@ package body Sem_Ch13 is
-- to duplicate than to translate the aspect in the spec into
-- a pragma in the declarative part of the body.
- when Aspect_CPU |
- Aspect_Interrupt_Priority |
- Aspect_Priority =>
-
+ when Aspect_CPU
+ | Aspect_Interrupt_Priority
+ | Aspect_Priority
+ =>
if Nkind_In (N, N_Subprogram_Body,
N_Subprogram_Declaration)
then
@@ -2244,7 +2473,7 @@ package body Sem_Ch13 is
end if;
end;
- -- Handling for these Aspects in subprograms is complete
+ -- Handling for these aspects in subprograms is complete
goto Continue;
@@ -2282,9 +2511,9 @@ package body Sem_Ch13 is
-- Invariant, Type_Invariant
- when Aspect_Invariant |
- Aspect_Type_Invariant =>
-
+ when Aspect_Invariant
+ | Aspect_Type_Invariant
+ =>
-- Analysis of the pragma will verify placement legality:
-- an invariant must apply to a private type, or appear in
-- the private part of a spec and apply to a completion.
@@ -2639,6 +2868,19 @@ package body Sem_Ch13 is
goto Continue;
end Initializes;
+ -- Max_Queue_Length
+
+ when Aspect_Max_Queue_Length =>
+ Make_Aitem_Pragma
+ (Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Loc,
+ Expression => Relocate_Node (Expr))),
+ Pragma_Name => Name_Max_Queue_Length);
+
+ Decorate (Aspect, Aitem);
+ Insert_Pragma (Aitem);
+ goto Continue;
+
-- Obsolescent
when Aspect_Obsolescent => declare
@@ -2930,8 +3172,9 @@ package body Sem_Ch13 is
if not (Is_Array_Type (E)
and then Is_Scalar_Type (Component_Type (E)))
then
- Error_Msg_N ("aspect Default_Component_Value can only "
- & "apply to an array of scalar components", N);
+ Error_Msg_N
+ ("aspect Default_Component_Value can only apply to an "
+ & "array of scalar components", N);
end if;
Aitem := Empty;
@@ -2949,13 +3192,6 @@ package body Sem_Ch13 is
Analyze_Aspect_Implicit_Dereference;
goto Continue;
- -- External_Name, Link_Name
-
- when Aspect_External_Name |
- Aspect_Link_Name =>
- Analyze_Aspect_External_Or_Link_Name;
- goto Continue;
-
-- Dimension
when Aspect_Dimension =>
@@ -2992,6 +3228,24 @@ package body Sem_Ch13 is
Pname := Name_Postcondition;
end if;
+ -- Check that the class-wide predicate cannot be applied to
+ -- an operation of a synchronized type that is not a tagged
+ -- type. Other legality checks are performed when analyzing
+ -- the contract of the operation.
+
+ if Class_Present (Aspect)
+ and then Is_Concurrent_Type (Current_Scope)
+ and then not Is_Tagged_Type (Current_Scope)
+ and then Ekind_In (E, E_Entry, E_Function, E_Procedure)
+ then
+ Error_Msg_Name_1 := Original_Aspect_Pragma_Name (Aspect);
+ Error_Msg_N
+ ("aspect % can only be specified for a primitive "
+ & "operation of a tagged type", Aspect);
+
+ goto Continue;
+ end if;
+
-- If the expressions is of the form A and then B, then
-- we generate separate Pre/Post aspects for the separate
-- clauses. Since we allow multiple pragmas, there is no
@@ -3149,9 +3403,9 @@ package body Sem_Ch13 is
-- generated yet because the evaluation of the boolean needs
-- to be delayed till the freeze point.
- when Boolean_Aspects |
- Library_Unit_Aspects =>
-
+ when Boolean_Aspects
+ | Library_Unit_Aspects
+ =>
Set_Is_Boolean_Aspect (Aspect);
-- Lock_Free aspect only apply to protected objects
@@ -3180,61 +3434,8 @@ package body Sem_Ch13 is
goto Continue;
- elsif A_Id = Aspect_Import or else A_Id = Aspect_Export then
-
- -- For the case of aspects Import and Export, we don't
- -- consider that we know the entity is never set in the
- -- source, since it is is likely modified outside the
- -- program.
-
- -- Note: one might think that the analysis of the
- -- resulting pragma would take care of that, but
- -- that's not the case since it won't be from source.
-
- if Ekind (E) = E_Variable then
- Set_Never_Set_In_Source (E, False);
- end if;
-
- -- In older versions of Ada the corresponding pragmas
- -- specified a Convention. In Ada 2012 the convention is
- -- specified as a separate aspect, and it is optional,
- -- given that it defaults to Convention_Ada. The code
- -- that verifed that there was a matching convention
- -- is now obsolete.
-
- -- Resolve the expression of an Import or Export here,
- -- and require it to be of type Boolean and static. This
- -- is not quite right, because in general this should be
- -- delayed, but that seems tricky for these, because
- -- normally Boolean aspects are replaced with pragmas at
- -- the freeze point (in Make_Pragma_From_Boolean_Aspect),
- -- but in the case of these aspects we can't generate
- -- a simple pragma with just the entity name. ???
-
- if not Present (Expr)
- or else Is_True (Static_Boolean (Expr))
- then
- if A_Id = Aspect_Import then
- Set_Is_Imported (E);
- Set_Has_Completion (E);
-
- -- An imported entity cannot have an explicit
- -- initialization.
-
- if Nkind (N) = N_Object_Declaration
- and then Present (Expression (N))
- then
- Error_Msg_N
- ("imported entities cannot be initialized "
- & "(RM B.1(24))", Expression (N));
- end if;
-
- elsif A_Id = Aspect_Export then
- Set_Is_Exported (E);
- end if;
- end if;
-
- goto Continue;
+ elsif A_Id = Aspect_Export or else A_Id = Aspect_Import then
+ Analyze_Aspect_Export_Import;
-- Disable_Controlled
@@ -3295,11 +3496,20 @@ package body Sem_Ch13 is
-- expression is missing other than the above cases.
if not Delay_Required or else No (Expr) then
- Make_Aitem_Pragma
- (Pragma_Argument_Associations => New_List (
- Make_Pragma_Argument_Association (Sloc (Ent),
- Expression => Ent)),
- Pragma_Name => Chars (Id));
+
+ -- Exclude aspects Export and Import because their pragma
+ -- syntax does not map directly to a Boolean aspect.
+
+ if A_Id /= Aspect_Export
+ and then A_Id /= Aspect_Import
+ then
+ Make_Aitem_Pragma
+ (Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Sloc (Ent),
+ Expression => Ent)),
+ Pragma_Name => Chars (Id));
+ end if;
+
Delay_Required := False;
-- In general cases, the corresponding pragma/attribute
@@ -3499,7 +3709,7 @@ package body Sem_Ch13 is
-- unit, we simply insert the pragma/attribute definition clause
-- in sequence.
- else
+ elsif Present (Aitem) then
Insert_After (Ins_Node, Aitem);
Ins_Node := Aitem;
end if;
@@ -3707,8 +3917,8 @@ package body Sem_Ch13 is
U_Ent : Entity_Id;
-- The underlying entity to which the attribute applies. Generally this
-- is the Underlying_Type of Ent, except in the case where the clause
- -- applies to full view of incomplete type or private type in which case
- -- U_Ent is just a copy of Ent.
+ -- applies to the full view of an incomplete or private type, in which
+ -- case U_Ent is just a copy of Ent.
FOnly : Boolean := False;
-- Reset to True for subtype specific attribute (Alignment, Size)
@@ -3752,21 +3962,27 @@ package body Sem_Ch13 is
Pnam : Entity_Id;
Is_Read : constant Boolean := (TSS_Nam = TSS_Stream_Read);
- -- True for Read attribute, false for other attributes
+ -- True for Read attribute, False for other attributes
- function Has_Good_Profile (Subp : Entity_Id) return Boolean;
+ function Has_Good_Profile
+ (Subp : Entity_Id;
+ Report : Boolean := False) return Boolean;
-- Return true if the entity is a subprogram with an appropriate
- -- profile for the attribute being defined.
+ -- profile for the attribute being defined. If result is False and
+ -- Report is True, function emits appropriate error.
----------------------
-- Has_Good_Profile --
----------------------
- function Has_Good_Profile (Subp : Entity_Id) return Boolean is
- F : Entity_Id;
- Is_Function : constant Boolean := (TSS_Nam = TSS_Stream_Input);
+ function Has_Good_Profile
+ (Subp : Entity_Id;
+ Report : Boolean := False) return Boolean
+ is
Expected_Ekind : constant array (Boolean) of Entity_Kind :=
(False => E_Procedure, True => E_Function);
+ Is_Function : constant Boolean := (TSS_Nam = TSS_Stream_Input);
+ F : Entity_Id;
Typ : Entity_Id;
begin
@@ -3779,7 +3995,7 @@ package body Sem_Ch13 is
if No (F)
or else Ekind (Etype (F)) /= E_Anonymous_Access_Type
or else Designated_Type (Etype (F)) /=
- Class_Wide_Type (RTE (RE_Root_Stream_Type))
+ Class_Wide_Type (RTE (RE_Root_Stream_Type))
then
return False;
end if;
@@ -3829,14 +4045,19 @@ package body Sem_Ch13 is
return False;
end if;
- if Present ((Next_Formal (F)))
- then
+ if Present (Next_Formal (F)) then
return False;
elsif not Is_Scalar_Type (Typ)
and then not Is_First_Subtype (Typ)
and then not Is_Class_Wide_Type (Typ)
then
+ if Report and not Is_First_Subtype (Typ) then
+ Error_Msg_N
+ ("subtype of formal in stream operation must be a first "
+ & "subtype", Parameter_Type (Parent (F)));
+ end if;
+
return False;
else
@@ -3885,7 +4106,7 @@ package body Sem_Ch13 is
if Is_Entity_Name (Expr) then
if not Is_Overloaded (Expr) then
- if Has_Good_Profile (Entity (Expr)) then
+ if Has_Good_Profile (Entity (Expr), Report => True) then
Subp := Entity (Expr);
end if;
@@ -3908,7 +4129,8 @@ package body Sem_Ch13 is
return;
-- A stream subprogram for an interface type must be a null
- -- procedure (RM 13.13.2 (38/3)).
+ -- procedure (RM 13.13.2 (38/3)). Note that the class-wide type
+ -- of an interface is not an interface type (3.9.4 (6.b/2)).
elsif Is_Interface (U_Ent)
and then not Is_Class_Wide_Type (U_Ent)
@@ -3921,8 +4143,8 @@ package body Sem_Ch13 is
(Unit_Declaration_Node (Ultimate_Alias (Subp)))))
then
Error_Msg_N
- ("stream subprogram for interface type "
- & "must be null procedure", Expr);
+ ("stream subprogram for interface type must be null "
+ & "procedure", Expr);
end if;
Set_Entity (Expr, Subp);
@@ -4199,11 +4421,22 @@ package body Sem_Ch13 is
----------------------------
function Valid_Default_Iterator (Subp : Entity_Id) return Boolean is
+ Root_T : constant Entity_Id := Root_Type (Etype (Etype (Subp)));
Formal : Entity_Id;
begin
if not Check_Primitive_Function (Subp) then
return False;
+
+ -- The return type must be derived from a type in an instance
+ -- of Iterator.Interfaces, and thus its root type must have a
+ -- predefined name.
+
+ elsif Chars (Root_T) /= Name_Forward_Iterator
+ and then Chars (Root_T) /= Name_Reversible_Iterator
+ then
+ return False;
+
else
Formal := First_Formal (Subp);
end if;
@@ -4286,6 +4519,9 @@ package body Sem_Ch13 is
if Present (Default) then
Set_Entity (Expr, Default);
Set_Is_Overloaded (Expr, False);
+ else
+ Error_Msg_N
+ ("no interpretation is a valid default iterator!", Expr);
end if;
end;
end if;
@@ -4384,6 +4620,8 @@ package body Sem_Ch13 is
Set_Analyzed (N, True);
end if;
+ Check_Restriction_No_Use_Of_Attribute (N);
+
-- Ignore some selected attributes in CodePeer mode since they are not
-- relevant in this context.
@@ -4413,15 +4651,16 @@ package body Sem_Ch13 is
-- affect legality (except possibly to be rejected because they
-- are incompatible with the compilation target).
- when Attribute_Alignment |
- Attribute_Bit_Order |
- Attribute_Component_Size |
- Attribute_Machine_Radix |
- Attribute_Object_Size |
- Attribute_Size |
- Attribute_Small |
- Attribute_Stream_Size |
- Attribute_Value_Size =>
+ when Attribute_Alignment
+ | Attribute_Bit_Order
+ | Attribute_Component_Size
+ | Attribute_Machine_Radix
+ | Attribute_Object_Size
+ | Attribute_Size
+ | Attribute_Small
+ | Attribute_Stream_Size
+ | Attribute_Value_Size
+ =>
Kill_Rep_Clause (N);
return;
@@ -4431,14 +4670,15 @@ package body Sem_Ch13 is
-- legality, e.g. failing to provide a stream attribute for a type
-- may make a program illegal.
- when Attribute_External_Tag |
- Attribute_Input |
- Attribute_Output |
- Attribute_Read |
- Attribute_Simple_Storage_Pool |
- Attribute_Storage_Pool |
- Attribute_Storage_Size |
- Attribute_Write =>
+ when Attribute_External_Tag
+ | Attribute_Input
+ | Attribute_Output
+ | Attribute_Read
+ | Attribute_Simple_Storage_Pool
+ | Attribute_Storage_Pool
+ | Attribute_Storage_Size
+ | Attribute_Write
+ =>
null;
-- We do not do anything here with address clauses, they will be
@@ -4569,7 +4809,6 @@ package body Sem_Ch13 is
end if;
Set_Entity (N, U_Ent);
- Check_Restriction_No_Use_Of_Attribute (N);
-- Switch on particular attribute
@@ -4620,9 +4859,8 @@ package body Sem_Ch13 is
elsif Is_Subprogram (U_Ent) then
if Has_Homonym (U_Ent) then
Error_Msg_N
- ("address clause cannot be given " &
- "for overloaded subprogram",
- Nam);
+ ("address clause cannot be given for overloaded "
+ & "subprogram", Nam);
return;
end if;
@@ -4664,20 +4902,33 @@ package body Sem_Ch13 is
if Warn_On_Obsolescent_Feature then
Error_Msg_N
- ("?j?attaching interrupt to task entry is an " &
- "obsolescent feature (RM J.7.1)", N);
+ ("?j?attaching interrupt to task entry is an obsolescent "
+ & "feature (RM J.7.1)", N);
Error_Msg_N
("\?j?use interrupt procedure instead", N);
end if;
- -- Case of an address clause for a controlled object which we
+ -- Case of an address clause for a controlled object, which we
-- consider to be erroneous.
elsif Is_Controlled (Etype (U_Ent))
or else Has_Controlled_Component (Etype (U_Ent))
then
Error_Msg_NE
- ("??controlled object& must not be overlaid", Nam, U_Ent);
+ ("??controlled object & must not be overlaid", Nam, U_Ent);
+ Error_Msg_N
+ ("\??Program_Error will be raised at run time", Nam);
+ Insert_Action (Declaration_Node (U_Ent),
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Overlaid_Controlled_Object));
+ return;
+
+ -- Case of an address clause for a class-wide object, which is
+ -- considered erroneous.
+
+ elsif Is_Class_Wide_Type (Etype (U_Ent)) then
+ Error_Msg_NE
+ ("??class-wide object & must not be overlaid", Nam, U_Ent);
Error_Msg_N
("\??Program_Error will be raised at run time", Nam);
Insert_Action (Declaration_Node (U_Ent),
@@ -4713,6 +4964,40 @@ package body Sem_Ch13 is
Set_Overlays_Constant (U_Ent);
end if;
+ -- If the address clause is of the form:
+
+ -- for X'Address use Y'Address;
+
+ -- or
+
+ -- C : constant Address := Y'Address;
+ -- ...
+ -- for X'Address use C;
+
+ -- then we make an entry in the table to check the size
+ -- and alignment of the overlaying variable. But we defer
+ -- this check till after code generation to take full
+ -- advantage of the annotation done by the back end.
+
+ -- If the entity has a generic type, the check will be
+ -- performed in the instance if the actual type justifies
+ -- it, and we do not insert the clause in the table to
+ -- prevent spurious warnings.
+
+ -- Note: we used to test Comes_From_Source and only give
+ -- this warning for source entities, but we have removed
+ -- this test. It really seems bogus to generate overlays
+ -- that would trigger this warning in generated code.
+ -- Furthermore, by removing the test, we handle the
+ -- aspect case properly.
+
+ if Is_Object (O_Ent)
+ and then not Is_Generic_Type (Etype (U_Ent))
+ and then Address_Clause_Overlay_Warnings
+ then
+ Address_Clause_Checks.Append
+ ((N, U_Ent, No_Uint, O_Ent, Off));
+ end if;
else
-- If this is not an overlay, mark a variable as being
-- volatile to prevent unwanted optimizations. It's a
@@ -4725,6 +5010,21 @@ package body Sem_Ch13 is
if Ekind (U_Ent) = E_Variable then
Set_Treat_As_Volatile (U_Ent);
end if;
+
+ -- Make an entry in the table for an absolute address as
+ -- above to check that the value is compatible with the
+ -- alignment of the object.
+
+ declare
+ Addr : constant Node_Id := Address_Value (Expr);
+ begin
+ if Compile_Time_Known_Value (Addr)
+ and then Address_Clause_Overlay_Warnings
+ then
+ Address_Clause_Checks.Append
+ ((N, U_Ent, Expr_Value (Addr), Empty, False));
+ end if;
+ end;
end if;
-- Overlaying controlled objects is erroneous. Emit warning
@@ -4814,41 +5114,6 @@ package body Sem_Ch13 is
-- the variable, it is somewhere else.
Kill_Size_Check_Code (U_Ent);
-
- -- If the address clause is of the form:
-
- -- for Y'Address use X'Address
-
- -- or
-
- -- Const : constant Address := X'Address;
- -- ...
- -- for Y'Address use Const;
-
- -- then we make an entry in the table for checking the size
- -- and alignment of the overlaying variable. We defer this
- -- check till after code generation to take full advantage
- -- of the annotation done by the back end.
-
- -- If the entity has a generic type, the check will be
- -- performed in the instance if the actual type justifies
- -- it, and we do not insert the clause in the table to
- -- prevent spurious warnings.
-
- -- Note: we used to test Comes_From_Source and only give
- -- this warning for source entities, but we have removed
- -- this test. It really seems bogus to generate overlays
- -- that would trigger this warning in generated code.
- -- Furthermore, by removing the test, we handle the
- -- aspect case properly.
-
- if Present (O_Ent)
- and then Is_Object (O_Ent)
- and then not Is_Generic_Type (Etype (U_Ent))
- and then Address_Clause_Overlay_Warnings
- then
- Address_Clause_Checks.Append ((N, U_Ent, O_Ent, Off));
- end if;
end;
-- Not a valid entity for an address clause
@@ -4884,12 +5149,17 @@ package body Sem_Ch13 is
Set_Has_Alignment_Clause (U_Ent);
-- Tagged type case, check for attempt to set alignment to a
- -- value greater than Max_Align, and reset if so.
+ -- value greater than Max_Align, and reset if so. This error
+ -- is suppressed in ASIS mode to allow for different ASIS
+ -- back ends or ASIS-based tools to query the illegal clause.
- if Is_Tagged_Type (U_Ent) and then Align > Max_Align then
+ if Is_Tagged_Type (U_Ent)
+ and then Align > Max_Align
+ and then not ASIS_Mode
+ then
Error_Msg_N
("alignment for & set to Maximum_Aligment??", Nam);
- Set_Alignment (U_Ent, Max_Align);
+ Set_Alignment (U_Ent, Max_Align);
-- All other cases
@@ -4914,8 +5184,7 @@ package body Sem_Ch13 is
-- Bit_Order attribute definition clause
- when Attribute_Bit_Order => Bit_Order : declare
- begin
+ when Attribute_Bit_Order =>
if not Is_Record_Type (U_Ent) then
Error_Msg_N
("Bit_Order can only be defined for record type", Nam);
@@ -4939,7 +5208,6 @@ package body Sem_Ch13 is
end if;
end if;
end if;
- end Bit_Order;
--------------------
-- Component_Size --
@@ -4962,7 +5230,7 @@ package body Sem_Ch13 is
end if;
Btype := Base_Type (U_Ent);
- Ctyp := Component_Type (Btype);
+ Ctyp := Component_Type (Btype);
if Duplicate_Clause then
null;
@@ -5033,8 +5301,8 @@ package body Sem_Ch13 is
-- CPU --
---------
- when Attribute_CPU => CPU :
- begin
+ when Attribute_CPU =>
+
-- CPU attribute definition clause not allowed except from aspect
-- specification.
@@ -5065,7 +5333,6 @@ package body Sem_Ch13 is
Error_Msg_N
("attribute& cannot be set with definition clause", N);
end if;
- end CPU;
----------------------
-- Default_Iterator --
@@ -5127,8 +5394,8 @@ package body Sem_Ch13 is
-- Dispatching_Domain --
------------------------
- when Attribute_Dispatching_Domain => Dispatching_Domain :
- begin
+ when Attribute_Dispatching_Domain =>
+
-- Dispatching_Domain attribute definition clause not allowed
-- except from aspect specification.
@@ -5159,14 +5426,12 @@ package body Sem_Ch13 is
Error_Msg_N
("attribute& cannot be set with definition clause", N);
end if;
- end Dispatching_Domain;
------------------
-- External_Tag --
------------------
- when Attribute_External_Tag => External_Tag :
- begin
+ when Attribute_External_Tag =>
if not Is_Tagged_Type (U_Ent) then
Error_Msg_N ("should be a tagged type", Nam);
end if;
@@ -5186,13 +5451,12 @@ package body Sem_Ch13 is
Error_Msg_NE
("??non-unique external tag supplied for &", N, U_Ent);
Error_Msg_N
- ("\??same external tag applies to all "
- & "subprogram calls", N);
+ ("\??same external tag applies to all subprogram calls",
+ N);
Error_Msg_N
("\??corresponding internal tag cannot be obtained", N);
end if;
end if;
- end External_Tag;
--------------------------
-- Implicit_Dereference --
@@ -5217,16 +5481,16 @@ package body Sem_Ch13 is
-- Interrupt_Priority --
------------------------
- when Attribute_Interrupt_Priority => Interrupt_Priority :
- begin
+ when Attribute_Interrupt_Priority =>
+
-- Interrupt_Priority attribute definition clause not allowed
-- except from aspect specification.
if From_Aspect_Specification (N) then
if not Is_Concurrent_Type (U_Ent) then
Error_Msg_N
- ("Interrupt_Priority can only be defined for task "
- & "and protected object", Nam);
+ ("Interrupt_Priority can only be defined for task and "
+ & "protected object", Nam);
elsif Duplicate_Clause then
null;
@@ -5256,7 +5520,6 @@ package body Sem_Ch13 is
Error_Msg_N
("attribute& cannot be set with definition clause", N);
end if;
- end Interrupt_Priority;
--------------
-- Iterable --
@@ -5318,9 +5581,15 @@ package body Sem_Ch13 is
if Radix = 2 then
null;
+
elsif Radix = 10 then
Set_Machine_Radix_10 (U_Ent);
- else
+
+ -- The following error is suppressed in ASIS mode to allow for
+ -- different ASIS back ends or ASIS-based tools to query the
+ -- illegal clause.
+
+ elsif not ASIS_Mode then
Error_Msg_N ("machine radix value must be 2 or 10", Expr);
end if;
end if;
@@ -5348,7 +5617,14 @@ package body Sem_Ch13 is
else
Check_Size (Expr, U_Ent, Size, Biased);
- if Is_Scalar_Type (U_Ent) then
+ -- The following errors are suppressed in ASIS mode to allow
+ -- for different ASIS back ends or ASIS-based tools to query
+ -- the illegal clause.
+
+ if ASIS_Mode then
+ null;
+
+ elsif Is_Scalar_Type (U_Ent) then
if Size /= 8 and then Size /= 16 and then Size /= 32
and then UI_Mod (Size, 64) /= 0
then
@@ -5379,8 +5655,8 @@ package body Sem_Ch13 is
-- Priority --
--------------
- when Attribute_Priority => Priority :
- begin
+ when Attribute_Priority =>
+
-- Priority attribute definition clause not allowed except from
-- aspect specification.
@@ -5415,7 +5691,6 @@ package body Sem_Ch13 is
Error_Msg_N
("attribute& cannot be set with definition clause", N);
end if;
- end Priority;
----------
-- Read --
@@ -5431,12 +5706,11 @@ package body Sem_Ch13 is
-- Scalar_Storage_Order attribute definition clause
- when Attribute_Scalar_Storage_Order => Scalar_Storage_Order : declare
- begin
+ when Attribute_Scalar_Storage_Order =>
if not (Is_Record_Type (U_Ent) or else Is_Array_Type (U_Ent)) then
Error_Msg_N
- ("Scalar_Storage_Order can only be defined for "
- & "record or array type", Nam);
+ ("Scalar_Storage_Order can only be defined for record or "
+ & "array type", Nam);
elsif Duplicate_Clause then
null;
@@ -5460,8 +5734,8 @@ package body Sem_Ch13 is
Set_Reverse_Storage_Order (Base_Type (U_Ent), True);
else
Error_Msg_N
- ("non-default Scalar_Storage_Order "
- & "not supported on target", Expr);
+ ("non-default Scalar_Storage_Order not supported on "
+ & "target", Expr);
end if;
end if;
@@ -5471,7 +5745,46 @@ package body Sem_Ch13 is
Set_SSO_Set_Low_By_Default (Base_Type (U_Ent), False);
Set_SSO_Set_High_By_Default (Base_Type (U_Ent), False);
end if;
- end Scalar_Storage_Order;
+
+ --------------------------
+ -- Secondary_Stack_Size --
+ --------------------------
+
+ when Attribute_Secondary_Stack_Size =>
+
+ -- Secondary_Stack_Size attribute definition clause not allowed
+ -- except from aspect specification.
+
+ if From_Aspect_Specification (N) then
+ if not Is_Task_Type (U_Ent) then
+ Error_Msg_N
+ ("Secondary Stack Size can only be defined for task", Nam);
+
+ elsif Duplicate_Clause then
+ null;
+
+ else
+ Check_Restriction (No_Secondary_Stack, Expr);
+
+ -- The expression must be analyzed in the special manner
+ -- described in "Handling of Default and Per-Object
+ -- Expressions" in sem.ads.
+
+ -- The visibility to the discriminants must be restored
+
+ Push_Scope_And_Install_Discriminants (U_Ent);
+ Preanalyze_Spec_Expression (Expr, Any_Integer);
+ Uninstall_Discriminants_And_Pop_Scope (U_Ent);
+
+ if not Is_OK_Static_Expression (Expr) then
+ Check_Restriction (Static_Storage_Size, Expr);
+ end if;
+ end if;
+
+ else
+ Error_Msg_N
+ ("attribute& cannot be set with definition clause", N);
+ end if;
----------
-- Size --
@@ -5558,21 +5871,22 @@ package body Sem_Ch13 is
-- For objects, set Esize only
else
- if Is_Elementary_Type (Etyp) then
- if Size /= System_Storage_Unit
- and then
- Size /= System_Storage_Unit * 2
- and then
- Size /= System_Storage_Unit * 4
- and then
- Size /= System_Storage_Unit * 8
- then
- Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit);
- Error_Msg_Uint_2 := Error_Msg_Uint_1 * 8;
- Error_Msg_N
- ("size for primitive object must be a power of 2"
- & " in the range ^-^", N);
- end if;
+ -- The following error is suppressed in ASIS mode to allow
+ -- for different ASIS back ends or ASIS-based tools to query
+ -- the illegal clause.
+
+ if Is_Elementary_Type (Etyp)
+ and then Size /= System_Storage_Unit
+ and then Size /= System_Storage_Unit * 2
+ and then Size /= System_Storage_Unit * 4
+ and then Size /= System_Storage_Unit * 8
+ and then not ASIS_Mode
+ then
+ Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit);
+ Error_Msg_Uint_2 := Error_Msg_Uint_1 * 8;
+ Error_Msg_N
+ ("size for primitive object must be a power of 2 in "
+ & "the range ^-^", N);
end if;
Set_Esize (U_Ent, Size);
@@ -5639,7 +5953,10 @@ package body Sem_Ch13 is
-- Storage_Pool attribute definition clause
- when Attribute_Storage_Pool | Attribute_Simple_Storage_Pool => declare
+ when Attribute_Simple_Storage_Pool
+ | Attribute_Storage_Pool
+ =>
+ Storage_Pool : declare
Pool : Entity_Id;
T : Entity_Id;
@@ -5650,8 +5967,7 @@ package body Sem_Ch13 is
Nam);
return;
- elsif not
- Ekind_In (U_Ent, E_Access_Type, E_General_Access_Type)
+ elsif not Ekind_In (U_Ent, E_Access_Type, E_General_Access_Type)
then
Error_Msg_N
("storage pool can only be given for access types", Nam);
@@ -5796,7 +6112,7 @@ package body Sem_Ch13 is
Error_Msg_N ("incorrect reference to a Storage Pool", Expr);
return;
end if;
- end;
+ end Storage_Pool;
------------------
-- Storage_Size --
@@ -5817,8 +6133,8 @@ package body Sem_Ch13 is
if Warn_On_Obsolescent_Feature then
Error_Msg_N
- ("?j?storage size clause for task is an " &
- "obsolescent feature (RM J.9)", N);
+ ("?j?storage size clause for task is an obsolescent "
+ & "feature (RM J.9)", N);
Error_Msg_N ("\?j?use Storage_Size pragma instead", N);
end if;
end if;
@@ -5886,24 +6202,29 @@ package body Sem_Ch13 is
null;
elsif Is_Elementary_Type (U_Ent) then
- if Size /= System_Storage_Unit
- and then
- Size /= System_Storage_Unit * 2
- and then
- Size /= System_Storage_Unit * 4
- and then
- Size /= System_Storage_Unit * 8
+
+ -- The following errors are suppressed in ASIS mode to allow
+ -- for different ASIS back ends or ASIS-based tools to query
+ -- the illegal clause.
+
+ if ASIS_Mode then
+ null;
+
+ elsif Size /= System_Storage_Unit
+ and then Size /= System_Storage_Unit * 2
+ and then Size /= System_Storage_Unit * 4
+ and then Size /= System_Storage_Unit * 8
then
Error_Msg_Uint_1 := UI_From_Int (System_Storage_Unit);
Error_Msg_N
- ("stream size for elementary type must be a"
- & " power of 2 and at least ^", N);
+ ("stream size for elementary type must be a power of 2 "
+ & "and at least ^", N);
elsif RM_Size (U_Ent) > Size then
Error_Msg_Uint_1 := RM_Size (U_Ent);
Error_Msg_N
- ("stream size for elementary type must be a"
- & " power of 2 and at least ^", N);
+ ("stream size for elementary type must be a power of 2 "
+ & "and at least ^", N);
end if;
Set_Has_Stream_Size_Clause (U_Ent);
@@ -6096,8 +6417,8 @@ package body Sem_Ch13 is
-----------------------------------------------
procedure Analyze_Enumeration_Representation_Clause (N : Node_Id) is
- Ident : constant Node_Id := Identifier (N);
- Aggr : constant Node_Id := Array_Aggregate (N);
+ Ident : constant Node_Id := Identifier (N);
+ Aggr : constant Node_Id := Array_Aggregate (N);
Enumtype : Entity_Id;
Elit : Entity_Id;
Expr : Node_Id;
@@ -6438,7 +6759,13 @@ package body Sem_Ch13 is
-----------------------------------
procedure Analyze_Freeze_Generic_Entity (N : Node_Id) is
+ E : constant Entity_Id := Entity (N);
+
begin
+ if not Is_Frozen (E) and then Has_Delayed_Aspects (E) then
+ Analyze_Aspects_At_Freeze_Point (E);
+ end if;
+
Freeze_Entity_Checks (N);
end Analyze_Freeze_Generic_Entity;
@@ -6649,12 +6976,10 @@ package body Sem_Ch13 is
and then Lbit /= No_Uint
then
if Posit < 0 then
- Error_Msg_N
- ("position cannot be negative", Position (CC));
+ Error_Msg_N ("position cannot be negative", Position (CC));
elsif Fbit < 0 then
- Error_Msg_N
- ("first bit cannot be negative", First_Bit (CC));
+ Error_Msg_N ("first bit cannot be negative", First_Bit (CC));
-- The Last_Bit specified in a component clause must not be
-- less than the First_Bit minus one (RM-13.5.1(10)).
@@ -6747,8 +7072,8 @@ package body Sem_Ch13 is
Intval (Last_Bit (CC))
then
Error_Msg_N
- ("component clause inconsistent "
- & "with representation of ancestor", CC);
+ ("component clause inconsistent with "
+ & "representation of ancestor", CC);
elsif Warn_On_Redundant_Constructs then
Error_Msg_N
@@ -7309,14 +7634,18 @@ package body Sem_Ch13 is
-- And
- when N_Op_And | N_And_Then =>
+ when N_And_Then
+ | N_Op_And
+ =>
return Get_RList (Left_Opnd (Exp))
and
Get_RList (Right_Opnd (Exp));
-- Or
- when N_Op_Or | N_Or_Else =>
+ when N_Op_Or
+ | N_Or_Else
+ =>
return Get_RList (Left_Opnd (Exp))
or
Get_RList (Right_Opnd (Exp));
@@ -7794,565 +8123,132 @@ package body Sem_Ch13 is
return;
end Build_Discrete_Static_Predicate;
- -------------------------------------------
- -- Build_Invariant_Procedure_Declaration --
- -------------------------------------------
+ --------------------------------
+ -- Build_Export_Import_Pragma --
+ --------------------------------
- function Build_Invariant_Procedure_Declaration
- (Typ : Entity_Id) return Node_Id
+ function Build_Export_Import_Pragma
+ (Asp : Node_Id;
+ Id : Entity_Id) return Node_Id
is
- Loc : constant Source_Ptr := Sloc (Typ);
- Decl : Node_Id;
- Obj_Id : Entity_Id;
- SId : Entity_Id;
-
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
+ Asp_Id : constant Aspect_Id := Get_Aspect_Id (Asp);
+ Expr : constant Node_Id := Expression (Asp);
+ Loc : constant Source_Ptr := Sloc (Asp);
+
+ Args : List_Id;
+ Conv : Node_Id;
+ Conv_Arg : Node_Id;
+ Dummy_1 : Node_Id;
+ Dummy_2 : Node_Id;
+ EN : Node_Id;
+ LN : Node_Id;
+ Prag : Node_Id;
+
+ Create_Pragma : Boolean := False;
+ -- This flag is set when the aspect form is such that it warrants the
+ -- creation of a corresponding pragma.
begin
- -- Check for duplicate definitions
-
- if Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ)) then
- return Empty;
- end if;
+ if Present (Expr) then
+ if Error_Posted (Expr) then
+ null;
- -- The related type may be subject to pragma Ghost. Set the mode now to
- -- ensure that the invariant procedure is properly marked as Ghost.
+ elsif Is_True (Expr_Value (Expr)) then
+ Create_Pragma := True;
+ end if;
- Set_Ghost_Mode_From_Entity (Typ);
+ -- Otherwise the aspect defaults to True
- SId :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Typ), "Invariant"));
- Set_Has_Invariants (Typ);
- Set_Ekind (SId, E_Procedure);
- Set_Etype (SId, Standard_Void_Type);
- Set_Is_Invariant_Procedure (SId);
- Set_Invariant_Procedure (Typ, SId);
-
- -- Mark the invariant procedure explicitly as Ghost because it does not
- -- come from source.
-
- if Ghost_Mode > None then
- Set_Is_Ghost_Entity (SId);
+ else
+ Create_Pragma := True;
end if;
- Obj_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('I'));
- Set_Etype (Obj_Id, Typ);
-
- Decl :=
- Make_Subprogram_Declaration (Loc,
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => SId,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Obj_Id,
- Parameter_Type => New_Occurrence_Of (Typ, Loc)))));
-
- Ghost_Mode := Save_Ghost_Mode;
-
- return Decl;
- end Build_Invariant_Procedure_Declaration;
-
- -------------------------------
- -- Build_Invariant_Procedure --
- -------------------------------
-
- -- The procedure that is constructed here has the form
-
- -- procedure typInvariant (Ixxx : typ) is
- -- begin
- -- pragma Check (Invariant, exp, "failed invariant from xxx");
- -- pragma Check (Invariant, exp, "failed invariant from xxx");
- -- ...
- -- pragma Check (Invariant, exp, "failed inherited invariant from xxx");
- -- ...
- -- end typInvariant;
-
- procedure Build_Invariant_Procedure (Typ : Entity_Id; N : Node_Id) is
- procedure Add_Invariants
- (T : Entity_Id;
- Obj_Id : Entity_Id;
- Stmts : in out List_Id;
- Inherit : Boolean);
- -- Appends statements to Stmts for any invariants in the rep item chain
- -- of the given type. If Inherit is False, then we only process entries
- -- on the chain for the type Typ. If Inherit is True, then we ignore any
- -- Invariant aspects, but we process all Invariant'Class aspects, adding
- -- "inherited" to the exception message and generating an informational
- -- message about the inheritance of an invariant.
-
- --------------------
- -- Add_Invariants --
- --------------------
-
- procedure Add_Invariants
- (T : Entity_Id;
- Obj_Id : Entity_Id;
- Stmts : in out List_Id;
- Inherit : Boolean)
- is
- procedure Add_Invariant (Prag : Node_Id);
- -- Create a runtime check to verify the exression of invariant pragma
- -- Prag. All generated code is added to list Stmts.
-
- -------------------
- -- Add_Invariant --
- -------------------
-
- procedure Add_Invariant (Prag : Node_Id) is
- procedure Replace_Type_Reference (N : Node_Id);
- -- Replace a single occurrence N of the subtype name with a
- -- reference to the formal of the predicate function. N can be an
- -- identifier referencing the subtype, or a selected component,
- -- representing an appropriately qualified occurrence of the
- -- subtype name.
-
- procedure Replace_Type_References is
- new Replace_Type_References_Generic (Replace_Type_Reference);
- -- Traverse an expression replacing all occurrences of the subtype
- -- name with appropriate references to the formal of the predicate
- -- function. Note that we must ensure that the type and entity
- -- information is properly set in the replacement node, since we
- -- will do a Preanalyze call of this expression without proper
- -- visibility of the procedure argument.
-
- ----------------------------
- -- Replace_Type_Reference --
- ----------------------------
-
- -- Note: See comments in Add_Predicates.Replace_Type_Reference
- -- regarding handling of Sloc and Comes_From_Source.
-
- procedure Replace_Type_Reference (N : Node_Id) is
- Nloc : constant Source_Ptr := Sloc (N);
-
- begin
- -- Add semantic information to node to be rewritten, for ASIS
- -- navigation needs.
-
- if Nkind (N) = N_Identifier then
- Set_Entity (N, T);
- Set_Etype (N, T);
-
- elsif Nkind (N) = N_Selected_Component then
- Analyze (Prefix (N));
- Set_Entity (Selector_Name (N), T);
- Set_Etype (Selector_Name (N), T);
- end if;
-
- -- Invariant'Class, replace with T'Class (obj)
-
- if Class_Present (Prag) then
-
- -- In ASIS mode, an inherited item is already analyzed,
- -- and the replacement has been done, so do not repeat
- -- the transformation to prevent a malformed tree.
-
- if ASIS_Mode
- and then Nkind (Parent (N)) = N_Attribute_Reference
- and then Attribute_Name (Parent (N)) = Name_Class
- then
- null;
-
- else
- Rewrite (N,
- Make_Type_Conversion (Nloc,
- Subtype_Mark =>
- Make_Attribute_Reference (Nloc,
- Prefix => New_Occurrence_Of (T, Nloc),
- Attribute_Name => Name_Class),
- Expression =>
- Make_Identifier (Nloc, Chars (Obj_Id))));
-
- Set_Entity (Expression (N), Obj_Id);
- Set_Etype (Expression (N), Typ);
- end if;
-
- -- Invariant, replace with obj
-
- else
- Rewrite (N, Make_Identifier (Nloc, Chars (Obj_Id)));
- Set_Entity (N, Obj_Id);
- Set_Etype (N, Typ);
- end if;
-
- Set_Comes_From_Source (N, True);
- end Replace_Type_Reference;
-
- -- Local variables
-
- Asp : constant Node_Id := Corresponding_Aspect (Prag);
- Nam : constant Name_Id := Original_Aspect_Pragma_Name (Prag);
- Ploc : constant Source_Ptr := Sloc (Prag);
- Arg1 : Node_Id;
- Arg2 : Node_Id;
- Arg3 : Node_Id;
- Assoc : List_Id;
- Expr : Node_Id;
- Str : String_Id;
-
- -- Start of processing for Add_Invariant
-
- begin
- -- Extract the arguments of the invariant pragma
-
- Arg1 := First (Pragma_Argument_Associations (Prag));
- Arg2 := Next (Arg1);
- Arg3 := Next (Arg2);
-
- Arg1 := Get_Pragma_Arg (Arg1);
- Arg2 := Get_Pragma_Arg (Arg2);
-
- -- The caller requests processing of all Invariant'Class pragmas,
- -- but the current pragma does not fall in this category. Return
- -- as there is nothing left to do.
-
- if Inherit then
- if not Class_Present (Prag) then
- return;
- end if;
-
- -- Otherwise the pragma must apply to the current type
-
- elsif Entity (Arg1) /= T then
- return;
- end if;
-
- Expr := New_Copy_Tree (Arg2);
-
- -- Replace all occurrences of the type's name with references to
- -- the formal parameter of the invariant procedure.
-
- Replace_Type_References (Expr, T);
-
- -- If the invariant pragma comes from an aspect, replace the saved
- -- expression because we need the subtype references replaced for
- -- the calls to Preanalyze_Spec_Expression in Check_Aspect_At_xxx
- -- routines.
-
- if Present (Asp) then
- Set_Entity (Identifier (Asp), New_Copy_Tree (Expr));
- end if;
-
- -- Preanalyze the invariant expression to capture the visibility
- -- of the proper package part. In general the expression is not
- -- fully analyzed until the body of the invariant procedure is
- -- analyzed at the end of the private part, but that yields the
- -- wrong visibility.
-
- -- Historical note: we used to set N as the parent, but a package
- -- specification as the parent of an expression is bizarre.
-
- Set_Parent (Expr, Parent (Arg2));
- Preanalyze_Assert_Expression (Expr, Any_Boolean);
-
- -- A class-wide invariant may be inherited in a separate unit,
- -- where the corresponding expression cannot be resolved by
- -- visibility, because it refers to a local function. Propagate
- -- semantic information to the original representation item, to
- -- be used when an invariant procedure for a derived type is
- -- constructed.
-
- -- ??? Unclear how to handle class-wide invariants that are not
- -- function calls.
-
- if not Inherit
- and then Class_Present (Prag)
- and then Nkind (Expr) = N_Function_Call
- and then Nkind (Arg2) = N_Indexed_Component
- then
- Rewrite (Arg2,
- Make_Function_Call (Ploc,
- Name =>
- New_Occurrence_Of (Entity (Name (Expr)), Ploc),
- Parameter_Associations =>
- New_Copy_List (Expressions (Arg2))));
- end if;
-
- -- In ASIS mode, even if assertions are not enabled, we must
- -- analyze the original expression in the aspect specification
- -- because it is part of the original tree.
-
- if ASIS_Mode and then Present (Asp) then
- declare
- Orig_Expr : constant Node_Id := Expression (Asp);
- begin
- Replace_Type_References (Orig_Expr, T);
- Preanalyze_Assert_Expression (Orig_Expr, Any_Boolean);
- end;
- end if;
-
- -- An ignored invariant must not generate a runtime check. Add a
- -- null statement to ensure that the invariant procedure does get
- -- a completing body.
-
- if No (Stmts) then
- Stmts := Empty_List;
- end if;
-
- if Is_Ignored (Prag) then
- Append_To (Stmts, Make_Null_Statement (Ploc));
-
- -- Otherwise the invariant is checked. Build a Check pragma to
- -- verify the expression at runtime.
-
- else
- Assoc := New_List (
- Make_Pragma_Argument_Association (Ploc,
- Expression => Make_Identifier (Ploc, Nam)),
- Make_Pragma_Argument_Association (Ploc,
- Expression => Expr));
-
- -- Handle the String argument (if any)
-
- if Present (Arg3) then
- Str := Strval (Get_Pragma_Arg (Arg3));
-
- -- When inheriting an invariant, modify the message from
- -- "failed invariant" to "failed inherited invariant".
-
- if Inherit then
- String_To_Name_Buffer (Str);
-
- if Name_Buffer (1 .. 16) = "failed invariant" then
- Insert_Str_In_Name_Buffer ("inherited ", 8);
- Str := String_From_Name_Buffer;
- end if;
- end if;
-
- Append_To (Assoc,
- Make_Pragma_Argument_Association (Ploc,
- Expression => Make_String_Literal (Ploc, Str)));
- end if;
-
- -- Generate:
- -- pragma Check (Nam, Expr, Str);
-
- Append_To (Stmts,
- Make_Pragma (Ploc,
- Pragma_Identifier =>
- Make_Identifier (Ploc, Name_Check),
- Pragma_Argument_Associations => Assoc));
- end if;
-
- -- Output an info message when inheriting an invariant and the
- -- listing option is enabled.
-
- if Inherit and Opt.List_Inherited_Aspects then
- Error_Msg_Sloc := Sloc (Prag);
- Error_Msg_N
- ("info: & inherits `Invariant''Class` aspect from #?L?", Typ);
- end if;
- end Add_Invariant;
-
- -- Local variables
-
- Ritem : Node_Id;
-
- -- Start of processing for Add_Invariants
-
- begin
- Ritem := First_Rep_Item (T);
- while Present (Ritem) loop
- if Nkind (Ritem) = N_Pragma
- and then Pragma_Name (Ritem) = Name_Invariant
- then
- Add_Invariant (Ritem);
- end if;
-
- Next_Rep_Item (Ritem);
- end loop;
- end Add_Invariants;
-
- -- Local variables
-
- Loc : constant Source_Ptr := Sloc (Typ);
- Priv_Decls : constant List_Id := Private_Declarations (N);
- Vis_Decls : constant List_Id := Visible_Declarations (N);
-
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
-
- PBody : Node_Id;
- PDecl : Node_Id;
- SId : Entity_Id;
- Spec : Node_Id;
- Stmts : List_Id;
-
- Obj_Id : Node_Id;
- -- The entity of the formal for the procedure
+ -- Nothing to do when the expression is False or is erroneous
- -- Start of processing for Build_Invariant_Procedure
-
- begin
- -- The related type may be subject to pragma Ghost. Set the mode now to
- -- ensure that the invariant procedure is properly marked as Ghost.
-
- Set_Ghost_Mode_From_Entity (Typ);
-
- Stmts := No_List;
- PDecl := Empty;
- PBody := Empty;
- SId := Empty;
+ if not Create_Pragma then
+ return Empty;
+ end if;
- -- If the aspect specification exists for some view of the type, the
- -- declaration for the procedure has been created.
+ -- Obtain all interfacing aspects that apply to the related entity
- if Has_Invariants (Typ) then
- SId := Invariant_Procedure (Typ);
- end if;
+ Get_Interfacing_Aspects
+ (Iface_Asp => Asp,
+ Conv_Asp => Conv,
+ EN_Asp => EN,
+ Expo_Asp => Dummy_1,
+ Imp_Asp => Dummy_2,
+ LN_Asp => LN);
- -- If the body is already present, nothing to do. This will occur when
- -- the type is already frozen, which is the case when the invariant
- -- appears in a private part, and the freezing takes place before the
- -- final pass over full declarations.
+ Args := New_List;
- -- See Exp_Ch3.Insert_Component_Invariant_Checks for details.
+ -- Handle the convention argument
- if Present (SId) then
- PDecl := Unit_Declaration_Node (SId);
+ if Present (Conv) then
+ Conv_Arg := New_Copy_Tree (Expression (Conv));
- if Present (PDecl)
- and then Nkind (PDecl) = N_Subprogram_Declaration
- and then Present (Corresponding_Body (PDecl))
- then
- Ghost_Mode := Save_Ghost_Mode;
- return;
- end if;
+ -- Assume convention "Ada' when aspect Convention is missing
else
- PDecl := Build_Invariant_Procedure_Declaration (Typ);
+ Conv_Arg := Make_Identifier (Loc, Name_Ada);
end if;
- -- Recover formal of procedure, for use in the calls to invariant
- -- functions (including inherited ones).
+ Append_To (Args,
+ Make_Pragma_Argument_Association (Loc,
+ Chars => Name_Convention,
+ Expression => Conv_Arg));
- Obj_Id :=
- Defining_Identifier
- (First (Parameter_Specifications (Specification (PDecl))));
+ -- Handle the entity argument
- -- Add invariants for the current type
+ Append_To (Args,
+ Make_Pragma_Argument_Association (Loc,
+ Chars => Name_Entity,
+ Expression => New_Occurrence_Of (Id, Loc)));
- Add_Invariants
- (T => Typ,
- Obj_Id => Obj_Id,
- Stmts => Stmts,
- Inherit => False);
+ -- Handle the External_Name argument
- -- Add invariants for parent types
-
- declare
- Current_Typ : Entity_Id;
- Parent_Typ : Entity_Id;
-
- begin
- Current_Typ := Typ;
- loop
- Parent_Typ := Etype (Current_Typ);
-
- if Is_Private_Type (Parent_Typ)
- and then Present (Full_View (Base_Type (Parent_Typ)))
- then
- Parent_Typ := Full_View (Base_Type (Parent_Typ));
- end if;
-
- exit when Parent_Typ = Current_Typ;
-
- Current_Typ := Parent_Typ;
- Add_Invariants
- (T => Current_Typ,
- Obj_Id => Obj_Id,
- Stmts => Stmts,
- Inherit => True);
- end loop;
- end;
-
- -- Add invariants of progenitors
-
- if Is_Tagged_Type (Typ) and then not Is_Interface (Typ) then
- declare
- Ifaces_List : Elist_Id;
- AI : Elmt_Id;
- Iface : Entity_Id;
-
- begin
- Collect_Interfaces (Typ, Ifaces_List);
-
- AI := First_Elmt (Ifaces_List);
- while Present (AI) loop
- Iface := Node (AI);
-
- if not Is_Ancestor (Iface, Typ, Use_Full_View => True) then
- Add_Invariants
- (T => Iface,
- Obj_Id => Obj_Id,
- Stmts => Stmts,
- Inherit => True);
- end if;
-
- Next_Elmt (AI);
- end loop;
- end;
+ if Present (EN) then
+ Append_To (Args,
+ Make_Pragma_Argument_Association (Loc,
+ Chars => Name_External_Name,
+ Expression => New_Copy_Tree (Expression (EN))));
end if;
- -- Build the procedure if we generated at least one Check pragma
-
- if Stmts /= No_List then
- Spec := Copy_Separate_Tree (Specification (PDecl));
-
- PBody :=
- Make_Subprogram_Body (Loc,
- Specification => Spec,
- Declarations => Empty_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Stmts));
-
- -- Insert procedure declaration and spec at the appropriate points.
- -- If declaration is already analyzed, it was processed by the
- -- generated pragma.
-
- if Present (Priv_Decls) then
-
- -- The spec goes at the end of visible declarations, but they have
- -- already been analyzed, so we need to explicitly do the analyze.
+ -- Handle the Link_Name argument
- if not Analyzed (PDecl) then
- Append_To (Vis_Decls, PDecl);
- Analyze (PDecl);
- end if;
+ if Present (LN) then
+ Append_To (Args,
+ Make_Pragma_Argument_Association (Loc,
+ Chars => Name_Link_Name,
+ Expression => New_Copy_Tree (Expression (LN))));
+ end if;
- -- The body goes at the end of the private declarations, which we
- -- have not analyzed yet, so we do not need to perform an explicit
- -- analyze call. We skip this if there are no private declarations
- -- (this is an error that will be caught elsewhere);
+ -- Generate:
+ -- pragma Export/Import
+ -- (Convention => <Conv>/Ada,
+ -- Entity => <Id>,
+ -- [External_Name => <EN>,]
+ -- [Link_Name => <LN>]);
- Append_To (Priv_Decls, PBody);
+ Prag :=
+ Make_Pragma (Loc,
+ Pragma_Identifier =>
+ Make_Identifier (Loc, Chars (Identifier (Asp))),
+ Pragma_Argument_Associations => Args);
- -- If the invariant appears on the full view of a type, the
- -- analysis of the private part is complete, and we must
- -- analyze the new body explicitly.
+ -- Decorate the relevant aspect and the pragma
- if In_Private_Part (Current_Scope) then
- Analyze (PBody);
- end if;
+ Set_Aspect_Rep_Item (Asp, Prag);
- -- If there are no private declarations this may be an error that
- -- will be diagnosed elsewhere. However, if this is a non-private
- -- type that inherits invariants, it needs no completion and there
- -- may be no private part. In this case insert invariant procedure
- -- at end of current declarative list, and analyze at once, given
- -- that the type is about to be frozen.
+ Set_Corresponding_Aspect (Prag, Asp);
+ Set_From_Aspect_Specification (Prag);
+ Set_Parent (Prag, Asp);
- elsif not Is_Private_Type (Typ) then
- Append_To (Vis_Decls, PDecl);
- Append_To (Vis_Decls, PBody);
- Analyze (PDecl);
- Analyze (PBody);
- end if;
+ if Asp_Id = Aspect_Import and then Is_Subprogram (Id) then
+ Set_Import_Pragma (Id, Prag);
end if;
- Ghost_Mode := Save_Ghost_Mode;
- end Build_Invariant_Procedure;
+ return Prag;
+ end Build_Export_Import_Pragma;
-------------------------------
-- Build_Predicate_Functions --
@@ -8385,6 +8281,10 @@ package body Sem_Ch13 is
-- the typPredicateM version of the function, in which any occurrence of a
-- Raise_Expression is converted to "return False".
+ -- WARNING: This routine manages Ghost regions. Return statements must be
+ -- replaced by gotos which jump to the end of the routine and restore the
+ -- Ghost mode.
+
procedure Build_Predicate_Functions (Typ : Entity_Id; N : Node_Id) is
Loc : constant Source_Ptr := Sloc (Typ);
@@ -8397,18 +8297,23 @@ package body Sem_Ch13 is
-- function. It differs in that raise expressions are marked for
-- special expansion (see Process_REs).
- Object_Name : constant Name_Id := New_Internal_Name ('I');
+ Object_Name : Name_Id;
-- Name for argument of Predicate procedure. Note that we use the same
-- name for both predicate functions. That way the reference within the
-- predicate expression is the same in both functions.
- Object_Entity : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Chars => Object_Name);
+ Object_Entity : Entity_Id;
-- Entity for argument of Predicate procedure
- Object_Entity_M : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Chars => Object_Name);
- -- Entity for argument of Predicate_M procedure
+ Object_Entity_M : Entity_Id;
+ -- Entity for argument of separate Predicate procedure when exceptions
+ -- are present in expression.
+
+ FDecl : Node_Id;
+ -- The function declaration
+
+ SId : Entity_Id;
+ -- Its entity
Raise_Expression_Present : Boolean := False;
-- Set True if Expr has at least one Raise_Expression
@@ -8604,6 +8509,26 @@ package body Sem_Ch13 is
and then Pragma_Name (Ritem) = Name_Predicate
then
Add_Predicate (Ritem);
+
+ -- If the type is declared in an inner package it may be frozen
+ -- outside of the package, and the generated pragma has not been
+ -- analyzed yet, so capture the expression for the predicate
+ -- function at this point.
+
+ elsif Nkind (Ritem) = N_Aspect_Specification
+ and then Present (Aspect_Rep_Item (Ritem))
+ and then Scope (Typ) /= Current_Scope
+ then
+ declare
+ Prag : constant Node_Id := Aspect_Rep_Item (Ritem);
+
+ begin
+ if Nkind (Prag) = N_Pragma
+ and then Pragma_Name (Prag) = Name_Predicate
+ then
+ Add_Predicate (Prag);
+ end if;
+ end;
end if;
Next_Rep_Item (Ritem);
@@ -8640,15 +8565,16 @@ package body Sem_Ch13 is
-- Local variables
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
+ Mode : Ghost_Mode_Type;
-- Start of processing for Build_Predicate_Functions
begin
-- Return if already built or if type does not have predicates
+ SId := Predicate_Function (Typ);
if not Has_Predicates (Typ)
- or else Present (Predicate_Function (Typ))
+ or else (Present (SId) and then Has_Completion (SId))
then
return;
end if;
@@ -8656,12 +8582,30 @@ package body Sem_Ch13 is
-- The related type may be subject to pragma Ghost. Set the mode now to
-- ensure that the predicate functions are properly marked as Ghost.
- Set_Ghost_Mode_From_Entity (Typ);
+ Set_Ghost_Mode (Typ, Mode);
-- Prepare to construct predicate expression
Expr := Empty;
+ if Present (SId) then
+ FDecl := Unit_Declaration_Node (SId);
+
+ else
+ FDecl := Build_Predicate_Function_Declaration (Typ);
+ SId := Defining_Entity (FDecl);
+ end if;
+
+ -- Recover name of formal parameter of function that replaces references
+ -- to the type in predicate expressions.
+
+ Object_Entity :=
+ Defining_Identifier
+ (First (Parameter_Specifications (Specification (FDecl))));
+
+ Object_Name := Chars (Object_Entity);
+ Object_Entity_M := Make_Defining_Identifier (Loc, Chars => Object_Name);
+
-- Add predicates for ancestor if present. These must come before the
-- ones for the current type, as required by AI12-0071-1.
@@ -8735,55 +8679,21 @@ package body Sem_Ch13 is
-- Build the main predicate function
declare
- SId : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Typ), "Predicate"));
- -- The entity for the function spec
-
SIdB : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Typ), "Predicate"));
-- The entity for the function body
Spec : Node_Id;
- FDecl : Node_Id;
FBody : Node_Id;
begin
- -- Build function declaration
-
- Set_Ekind (SId, E_Function);
- Set_Is_Internal (SId);
- Set_Is_Predicate_Function (SId);
- Set_Predicate_Function (Typ, SId);
-
-- The predicate function is shared between views of a type
if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
Set_Predicate_Function (Full_View (Typ), SId);
end if;
- -- Mark the predicate function explicitly as Ghost because it does
- -- not come from source.
-
- if Ghost_Mode > None then
- Set_Is_Ghost_Entity (SId);
- end if;
-
- Spec :=
- Make_Function_Specification (Loc,
- Defining_Unit_Name => SId,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Object_Entity,
- Parameter_Type => New_Occurrence_Of (Typ, Loc))),
- Result_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loc));
-
- FDecl :=
- Make_Subprogram_Declaration (Loc,
- Specification => Spec);
-
-- Build function body
Spec :=
@@ -8808,10 +8718,14 @@ package body Sem_Ch13 is
Make_Simple_Return_Statement (Loc,
Expression => Expr))));
- -- Insert declaration before freeze node and body after
+ -- If declaration has not been analyzed yet, Insert declaration
+ -- before freeze node. Insert body itself after freeze node.
+
+ if not Analyzed (FDecl) then
+ Insert_Before_And_Analyze (N, FDecl);
+ end if;
- Insert_Before_And_Analyze (N, FDecl);
- Insert_After_And_Analyze (N, FBody);
+ Insert_After_And_Analyze (N, FBody);
-- Static predicate functions are always side-effect free, and
-- in most cases dynamic predicate functions are as well. Mark
@@ -8841,8 +8755,8 @@ package body Sem_Ch13 is
-- The entity for the function body
Spec : Node_Id;
- FDecl : Node_Id;
FBody : Node_Id;
+ FDecl : Node_Id;
BTemp : Entity_Id;
begin
@@ -8862,13 +8776,6 @@ package body Sem_Ch13 is
Set_Predicate_Function_M (Full_View (Typ), SId);
end if;
- -- Mark the predicate function explicitly as Ghost because it
- -- does not come from source.
-
- if Ghost_Mode > None then
- Set_Is_Ghost_Entity (SId);
- end if;
-
Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => SId,
@@ -9021,9 +8928,63 @@ package body Sem_Ch13 is
end;
end if;
- Ghost_Mode := Save_Ghost_Mode;
+ Restore_Ghost_Mode (Mode);
end Build_Predicate_Functions;
+ ------------------------------------------
+ -- Build_Predicate_Function_Declaration --
+ ------------------------------------------
+
+ -- WARNING: This routine manages Ghost regions. Return statements must be
+ -- replaced by gotos which jump to the end of the routine and restore the
+ -- Ghost mode.
+
+ function Build_Predicate_Function_Declaration
+ (Typ : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+
+ Func_Decl : Node_Id;
+ Func_Id : Entity_Id;
+ Mode : Ghost_Mode_Type;
+ Spec : Node_Id;
+
+ begin
+ -- The related type may be subject to pragma Ghost. Set the mode now to
+ -- ensure that the predicate functions are properly marked as Ghost.
+
+ Set_Ghost_Mode (Typ, Mode);
+
+ Func_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_External_Name (Chars (Typ), "Predicate"));
+
+ Spec :=
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => Func_Id,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Make_Temporary (Loc, 'I'),
+ Parameter_Type => New_Occurrence_Of (Typ, Loc))),
+ Result_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc));
+
+ Func_Decl := Make_Subprogram_Declaration (Loc, Specification => Spec);
+
+ Set_Ekind (Func_Id, E_Function);
+ Set_Etype (Func_Id, Standard_Boolean);
+ Set_Is_Internal (Func_Id);
+ Set_Is_Predicate_Function (Func_Id);
+ Set_Predicate_Function (Typ, Func_Id);
+
+ Insert_After (Parent (Typ), Func_Decl);
+ Analyze (Func_Decl);
+
+ Restore_Ghost_Mode (Mode);
+
+ return Func_Decl;
+ end Build_Predicate_Function_Declaration;
+
-----------------------------------------
-- Check_Aspect_At_End_Of_Declarations --
-----------------------------------------
@@ -9037,10 +8998,12 @@ package body Sem_Ch13 is
-- Expression to be analyzed at end of declarations
Freeze_Expr : constant Node_Id := Expression (ASN);
- -- Expression from call to Check_Aspect_At_Freeze_Point
+ -- Expression from call to Check_Aspect_At_Freeze_Point.
- T : constant Entity_Id := Etype (Freeze_Expr);
- -- Type required for preanalyze call
+ T : constant Entity_Id := Etype (Original_Node (Freeze_Expr));
+ -- Type required for preanalyze call. We use the original expression to
+ -- get the proper type, to prevent cascaded errors when the expression
+ -- is constant-folded.
Err : Boolean;
-- Set False if error
@@ -9224,9 +9187,9 @@ package body Sem_Ch13 is
-- Aspects taking an optional boolean argument
- when Boolean_Aspects |
- Library_Unit_Aspects =>
-
+ when Boolean_Aspects
+ | Library_Unit_Aspects
+ =>
T := Standard_Boolean;
-- Aspects corresponding to attribute definition clauses
@@ -9237,7 +9200,9 @@ package body Sem_Ch13 is
when Aspect_Attach_Handler =>
T := RTE (RE_Interrupt_ID);
- when Aspect_Bit_Order | Aspect_Scalar_Storage_Order =>
+ when Aspect_Bit_Order
+ | Aspect_Scalar_Storage_Order
+ =>
T := RTE (RE_Bit_Order);
when Aspect_Convention =>
@@ -9271,12 +9236,17 @@ package body Sem_Ch13 is
when Aspect_Link_Name =>
T := Standard_String;
- when Aspect_Priority | Aspect_Interrupt_Priority =>
+ when Aspect_Interrupt_Priority
+ | Aspect_Priority
+ =>
T := Standard_Integer;
when Aspect_Relative_Deadline =>
T := RTE (RE_Time_Span);
+ when Aspect_Secondary_Stack_Size =>
+ T := Standard_Integer;
+
when Aspect_Small =>
T := Universal_Real;
@@ -9290,14 +9260,15 @@ package body Sem_Ch13 is
when Aspect_Storage_Pool =>
T := Class_Wide_Type (RTE (RE_Root_Storage_Pool));
- when Aspect_Alignment |
- Aspect_Component_Size |
- Aspect_Machine_Radix |
- Aspect_Object_Size |
- Aspect_Size |
- Aspect_Storage_Size |
- Aspect_Stream_Size |
- Aspect_Value_Size =>
+ when Aspect_Alignment
+ | Aspect_Component_Size
+ | Aspect_Machine_Radix
+ | Aspect_Object_Size
+ | Aspect_Size
+ | Aspect_Storage_Size
+ | Aspect_Stream_Size
+ | Aspect_Value_Size
+ =>
T := Any_Integer;
when Aspect_Linker_Section =>
@@ -9309,23 +9280,25 @@ package body Sem_Ch13 is
-- Special case, the expression of these aspects is just an entity
-- that does not need any resolution, so just analyze.
- when Aspect_Input |
- Aspect_Output |
- Aspect_Read |
- Aspect_Suppress |
- Aspect_Unsuppress |
- Aspect_Warnings |
- Aspect_Write =>
+ when Aspect_Input
+ | Aspect_Output
+ | Aspect_Read
+ | Aspect_Suppress
+ | Aspect_Unsuppress
+ | Aspect_Warnings
+ | Aspect_Write
+ =>
Analyze (Expression (ASN));
return;
-- Same for Iterator aspects, where the expression is a function
-- name. Legality rules are checked separately.
- when Aspect_Constant_Indexing |
- Aspect_Default_Iterator |
- Aspect_Iterator_Element |
- Aspect_Variable_Indexing =>
+ when Aspect_Constant_Indexing
+ | Aspect_Default_Iterator
+ | Aspect_Iterator_Element
+ | Aspect_Variable_Indexing
+ =>
Analyze (Expression (ASN));
return;
@@ -9362,11 +9335,12 @@ package body Sem_Ch13 is
-- Invariant/Predicate take boolean expressions
- when Aspect_Dynamic_Predicate |
- Aspect_Invariant |
- Aspect_Predicate |
- Aspect_Static_Predicate |
- Aspect_Type_Invariant =>
+ when Aspect_Dynamic_Predicate
+ | Aspect_Invariant
+ | Aspect_Predicate
+ | Aspect_Static_Predicate
+ | Aspect_Type_Invariant
+ =>
T := Standard_Boolean;
when Aspect_Predicate_Failure =>
@@ -9374,38 +9348,40 @@ package body Sem_Ch13 is
-- Here is the list of aspects that don't require delay analysis
- when Aspect_Abstract_State |
- Aspect_Annotate |
- Aspect_Async_Readers |
- Aspect_Async_Writers |
- Aspect_Constant_After_Elaboration |
- Aspect_Contract_Cases |
- Aspect_Default_Initial_Condition |
- Aspect_Depends |
- Aspect_Dimension |
- Aspect_Dimension_System |
- Aspect_Effective_Reads |
- Aspect_Effective_Writes |
- Aspect_Extensions_Visible |
- Aspect_Ghost |
- Aspect_Global |
- Aspect_Implicit_Dereference |
- Aspect_Initial_Condition |
- Aspect_Initializes |
- Aspect_Obsolescent |
- Aspect_Part_Of |
- Aspect_Post |
- Aspect_Postcondition |
- Aspect_Pre |
- Aspect_Precondition |
- Aspect_Refined_Depends |
- Aspect_Refined_Global |
- Aspect_Refined_Post |
- Aspect_Refined_State |
- Aspect_SPARK_Mode |
- Aspect_Test_Case |
- Aspect_Unimplemented |
- Aspect_Volatile_Function =>
+ when Aspect_Abstract_State
+ | Aspect_Annotate
+ | Aspect_Async_Readers
+ | Aspect_Async_Writers
+ | Aspect_Constant_After_Elaboration
+ | Aspect_Contract_Cases
+ | Aspect_Default_Initial_Condition
+ | Aspect_Depends
+ | Aspect_Dimension
+ | Aspect_Dimension_System
+ | Aspect_Effective_Reads
+ | Aspect_Effective_Writes
+ | Aspect_Extensions_Visible
+ | Aspect_Ghost
+ | Aspect_Global
+ | Aspect_Implicit_Dereference
+ | Aspect_Initial_Condition
+ | Aspect_Initializes
+ | Aspect_Max_Queue_Length
+ | Aspect_Obsolescent
+ | Aspect_Part_Of
+ | Aspect_Post
+ | Aspect_Postcondition
+ | Aspect_Pre
+ | Aspect_Precondition
+ | Aspect_Refined_Depends
+ | Aspect_Refined_Global
+ | Aspect_Refined_Post
+ | Aspect_Refined_State
+ | Aspect_SPARK_Mode
+ | Aspect_Test_Case
+ | Aspect_Unimplemented
+ | Aspect_Volatile_Function
+ =>
raise Program_Error;
end case;
@@ -9447,11 +9423,10 @@ package body Sem_Ch13 is
if Present (Address_Clause (Entity ((Nod)))) then
Error_Msg_NE
("invalid address clause for initialized object &!",
- Nod, U_Ent);
- Error_Msg_NE
- ("address for& cannot" &
- " depend on another address clause! (RM 13.1(22))!",
Nod, U_Ent);
+ Error_Msg_NE
+ ("address for& cannot depend on another address clause! "
+ & "(RM 13.1(22))!", Nod, U_Ent);
elsif In_Same_Source_Unit (Entity (Nod), U_Ent)
and then Sloc (U_Ent) < Sloc (Entity (Nod))
@@ -9481,9 +9456,8 @@ package body Sem_Ch13 is
("invalid address clause for initialized object &!",
Nod, U_Ent);
Error_Msg_N
- ("\address cannot depend on component" &
- " of discriminated record (RM 13.1(22))!",
- Nod);
+ ("\address cannot depend on component of discriminated "
+ & "record (RM 13.1(22))!", Nod);
else
Check_At_Constant_Address (Prefix (Nod));
end if;
@@ -9514,10 +9488,14 @@ package body Sem_Ch13 is
end if;
case Nkind (Nod) is
- when N_Empty | N_Error =>
+ when N_Empty
+ | N_Error
+ =>
return;
- when N_Identifier | N_Expanded_Name =>
+ when N_Expanded_Name
+ | N_Identifier
+ =>
Ent := Entity (Nod);
-- We need to look at the original node if it is different
@@ -9623,9 +9601,10 @@ package body Sem_Ch13 is
Set_Etype (Nod, Base_Type (Etype (Nod)));
end if;
- when N_Real_Literal |
- N_String_Literal |
- N_Character_Literal =>
+ when N_Character_Literal
+ | N_Real_Literal
+ | N_String_Literal
+ =>
return;
when N_Range =>
@@ -9674,17 +9653,21 @@ package body Sem_Ch13 is
when N_Null =>
return;
- when N_Binary_Op | N_Short_Circuit | N_Membership_Test =>
+ when N_Binary_Op
+ | N_Membership_Test
+ | N_Short_Circuit
+ =>
Check_Expr_Constants (Left_Opnd (Nod));
Check_Expr_Constants (Right_Opnd (Nod));
when N_Unary_Op =>
Check_Expr_Constants (Right_Opnd (Nod));
- when N_Type_Conversion |
- N_Qualified_Expression |
- N_Allocator |
- N_Unchecked_Type_Conversion =>
+ when N_Allocator
+ | N_Qualified_Expression
+ | N_Type_Conversion
+ | N_Unchecked_Type_Conversion
+ =>
Check_Expr_Constants (Expression (Nod));
when N_Function_Call =>
@@ -10426,15 +10409,26 @@ package body Sem_Ch13 is
Nbit := Sbit;
for J in 1 .. Ncomps loop
CEnt := Comps (J);
- Error_Msg_Uint_1 := Component_Bit_Offset (CEnt) - Nbit;
- if Error_Msg_Uint_1 > 0 then
- Error_Msg_NE
- ("?H?^-bit gap before component&",
- Component_Name (Component_Clause (CEnt)), CEnt);
- end if;
+ declare
+ CBO : constant Uint := Component_Bit_Offset (CEnt);
+
+ begin
+ -- Skip components with unknown offsets
+
+ if CBO /= No_Uint and then CBO >= 0 then
+ Error_Msg_Uint_1 := CBO - Nbit;
- Nbit := Component_Bit_Offset (CEnt) + Esize (CEnt);
+ if Error_Msg_Uint_1 > 0 then
+ Error_Msg_NE
+ ("?H?^-bit gap before component&",
+ Component_Name (Component_Clause (CEnt)),
+ CEnt);
+ end if;
+
+ Nbit := CBO + Esize (CEnt);
+ end if;
+ end;
end loop;
-- Process variant parts recursively if present
@@ -10518,13 +10512,36 @@ package body Sem_Ch13 is
Siz : Uint;
Biased : out Boolean)
is
+ procedure Size_Too_Small_Error (Min_Siz : Uint);
+ -- Emit an error concerning illegal size Siz. Min_Siz denotes the
+ -- minimum size.
+
+ --------------------------
+ -- Size_Too_Small_Error --
+ --------------------------
+
+ procedure Size_Too_Small_Error (Min_Siz : Uint) is
+ begin
+ -- This error is suppressed in ASIS mode to allow for different ASIS
+ -- back ends or ASIS-based tools to query the illegal clause.
+
+ if not ASIS_Mode then
+ Error_Msg_Uint_1 := Min_Siz;
+ Error_Msg_NE ("size for& too small, minimum allowed is ^", N, T);
+ end if;
+ end Size_Too_Small_Error;
+
+ -- Local variables
+
UT : constant Entity_Id := Underlying_Type (T);
M : Uint;
+ -- Start of processing for Check_Size
+
begin
Biased := False;
- -- Reject patently improper size values.
+ -- Reject patently improper size values
if Is_Elementary_Type (T)
and then Siz > UI_From_Int (Int'Last)
@@ -10593,9 +10610,7 @@ package body Sem_Ch13 is
return;
else
- Error_Msg_Uint_1 := Asiz;
- Error_Msg_NE
- ("size for& too small, minimum allowed is ^", N, T);
+ Size_Too_Small_Error (Asiz);
Set_Esize (T, Asiz);
Set_RM_Size (T, Asiz);
end if;
@@ -10610,9 +10625,7 @@ package body Sem_Ch13 is
-- since we don't know all the characteristics of the type that can
-- affect the size (e.g. a specified small) till freeze time.
- elsif Is_Fixed_Point_Type (UT)
- and then not Is_Frozen (UT)
- then
+ elsif Is_Fixed_Point_Type (UT) and then not Is_Frozen (UT) then
null;
-- Cases for which a minimum check is required
@@ -10636,10 +10649,8 @@ package body Sem_Ch13 is
M := UI_From_Int (Minimum_Size (UT, Biased => True));
if Siz < M then
- Error_Msg_Uint_1 := M;
- Error_Msg_NE
- ("size for& too small, minimum allowed is ^", N, T);
- Set_Esize (T, M);
+ Size_Too_Small_Error (M);
+ Set_Esize (T, M);
Set_RM_Size (T, M);
else
Biased := True;
@@ -10773,9 +10784,7 @@ package body Sem_Ch13 is
end if;
end Hide_Non_Overridden_Subprograms;
- ---------------------
- -- Local variables --
- ---------------------
+ -- Local variables
E : constant Entity_Id := Entity (N);
@@ -10825,10 +10834,10 @@ package body Sem_Ch13 is
-- After all forms of overriding have been resolved, a tagged type may
-- be left with a set of implicitly declared and possibly erroneous
-- abstract subprograms, null procedures and subprograms that require
- -- overriding. If this set contains fully conformat homographs, then one
- -- is chosen arbitrarily (already done during resolution), otherwise all
- -- remaining non-fully conformant homographs are hidden from visibility
- -- (Ada RM 8.3 12.3/2).
+ -- overriding. If this set contains fully conformant homographs, then
+ -- one is chosen arbitrarily (already done during resolution), otherwise
+ -- all remaining non-fully conformant homographs are hidden from
+ -- visibility (Ada RM 8.3 12.3/2).
if Is_Tagged_Type (E) then
Hide_Non_Overridden_Subprograms (E);
@@ -10938,14 +10947,14 @@ package body Sem_Ch13 is
Inside_Freezing_Actions := Inside_Freezing_Actions - 1;
- -- If we have a type with predicates, build predicate function. This
- -- is not needed in the generic case, and is not needed within TSS
- -- subprograms and other predefined primitives.
+ -- If we have a type with predicates, build predicate function. This is
+ -- not needed in the generic case, nor within TSS subprograms and other
+ -- predefined primitives.
- if Non_Generic_Case
- and then Is_Type (E)
- and then Has_Predicates (E)
+ if Is_Type (E)
+ and then Non_Generic_Case
and then not Within_Internal_Subprogram
+ and then Has_Predicates (E)
then
Build_Predicate_Functions (E, N);
end if;
@@ -11168,7 +11177,14 @@ package body Sem_Ch13 is
return No_Uint;
elsif Align <= 0 then
- Error_Msg_N ("alignment value must be positive", Expr);
+
+ -- This error is suppressed in ASIS mode to allow for different ASIS
+ -- back ends or ASIS-based tools to query the illegal clause.
+
+ if not ASIS_Mode then
+ Error_Msg_N ("alignment value must be positive", Expr);
+ end if;
+
return No_Uint;
else
@@ -11180,8 +11196,15 @@ package body Sem_Ch13 is
exit when M = Align;
if M > Align then
- Error_Msg_N
- ("alignment value must be power of 2", Expr);
+
+ -- This error is suppressed in ASIS mode to allow for
+ -- different ASIS back ends or ASIS-based tools to query the
+ -- illegal clause.
+
+ if not ASIS_Mode then
+ Error_Msg_N ("alignment value must be power of 2", Expr);
+ end if;
+
return No_Uint;
end if;
end;
@@ -11191,6 +11214,106 @@ package body Sem_Ch13 is
end if;
end Get_Alignment_Value;
+ -----------------------------
+ -- Get_Interfacing_Aspects --
+ -----------------------------
+
+ procedure Get_Interfacing_Aspects
+ (Iface_Asp : Node_Id;
+ Conv_Asp : out Node_Id;
+ EN_Asp : out Node_Id;
+ Expo_Asp : out Node_Id;
+ Imp_Asp : out Node_Id;
+ LN_Asp : out Node_Id;
+ Do_Checks : Boolean := False)
+ is
+ procedure Save_Or_Duplication_Error
+ (Asp : Node_Id;
+ To : in out Node_Id);
+ -- Save the value of aspect Asp in node To. If To already has a value,
+ -- then this is considered a duplicate use of aspect. Emit an error if
+ -- flag Do_Checks is set.
+
+ -------------------------------
+ -- Save_Or_Duplication_Error --
+ -------------------------------
+
+ procedure Save_Or_Duplication_Error
+ (Asp : Node_Id;
+ To : in out Node_Id)
+ is
+ begin
+ -- Detect an extra aspect and issue an error
+
+ if Present (To) then
+ if Do_Checks then
+ Error_Msg_Name_1 := Chars (Identifier (Asp));
+ Error_Msg_Sloc := Sloc (To);
+ Error_Msg_N ("aspect % previously given #", Asp);
+ end if;
+
+ -- Otherwise capture the aspect
+
+ else
+ To := Asp;
+ end if;
+ end Save_Or_Duplication_Error;
+
+ -- Local variables
+
+ Asp : Node_Id;
+ Asp_Id : Aspect_Id;
+
+ -- The following variables capture each individual aspect
+
+ Conv : Node_Id := Empty;
+ EN : Node_Id := Empty;
+ Expo : Node_Id := Empty;
+ Imp : Node_Id := Empty;
+ LN : Node_Id := Empty;
+
+ -- Start of processing for Get_Interfacing_Aspects
+
+ begin
+ -- The input interfacing aspect should reside in an aspect specification
+ -- list.
+
+ pragma Assert (Is_List_Member (Iface_Asp));
+
+ -- Examine the aspect specifications of the related entity. Find and
+ -- capture all interfacing aspects. Detect duplicates and emit errors
+ -- if applicable.
+
+ Asp := First (List_Containing (Iface_Asp));
+ while Present (Asp) loop
+ Asp_Id := Get_Aspect_Id (Asp);
+
+ if Asp_Id = Aspect_Convention then
+ Save_Or_Duplication_Error (Asp, Conv);
+
+ elsif Asp_Id = Aspect_External_Name then
+ Save_Or_Duplication_Error (Asp, EN);
+
+ elsif Asp_Id = Aspect_Export then
+ Save_Or_Duplication_Error (Asp, Expo);
+
+ elsif Asp_Id = Aspect_Import then
+ Save_Or_Duplication_Error (Asp, Imp);
+
+ elsif Asp_Id = Aspect_Link_Name then
+ Save_Or_Duplication_Error (Asp, LN);
+ end if;
+
+ Next (Asp);
+ end loop;
+
+ Conv_Asp := Conv;
+ EN_Asp := EN;
+ Expo_Asp := Expo;
+ Imp_Asp := Imp;
+ LN_Asp := LN;
+ end Get_Interfacing_Aspects;
+
-------------------------------------
-- Inherit_Aspects_At_Freeze_Point --
-------------------------------------
@@ -11330,30 +11453,6 @@ package body Sem_Ch13 is
Set_Discard_Names (Typ);
end if;
- -- Invariants
-
- if not Has_Rep_Item (Typ, Name_Invariant, False)
- and then Has_Rep_Item (Typ, Name_Invariant)
- and then Is_Pragma_Or_Corr_Pragma_Present_In_Rep_Item
- (Get_Rep_Item (Typ, Name_Invariant))
- then
- Set_Has_Invariants (Typ);
-
- if Class_Present (Get_Rep_Item (Typ, Name_Invariant)) then
- Set_Has_Inheritable_Invariants (Typ);
- end if;
-
- -- If we have a subtype with invariants, whose base type does not have
- -- invariants, copy these invariants to the base type. This happens for
- -- the case of implicit base types created for scalar and array types.
-
- elsif Has_Invariants (Typ)
- and then not Has_Invariants (Base_Type (Typ))
- then
- Set_Has_Invariants (Base_Type (Typ));
- Set_Invariant_Procedure (Base_Type (Typ), Invariant_Procedure (Typ));
- end if;
-
-- Volatile
if not Has_Rep_Item (Typ, Name_Volatile, False)
@@ -11477,6 +11576,7 @@ package body Sem_Ch13 is
procedure Initialize is
begin
Address_Clause_Checks.Init;
+ Compile_Time_Warnings_Errors.Init;
Unchecked_Conversions.Init;
if AAMP_On_Target then
@@ -11573,6 +11673,12 @@ package body Sem_Ch13 is
-- expression (i.e. if it is an identifier whose Chars field matches the
-- Nam given in the call). N must not be parenthesized, if the type name
-- appears in parens, this routine will return False.
+ --
+ -- The routine also returns True for function calls generated during the
+ -- expansion of comparison operators on strings, which are intended to
+ -- be legal in static predicates, and are converted into calls to array
+ -- comparison routines in the body of the corresponding predicate
+ -- function.
----------------------------------
-- All_Static_Case_Alternatives --
@@ -11637,9 +11743,10 @@ package body Sem_Ch13 is
function Is_Type_Ref (N : Node_Id) return Boolean is
begin
- return Nkind (N) = N_Identifier
- and then Chars (N) = Nam
- and then Paren_Count (N) = 0;
+ return (Nkind (N) = N_Identifier
+ and then Chars (N) = Nam
+ and then Paren_Count (N) = 0)
+ or else Nkind (N) = N_Function_Call;
end Is_Type_Ref;
-- Start of processing for Is_Predicate_Static
@@ -11689,10 +11796,12 @@ package body Sem_Ch13 is
-- and inequality operations to be valid on strings (this helps deal
-- with cases where we transform A in "ABC" to A = "ABC).
+ -- In fact, it appears that the intent of the ARG is to extend static
+ -- predicates to strings, and that the extension should probably apply
+ -- to static expressions themselves. The code below accepts comparison
+ -- operators that apply to static strings.
+
elsif Nkind (Expr) in N_Op_Compare
- and then ((not Is_String_Type (Etype (Left_Opnd (Expr))))
- or else (Nkind_In (Expr, N_Op_Eq, N_Op_Ne)
- and then not Comes_From_Source (Expr)))
and then ((Is_Type_Ref (Left_Opnd (Expr))
and then Is_OK_Static_Expression (Right_Opnd (Expr)))
or else
@@ -11741,9 +11850,11 @@ package body Sem_Ch13 is
-- to specify a static predicate for a subtype which is inheriting a
-- dynamic predicate, so the static predicate validation here ignores
-- the inherited predicate even if it is dynamic.
+ -- In all cases, a static predicate can only apply to a scalar type.
elsif Nkind (Expr) = N_Function_Call
and then Is_Predicate_Function (Entity (Name (Expr)))
+ and then Is_Scalar_Type (Etype (First_Entity (Entity (Name (Expr)))))
then
return True;
@@ -12019,7 +12130,9 @@ package body Sem_Ch13 is
-- at the freeze point, and we must generate only a completion of this
-- declaration. We do the same for private types, because the full view
-- might be tagged. Otherwise we generate a declaration at the point of
- -- the attribute definition clause.
+ -- the attribute definition clause. If the attribute definition comes
+ -- from an aspect specification the declaration is part of the freeze
+ -- actions of the type.
function Build_Spec return Node_Id;
-- Used for declaration and renaming declaration, so that this is
@@ -12111,18 +12224,32 @@ package body Sem_Ch13 is
Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc));
end if;
- Insert_Action (N, Subp_Decl);
- Set_Entity (N, Subp_Id);
+ if not Defer_Declaration
+ and then From_Aspect_Specification (N)
+ and then Has_Delayed_Freeze (Ent)
+ then
+ Append_Freeze_Action (Ent, Subp_Decl);
+
+ else
+ Insert_Action (N, Subp_Decl);
+ Set_Entity (N, Subp_Id);
+ end if;
Subp_Decl :=
Make_Subprogram_Renaming_Declaration (Loc,
Specification => Build_Spec,
- Name => New_Occurrence_Of (Subp, Loc));
+ Name => New_Occurrence_Of (Subp, Loc));
if Defer_Declaration then
Set_TSS (Base_Type (Ent), Subp_Id);
+
else
- Insert_Action (N, Subp_Decl);
+ if From_Aspect_Specification (N) then
+ Append_Freeze_Action (Ent, Subp_Decl);
+ else
+ Insert_Action (N, Subp_Decl);
+ end if;
+
Copy_TSS (Subp_Id, Base_Type (Ent));
end if;
end New_Stream_Subprogram;
@@ -12136,7 +12263,7 @@ package body Sem_Ch13 is
if Has_Discriminants (E) then
Push_Scope (E);
- -- Make discriminants visible for type declarations and protected
+ -- Make the discriminants visible for type declarations and protected
-- type declarations, not for subtype declarations (RM 13.1.1 (12/3))
if Nkind (Parent (E)) /= N_Subtype_Declaration then
@@ -12264,6 +12391,18 @@ package body Sem_Ch13 is
and then Comes_From_Source (T)
then
+ -- A self-referential aspect is illegal if it forces freezing the
+ -- entity before the corresponding pragma has been analyzed.
+
+ if Nkind_In (N, N_Attribute_Definition_Clause, N_Pragma)
+ and then From_Aspect_Specification (N)
+ then
+ Error_Msg_NE
+ ("aspect specification causes premature freezing of&", N, T);
+ Set_Has_Delayed_Freeze (T, False);
+ return True;
+ end if;
+
Too_Late;
S := First_Subtype (T);
@@ -12379,38 +12518,92 @@ package body Sem_Ch13 is
procedure Replace_Type_References_Generic (N : Node_Id; T : Entity_Id) is
TName : constant Name_Id := Chars (T);
- function Replace_Node (N : Node_Id) return Traverse_Result;
+ function Replace_Type_Ref (N : Node_Id) return Traverse_Result;
-- Processes a single node in the traversal procedure below, checking
-- if node N should be replaced, and if so, doing the replacement.
- procedure Replace_Type_Refs is new Traverse_Proc (Replace_Node);
- -- This instantiation provides the body of Replace_Type_References
+ function Visible_Component (Comp : Name_Id) return Entity_Id;
+ -- Given an identifier in the expression, check whether there is a
+ -- discriminant or component of the type that is directy visible, and
+ -- rewrite it as the corresponding selected component of the formal of
+ -- the subprogram. The entity is located by a sequential search, which
+ -- seems acceptable given the typical size of component lists and check
+ -- expressions. Possible optimization ???
- ------------------
- -- Replace_Node --
- ------------------
+ ----------------------
+ -- Replace_Type_Ref --
+ ----------------------
- function Replace_Node (N : Node_Id) return Traverse_Result is
- S : Entity_Id;
- P : Node_Id;
+ function Replace_Type_Ref (N : Node_Id) return Traverse_Result is
+ Loc : constant Source_Ptr := Sloc (N);
- begin
- -- Case of identifier
+ procedure Add_Prefix (Ref : Node_Id; Comp : Entity_Id);
+ -- Add the proper prefix to a reference to a component of the type
+ -- when it is not already a selected component.
+
+ ----------------
+ -- Add_Prefix --
+ ----------------
+
+ procedure Add_Prefix (Ref : Node_Id; Comp : Entity_Id) is
+ begin
+ Rewrite (Ref,
+ Make_Selected_Component (Loc,
+ Prefix => New_Occurrence_Of (T, Loc),
+ Selector_Name => New_Occurrence_Of (Comp, Loc)));
+ Replace_Type_Reference (Prefix (Ref));
+ end Add_Prefix;
+
+ -- Local variables
+
+ Comp : Entity_Id;
+ Pref : Node_Id;
+ Scop : Entity_Id;
+ -- Start of processing for Replace_Type_Ref
+
+ begin
if Nkind (N) = N_Identifier then
- -- If not the type name, check whether it is a reference to
- -- some other type, which must be frozen before the predicate
- -- function is analyzed, i.e. before the freeze node of the
- -- type to which the predicate applies.
+ -- If not the type name, check whether it is a reference to some
+ -- other type, which must be frozen before the predicate function
+ -- is analyzed, i.e. before the freeze node of the type to which
+ -- the predicate applies.
if Chars (N) /= TName then
if Present (Current_Entity (N))
- and then Is_Type (Current_Entity (N))
+ and then Is_Type (Current_Entity (N))
then
Freeze_Before (Freeze_Node (T), Current_Entity (N));
end if;
+ -- The components of the type are directly visible and can
+ -- be referenced without a prefix.
+
+ if Nkind (Parent (N)) = N_Selected_Component then
+ null;
+
+ -- In expression C (I), C may be a directly visible function
+ -- or a visible component that has an array type. Disambiguate
+ -- by examining the component type.
+
+ elsif Nkind (Parent (N)) = N_Indexed_Component
+ and then N = Prefix (Parent (N))
+ then
+ Comp := Visible_Component (Chars (N));
+
+ if Present (Comp) and then Is_Array_Type (Etype (Comp)) then
+ Add_Prefix (N, Comp);
+ end if;
+
+ else
+ Comp := Visible_Component (Chars (N));
+
+ if Present (Comp) then
+ Add_Prefix (N, Comp);
+ end if;
+ end if;
+
return Skip;
-- Otherwise do the replacement and we are done with this node
@@ -12420,13 +12613,13 @@ package body Sem_Ch13 is
return Skip;
end if;
- -- Case of selected component (which is what a qualification
- -- looks like in the unanalyzed tree, which is what we have.
+ -- Case of selected component (which is what a qualification looks
+ -- like in the unanalyzed tree, which is what we have.
elsif Nkind (N) = N_Selected_Component then
- -- If selector name is not our type, keeping going (we might
- -- still have an occurrence of the type in the prefix).
+ -- If selector name is not our type, keeping going (we might still
+ -- have an occurrence of the type in the prefix).
if Nkind (Selector_Name (N)) /= N_Identifier
or else Chars (Selector_Name (N)) /= TName
@@ -12438,35 +12631,35 @@ package body Sem_Ch13 is
else
-- Loop through scopes and prefixes, doing comparison
- S := Current_Scope;
- P := Prefix (N);
+ Scop := Current_Scope;
+ Pref := Prefix (N);
loop
-- Continue if no more scopes or scope with no name
- if No (S) or else Nkind (S) not in N_Has_Chars then
+ if No (Scop) or else Nkind (Scop) not in N_Has_Chars then
return OK;
end if;
- -- Do replace if prefix is an identifier matching the
- -- scope that we are currently looking at.
+ -- Do replace if prefix is an identifier matching the scope
+ -- that we are currently looking at.
- if Nkind (P) = N_Identifier
- and then Chars (P) = Chars (S)
+ if Nkind (Pref) = N_Identifier
+ and then Chars (Pref) = Chars (Scop)
then
Replace_Type_Reference (N);
return Skip;
end if;
- -- Go check scope above us if prefix is itself of the
- -- form of a selected component, whose selector matches
- -- the scope we are currently looking at.
+ -- Go check scope above us if prefix is itself of the form
+ -- of a selected component, whose selector matches the scope
+ -- we are currently looking at.
- if Nkind (P) = N_Selected_Component
- and then Nkind (Selector_Name (P)) = N_Identifier
- and then Chars (Selector_Name (P)) = Chars (S)
+ if Nkind (Pref) = N_Selected_Component
+ and then Nkind (Selector_Name (Pref)) = N_Identifier
+ and then Chars (Selector_Name (Pref)) = Chars (Scop)
then
- S := Scope (S);
- P := Prefix (P);
+ Scop := Scope (Scop);
+ Pref := Prefix (Pref);
-- For anything else, we don't have a match, so keep on
-- going, there are still some weird cases where we may
@@ -12483,7 +12676,41 @@ package body Sem_Ch13 is
else
return OK;
end if;
- end Replace_Node;
+ end Replace_Type_Ref;
+
+ procedure Replace_Type_Refs is new Traverse_Proc (Replace_Type_Ref);
+
+ -----------------------
+ -- Visible_Component --
+ -----------------------
+
+ function Visible_Component (Comp : Name_Id) return Entity_Id is
+ E : Entity_Id;
+
+ begin
+
+ -- Types with nameable components are records and discriminated
+ -- private types.
+
+ if Ekind (T) = E_Record_Type
+ or else (Is_Private_Type (T) and then Has_Discriminants (T))
+ then
+ E := First_Entity (T);
+ while Present (E) loop
+ if Comes_From_Source (E) and then Chars (E) = Comp then
+ return E;
+ end if;
+
+ Next_Entity (E);
+ end loop;
+ end if;
+
+ -- Nothing by that name, or type has no components.
+
+ return Empty;
+ end Visible_Component;
+
+ -- Start of processing for Replace_Type_References_Generic
begin
Replace_Type_Refs (N);
@@ -12498,6 +12725,51 @@ package body Sem_Ch13 is
A_Id : Aspect_Id;
Expr : Node_Id;
+ function Resolve_Name (N : Node_Id) return Traverse_Result;
+ -- Verify that all identifiers in the expression, with the exception
+ -- of references to the current entity, denote visible entities. This
+ -- is done only to detect visibility errors, as the expression will be
+ -- properly analyzed/expanded during analysis of the predicate function
+ -- body. We omit quantified expressions from this test, given that they
+ -- introduce a local identifier that would require proper expansion to
+ -- handle properly.
+
+ -- In ASIS_Mode we preserve the entity in the source because there is
+ -- no subsequent expansion to decorate the tree.
+
+ ------------------
+ -- Resolve_Name --
+ ------------------
+
+ function Resolve_Name (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) = N_Selected_Component then
+ if Nkind (Prefix (N)) = N_Identifier
+ and then Chars (Prefix (N)) /= Chars (E)
+ then
+ Find_Selected_Component (N);
+ end if;
+
+ return Skip;
+
+ elsif Nkind (N) = N_Identifier and then Chars (N) /= Chars (E) then
+ Find_Direct_Name (N);
+
+ if True or else not ASIS_Mode then -- ????
+ Set_Entity (N, Empty);
+ end if;
+
+ elsif Nkind (N) = N_Quantified_Expression then
+ return Skip;
+ end if;
+
+ return OK;
+ end Resolve_Name;
+
+ procedure Resolve_Aspect_Expression is new Traverse_Proc (Resolve_Name);
+
+ -- Start of processing for Resolve_Aspect_Expressions
+
begin
ASN := First_Rep_Item (E);
while Present (ASN) loop
@@ -12506,17 +12778,33 @@ package body Sem_Ch13 is
Expr := Expression (ASN);
case A_Id is
+
-- For now we only deal with aspects that do not generate
-- subprograms, or that may mention current instances of
-- types. These will require special handling (???TBD).
- when Aspect_Predicate |
- Aspect_Predicate_Failure |
- Aspect_Invariant |
- Aspect_Static_Predicate |
- Aspect_Dynamic_Predicate =>
+ when Aspect_Invariant
+ | Aspect_Predicate
+ | Aspect_Predicate_Failure
+ =>
null;
+ when Aspect_Dynamic_Predicate
+ | Aspect_Static_Predicate
+ =>
+ -- Build predicate function specification and preanalyze
+ -- expression after type replacement.
+
+ if No (Predicate_Function (E)) then
+ declare
+ FDecl : constant Node_Id :=
+ Build_Predicate_Function_Declaration (E);
+ pragma Unreferenced (FDecl);
+ begin
+ Resolve_Aspect_Expression (Expr);
+ end;
+ end if;
+
when Pre_Post_Aspects =>
null;
@@ -12537,18 +12825,19 @@ package body Sem_Ch13 is
when others =>
if Present (Expr) then
case Aspect_Argument (A_Id) is
- when Expression | Optional_Expression =>
+ when Expression
+ | Optional_Expression
+ =>
Analyze_And_Resolve (Expression (ASN));
- when Name | Optional_Name =>
+ when Name
+ | Optional_Name
+ =>
if Nkind (Expr) = N_Identifier then
Find_Direct_Name (Expr);
elsif Nkind (Expr) = N_Selected_Component then
Find_Selected_Component (Expr);
-
- else
- null;
end if;
end case;
end if;
@@ -13061,6 +13350,53 @@ package body Sem_Ch13 is
------------------------------
procedure Validate_Address_Clauses is
+ function Offset_Value (Expr : Node_Id) return Uint;
+ -- Given an Address attribute reference, return the value in bits of its
+ -- offset from the first bit of the underlying entity, or 0 if it is not
+ -- known at compile time.
+
+ ------------------
+ -- Offset_Value --
+ ------------------
+
+ function Offset_Value (Expr : Node_Id) return Uint is
+ N : Node_Id := Prefix (Expr);
+ Off : Uint;
+ Val : Uint := Uint_0;
+
+ begin
+ -- Climb the prefix chain and compute the cumulative offset
+
+ loop
+ if Is_Entity_Name (N) then
+ return Val;
+
+ elsif Nkind (N) = N_Selected_Component then
+ Off := Component_Bit_Offset (Entity (Selector_Name (N)));
+ if Off /= No_Uint and then Off >= Uint_0 then
+ Val := Val + Off;
+ N := Prefix (N);
+ else
+ return Uint_0;
+ end if;
+
+ elsif Nkind (N) = N_Indexed_Component then
+ Off := Indexed_Component_Bit_Offset (N);
+ if Off /= No_Uint then
+ Val := Val + Off;
+ N := Prefix (N);
+ else
+ return Uint_0;
+ end if;
+
+ else
+ return Uint_0;
+ end if;
+ end loop;
+ end Offset_Value;
+
+ -- Start of processing for Validate_Address_Clauses
+
begin
for J in Address_Clause_Checks.First .. Address_Clause_Checks.Last loop
declare
@@ -13075,27 +13411,56 @@ package body Sem_Ch13 is
X_Size : Uint;
Y_Size : Uint;
+ X_Offs : Uint;
+
begin
-- Skip processing of this entry if warning already posted
if not Address_Warning_Posted (ACCR.N) then
Expr := Original_Node (Expression (ACCR.N));
- -- Get alignments
+ -- Get alignments, sizes and offset, if any
X_Alignment := Alignment (ACCR.X);
- Y_Alignment := Alignment (ACCR.Y);
+ X_Size := Esize (ACCR.X);
+
+ if Present (ACCR.Y) then
+ Y_Alignment := Alignment (ACCR.Y);
+ Y_Size := Esize (ACCR.Y);
+ end if;
- -- Similarly obtain sizes
+ if ACCR.Off
+ and then Nkind (Expr) = N_Attribute_Reference
+ and then Attribute_Name (Expr) = Name_Address
+ then
+ X_Offs := Offset_Value (Expr);
+ else
+ X_Offs := Uint_0;
+ end if;
+
+ -- Check for known value not multiple of alignment
+
+ if No (ACCR.Y) then
+ if not Alignment_Checks_Suppressed (ACCR.X)
+ and then X_Alignment /= 0
+ and then ACCR.A mod X_Alignment /= 0
+ then
+ Error_Msg_NE
+ ("??specified address for& is inconsistent with "
+ & "alignment", ACCR.N, ACCR.X);
+ Error_Msg_N
+ ("\??program execution may be erroneous (RM 13.3(27))",
+ ACCR.N);
- X_Size := Esize (ACCR.X);
- Y_Size := Esize (ACCR.Y);
+ Error_Msg_Uint_1 := X_Alignment;
+ Error_Msg_NE ("\??alignment of & is ^", ACCR.N, ACCR.X);
+ end if;
-- Check for large object overlaying smaller one
- if Y_Size > Uint_0
+ elsif Y_Size > Uint_0
and then X_Size > Uint_0
- and then X_Size > Y_Size
+ and then X_Offs + X_Size > Y_Size
then
Error_Msg_NE ("??& overlays smaller object", ACCR.N, ACCR.X);
Error_Msg_N
@@ -13107,6 +13472,11 @@ package body Sem_Ch13 is
Error_Msg_Uint_1 := Y_Size;
Error_Msg_NE ("\??size of & is ^", ACCR.N, ACCR.Y);
+ if Y_Size >= X_Size then
+ Error_Msg_Uint_1 := X_Offs;
+ Error_Msg_NE ("\??but offset of & is ^", ACCR.N, ACCR.X);
+ end if;
+
-- Check for inadequate alignment, both of the base object
-- and of the offset, if any. We only do this check if the
-- run-time Alignment_Check is active. No point in warning
@@ -13116,7 +13486,7 @@ package body Sem_Ch13 is
-- Note: we do not check the alignment if we gave a size
-- warning, since it would likely be redundant.
- elsif not Alignment_Checks_Suppressed (ACCR.Y)
+ elsif not Alignment_Checks_Suppressed (ACCR.X)
and then Y_Alignment /= Uint_0
and then
(Y_Alignment < X_Alignment
@@ -13151,6 +13521,79 @@ package body Sem_Ch13 is
end loop;
end Validate_Address_Clauses;
+ -----------------------------------------
+ -- Validate_Compile_Time_Warning_Error --
+ -----------------------------------------
+
+ procedure Validate_Compile_Time_Warning_Error (N : Node_Id) is
+ begin
+ Compile_Time_Warnings_Errors.Append
+ (New_Val => CTWE_Entry'(Eloc => Sloc (N),
+ Scope => Current_Scope,
+ Prag => N));
+ end Validate_Compile_Time_Warning_Error;
+
+ ------------------------------------------
+ -- Validate_Compile_Time_Warning_Errors --
+ ------------------------------------------
+
+ procedure Validate_Compile_Time_Warning_Errors is
+ procedure Set_Scope (S : Entity_Id);
+ -- Install all enclosing scopes of S along with S itself
+
+ procedure Unset_Scope (S : Entity_Id);
+ -- Uninstall all enclosing scopes of S along with S itself
+
+ ---------------
+ -- Set_Scope --
+ ---------------
+
+ procedure Set_Scope (S : Entity_Id) is
+ begin
+ if S /= Standard_Standard then
+ Set_Scope (Scope (S));
+ end if;
+
+ Push_Scope (S);
+ end Set_Scope;
+
+ -----------------
+ -- Unset_Scope --
+ -----------------
+
+ procedure Unset_Scope (S : Entity_Id) is
+ begin
+ if S /= Standard_Standard then
+ Unset_Scope (Scope (S));
+ end if;
+
+ Pop_Scope;
+ end Unset_Scope;
+
+ -- Start of processing for Validate_Compile_Time_Warning_Errors
+
+ begin
+ Expander_Mode_Save_And_Set (False);
+ In_Compile_Time_Warning_Or_Error := True;
+
+ for N in Compile_Time_Warnings_Errors.First ..
+ Compile_Time_Warnings_Errors.Last
+ loop
+ declare
+ T : CTWE_Entry renames Compile_Time_Warnings_Errors.Table (N);
+
+ begin
+ Set_Scope (T.Scope);
+ Reset_Analyzed_Flags (T.Prag);
+ Process_Compile_Time_Warning_Or_Error (T.Prag, T.Eloc);
+ Unset_Scope (T.Scope);
+ end;
+ end loop;
+
+ In_Compile_Time_Warning_Or_Error := False;
+ Expander_Mode_Restore;
+ end Validate_Compile_Time_Warning_Errors;
+
---------------------------
-- Validate_Independence --
---------------------------
@@ -13637,7 +14080,7 @@ package body Sem_Ch13 is
Target => Target,
Act_Unit => Act_Unit));
- -- If both sizes are known statically now, then back end annotation
+ -- If both sizes are known statically now, then back-end annotation
-- is not required to do a proper check but if either size is not
-- known statically, then we need the annotation.
@@ -13690,10 +14133,10 @@ package body Sem_Ch13 is
declare
T : UC_Entry renames Unchecked_Conversions.Table (N);
+ Act_Unit : constant Entity_Id := T.Act_Unit;
Eloc : constant Source_Ptr := T.Eloc;
Source : constant Entity_Id := T.Source;
Target : constant Entity_Id := T.Target;
- Act_Unit : constant Entity_Id := T.Act_Unit;
Source_Siz : Uint;
Target_Siz : Uint;
diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads
index 8ae9294109..b99c56fa1b 100644
--- a/gcc/ada/sem_ch13.ads
+++ b/gcc/ada/sem_ch13.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -50,27 +50,9 @@ package Sem_Ch13 is
procedure Adjust_Record_For_Reverse_Bit_Order (R : Entity_Id);
-- Called from Freeze where R is a record entity for which reverse bit
- -- order is specified and there is at least one component clause. Adjusts
- -- component positions according to either Ada 95 or Ada 2005 (AI-133).
-
- function Build_Invariant_Procedure_Declaration
- (Typ : Entity_Id) return Node_Id;
- -- If a type declaration has a specified invariant aspect, build the
- -- declaration for the procedure at once, so that calls to it can be
- -- generated before the body of the invariant procedure is built. This
- -- is needed in the presence of public expression functions that return
- -- the type in question.
-
- procedure Build_Invariant_Procedure (Typ : Entity_Id; N : Node_Id);
- -- Typ is a private type with invariants (indicated by Has_Invariants being
- -- set for Typ, indicating the presence of pragma Invariant entries on the
- -- rep chain, note that Invariant aspects have already been converted to
- -- pragma Invariant), then this procedure builds the spec and body for the
- -- corresponding Invariant procedure, inserting them at appropriate points
- -- in the package specification N. Invariant_Procedure is set for Typ. Note
- -- that this procedure is called at the end of processing the declarations
- -- in the visible part (i.e. the right point for visibility analysis of
- -- the invariant expression).
+ -- order is specified and there is at least one component clause. Note:
+ -- component positions are normally adjusted as per AI95-0133, unless
+ -- -gnatd.p is used to restore original Ada 95 mode.
procedure Check_Record_Representation_Clause (N : Node_Id);
-- This procedure completes the analysis of a record representation clause
@@ -207,6 +189,18 @@ package Sem_Ch13 is
-- change. A False result is possible only for array, enumeration or
-- record types.
+ procedure Validate_Compile_Time_Warning_Error (N : Node_Id);
+ -- N is a pragma Compile_Time_Error or Compile_Warning_Error whose boolean
+ -- expression is not known at compile time. This procedure makes an entry
+ -- in a table. The actual checking is performed by Validate_Compile_Time_
+ -- Warning_Errors, which is invoked after calling the back end.
+
+ procedure Validate_Compile_Time_Warning_Errors;
+ -- This routine is called after calling the back end to validate pragmas
+ -- Compile_Time_Error and Compile_Time_Warning for size and alignment
+ -- appropriateness. The reason it is called that late is to take advantage
+ -- of any back-annotation of size and alignment performed by the back end.
+
procedure Validate_Unchecked_Conversion
(N : Node_Id;
Act_Unit : Entity_Id);
@@ -219,10 +213,10 @@ package Sem_Ch13 is
-- back end as required.
procedure Validate_Unchecked_Conversions;
- -- This routine is called after calling the backend to validate unchecked
+ -- This routine is called after calling the back end to validate unchecked
-- conversions for size and alignment appropriateness. The reason it is
-- called that late is to take advantage of any back-annotation of size
- -- and alignment performed by the backend.
+ -- and alignment performed by the back end.
procedure Validate_Address_Clauses;
-- This is called after the back end has been called (and thus after the
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 35d2b9810b..7c3f7e601c 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -33,6 +33,7 @@ with Einfo; use Einfo;
with Errout; use Errout;
with Eval_Fat; use Eval_Fat;
with Exp_Ch3; use Exp_Ch3;
+with Exp_Ch7; use Exp_Ch7;
with Exp_Ch9; use Exp_Ch9;
with Exp_Disp; use Exp_Disp;
with Exp_Dist; use Exp_Dist;
@@ -646,17 +647,6 @@ package body Sem_Ch3 is
-- present. If errors are found, error messages are posted, and the
-- Real_Range_Specification of Def is reset to Empty.
- procedure Propagate_Default_Init_Cond_Attributes
- (From_Typ : Entity_Id;
- To_Typ : Entity_Id;
- Parent_To_Derivation : Boolean := False;
- Private_To_Full_View : Boolean := False);
- -- Subsidiary to routines Build_Derived_Type and Process_Full_View. Inherit
- -- all attributes related to pragma Default_Initial_Condition from From_Typ
- -- to To_Typ. Flag Parent_To_Derivation should be set when the context is
- -- the creation of a derived type. Flag Private_To_Full_View should be set
- -- when processing both views of a private type.
-
procedure Record_Type_Declaration
(T : Entity_Id;
N : Node_Id;
@@ -1343,7 +1333,9 @@ package body Sem_Ch3 is
if Nkind (S) /= N_Subtype_Indication then
Analyze (S);
- if Ekind (Root_Type (Entity (S))) = E_Incomplete_Type then
+ if Present (Entity (S))
+ and then Ekind (Root_Type (Entity (S))) = E_Incomplete_Type
+ then
Set_Directly_Designated_Type (T, Entity (S));
-- If the designated type is a limited view, we cannot tell if
@@ -1415,7 +1407,7 @@ package body Sem_Ch3 is
elsif Is_Class_Wide_Type (Full_Desig) and then Etype (Full_Desig) = T
then
Error_Msg_N
- ("access type cannot designate its own classwide type", S);
+ ("access type cannot designate its own class-wide type", S);
-- Clean up indication of tagged status to prevent cascaded errors
@@ -1437,8 +1429,9 @@ package body Sem_Ch3 is
-- and to Has_Protected.
Set_Has_Task (T, False);
- Set_Has_Controlled_Component (T, False);
Set_Has_Protected (T, False);
+ Set_Has_Timing_Event (T, False);
+ Set_Has_Controlled_Component (T, False);
-- Initialize field Finalization_Master explicitly to Empty, to avoid
-- problems where an incomplete view of this entity has been previously
@@ -1857,7 +1850,6 @@ package body Sem_Ch3 is
when others =>
return False;
-
end case;
end Contains_POC;
@@ -2164,16 +2156,45 @@ package body Sem_Ch3 is
-- (They have the sloc of the label as found in the source, and that
-- is ahead of the current declarative part).
+ procedure Build_Assertion_Bodies (Decls : List_Id; Context : Node_Id);
+ -- Create the subprogram bodies which verify the run-time semantics of
+ -- the pragmas listed below for each elibigle type found in declarative
+ -- list Decls. The pragmas are:
+ --
+ -- Default_Initial_Condition
+ -- Invariant
+ -- Type_Invariant
+ --
+ -- Context denotes the owner of the declarative list.
+
+ procedure Check_Entry_Contracts;
+ -- Perform a pre-analysis of the pre- and postconditions of an entry
+ -- declaration. This must be done before full resolution and creation
+ -- of the parameter block, etc. to catch illegal uses within the
+ -- contract expression. Full analysis of the expression is done when
+ -- the contract is processed.
+
procedure Handle_Late_Controlled_Primitive (Body_Decl : Node_Id);
-- Determine whether Body_Decl denotes the body of a late controlled
-- primitive (either Initialize, Adjust or Finalize). If this is the
-- case, add a proper spec if the body lacks one. The spec is inserted
- -- before Body_Decl and immedately analyzed.
+ -- before Body_Decl and immediately analyzed.
+
+ procedure Remove_Partial_Visible_Refinements (Spec_Id : Entity_Id);
+ -- Spec_Id is the entity of a package that may define abstract states,
+ -- and in the case of a child unit, whose ancestors may define abstract
+ -- states. If the states have partial visible refinement, remove the
+ -- partial visibility of each constituent at the end of the package
+ -- spec and body declarations.
procedure Remove_Visible_Refinements (Spec_Id : Entity_Id);
-- Spec_Id is the entity of a package that may define abstract states.
-- If the states have visible refinement, remove the visibility of each
- -- constituent at the end of the package body declarations.
+ -- constituent at the end of the package body declaration.
+
+ procedure Resolve_Aspects;
+ -- Utility to resolve the expressions of aspects at the end of a list of
+ -- declarations.
-----------------
-- Adjust_Decl --
@@ -2188,6 +2209,135 @@ package body Sem_Ch3 is
end loop;
end Adjust_Decl;
+ ----------------------------
+ -- Build_Assertion_Bodies --
+ ----------------------------
+
+ procedure Build_Assertion_Bodies (Decls : List_Id; Context : Node_Id) is
+ procedure Build_Assertion_Bodies_For_Type (Typ : Entity_Id);
+ -- Create the subprogram bodies which verify the run-time semantics
+ -- of the pragmas listed below for type Typ. The pragmas are:
+ --
+ -- Default_Initial_Condition
+ -- Invariant
+ -- Type_Invariant
+
+ -------------------------------------
+ -- Build_Assertion_Bodies_For_Type --
+ -------------------------------------
+
+ procedure Build_Assertion_Bodies_For_Type (Typ : Entity_Id) is
+ begin
+ -- Preanalyze and resolve the Default_Initial_Condition assertion
+ -- expression at the end of the declarations to catch any errors.
+
+ if Has_DIC (Typ) then
+ Build_DIC_Procedure_Body (Typ);
+ end if;
+
+ if Nkind (Context) = N_Package_Specification then
+
+ -- Preanalyze and resolve the invariants of a private type
+ -- at the end of the visible declarations to catch potential
+ -- errors. Inherited class-wide invariants are not included
+ -- because they have already been resolved.
+
+ if Decls = Visible_Declarations (Context)
+ and then Ekind_In (Typ, E_Limited_Private_Type,
+ E_Private_Type,
+ E_Record_Type_With_Private)
+ and then Has_Own_Invariants (Typ)
+ then
+ Build_Invariant_Procedure_Body
+ (Typ => Typ,
+ Partial_Invariant => True);
+
+ -- Preanalyze and resolve the invariants of a private type's
+ -- full view at the end of the private declarations to catch
+ -- potential errors.
+
+ elsif Decls = Private_Declarations (Context)
+ and then not Is_Private_Type (Typ)
+ and then Has_Private_Declaration (Typ)
+ and then Has_Invariants (Typ)
+ then
+ Build_Invariant_Procedure_Body (Typ);
+ end if;
+ end if;
+ end Build_Assertion_Bodies_For_Type;
+
+ -- Local variables
+
+ Decl : Node_Id;
+ Decl_Id : Entity_Id;
+
+ -- Start of processing for Build_Assertion_Bodies
+
+ begin
+ Decl := First (Decls);
+ while Present (Decl) loop
+ if Is_Declaration (Decl) then
+ Decl_Id := Defining_Entity (Decl);
+
+ if Is_Type (Decl_Id) then
+ Build_Assertion_Bodies_For_Type (Decl_Id);
+ end if;
+ end if;
+
+ Next (Decl);
+ end loop;
+ end Build_Assertion_Bodies;
+
+ ---------------------------
+ -- Check_Entry_Contracts --
+ ---------------------------
+
+ procedure Check_Entry_Contracts is
+ ASN : Node_Id;
+ Ent : Entity_Id;
+ Exp : Node_Id;
+
+ begin
+ Ent := First_Entity (Current_Scope);
+ while Present (Ent) loop
+
+ -- This only concerns entries with pre/postconditions
+
+ if Ekind (Ent) = E_Entry
+ and then Present (Contract (Ent))
+ and then Present (Pre_Post_Conditions (Contract (Ent)))
+ then
+ ASN := Pre_Post_Conditions (Contract (Ent));
+ Push_Scope (Ent);
+ Install_Formals (Ent);
+
+ -- Pre/postconditions are rewritten as Check pragmas. Analysis
+ -- is performed on a copy of the pragma expression, to prevent
+ -- modifying the original expression.
+
+ while Present (ASN) loop
+ if Nkind (ASN) = N_Pragma then
+ Exp :=
+ New_Copy_Tree
+ (Expression
+ (First (Pragma_Argument_Associations (ASN))));
+ Set_Parent (Exp, ASN);
+
+ -- ??? why not Preanalyze_Assert_Expression
+
+ Preanalyze (Exp);
+ end if;
+
+ ASN := Next_Pragma (ASN);
+ end loop;
+
+ End_Scope;
+ end if;
+
+ Next_Entity (Ent);
+ end loop;
+ end Check_Entry_Contracts;
+
--------------------------------------
-- Handle_Late_Controlled_Primitive --
--------------------------------------
@@ -2269,10 +2419,37 @@ package body Sem_Ch3 is
Set_Null_Present (Spec, False);
- Insert_Before_And_Analyze (Body_Decl,
- Make_Subprogram_Declaration (Loc, Specification => Spec));
+ -- Ensure that the freeze node is inserted after the declaration of
+ -- the primitive since its expansion will freeze the primitive.
+
+ Decl := Make_Subprogram_Declaration (Loc, Specification => Spec);
+
+ Insert_Before_And_Analyze (Body_Decl, Decl);
end Handle_Late_Controlled_Primitive;
+ ----------------------------------------
+ -- Remove_Partial_Visible_Refinements --
+ ----------------------------------------
+
+ procedure Remove_Partial_Visible_Refinements (Spec_Id : Entity_Id) is
+ State_Elmt : Elmt_Id;
+ begin
+ if Present (Abstract_States (Spec_Id)) then
+ State_Elmt := First_Elmt (Abstract_States (Spec_Id));
+ while Present (State_Elmt) loop
+ Set_Has_Partial_Visible_Refinement (Node (State_Elmt), False);
+ Next_Elmt (State_Elmt);
+ end loop;
+ end if;
+
+ -- For a child unit, also hide the partial state refinement from
+ -- ancestor packages.
+
+ if Is_Child_Unit (Spec_Id) then
+ Remove_Partial_Visible_Refinements (Scope (Spec_Id));
+ end if;
+ end Remove_Partial_Visible_Refinements;
+
--------------------------------
-- Remove_Visible_Refinements --
--------------------------------
@@ -2289,6 +2466,21 @@ package body Sem_Ch3 is
end if;
end Remove_Visible_Refinements;
+ ---------------------
+ -- Resolve_Aspects --
+ ---------------------
+
+ procedure Resolve_Aspects is
+ E : Entity_Id;
+
+ begin
+ E := First_Entity (Current_Scope);
+ while Present (E) loop
+ Resolve_Aspect_Expressions (E);
+ Next_Entity (E);
+ end loop;
+ end Resolve_Aspects;
+
-- Local variables
Context : Node_Id := Empty;
@@ -2298,6 +2490,10 @@ package body Sem_Ch3 is
Body_Seen : Boolean := False;
-- Flag set when the first body [stub] is encountered
+ Ignore_Freezing : Boolean;
+ -- Flag set when deciding to freeze an expression function in the
+ -- current scope.
+
-- Start of processing for Analyze_Declarations
begin
@@ -2344,12 +2540,14 @@ package body Sem_Ch3 is
-- (This is needed in any case for early instantiations ???).
if No (Next_Decl) then
- if Nkind_In (Parent (L), N_Component_List,
- N_Task_Definition,
- N_Protected_Definition)
- then
+ if Nkind (Parent (L)) = N_Component_List then
null;
+ elsif Nkind_In (Parent (L), N_Protected_Definition,
+ N_Task_Definition)
+ then
+ Check_Entry_Contracts;
+
elsif Nkind (Parent (L)) /= N_Package_Specification then
if Nkind (Parent (L)) = N_Package_Body then
Freeze_From := First_Entity (Current_Scope);
@@ -2365,17 +2563,42 @@ package body Sem_Ch3 is
Freeze_All (First_Entity (Current_Scope), Decl);
Freeze_From := Last_Entity (Current_Scope);
+ -- Current scope is a package specification
+
elsif Scope (Current_Scope) /= Standard_Standard
and then not Is_Child_Unit (Current_Scope)
and then No (Generic_Parent (Parent (L)))
then
- null;
+ -- This is needed in all cases to catch visibility errors in
+ -- aspect expressions, but several large user tests are now
+ -- rejected. Pending notification we restrict this call to
+ -- ASIS mode.
+
+ if False and then ASIS_Mode then -- ????
+ Resolve_Aspects;
+ end if;
elsif L /= Visible_Declarations (Parent (L))
- or else No (Private_Declarations (Parent (L)))
- or else Is_Empty_List (Private_Declarations (Parent (L)))
+ or else No (Private_Declarations (Parent (L)))
+ or else Is_Empty_List (Private_Declarations (Parent (L)))
then
Adjust_Decl;
+
+ -- End of a package declaration
+
+ -- In compilation mode the expansion of freeze node takes care
+ -- of resolving expressions of all aspects in the list. In ASIS
+ -- mode this must be done explicitly.
+
+ if ASIS_Mode
+ and then Scope (Current_Scope) = Standard_Standard
+ then
+ Resolve_Aspects;
+ end if;
+
+ -- This is a freeze point because it is the end of a
+ -- compilation unit.
+
Freeze_All (First_Entity (Current_Scope), Decl);
Freeze_From := Last_Entity (Current_Scope);
@@ -2391,16 +2614,7 @@ package body Sem_Ch3 is
-- pragmas do not appear in the original generic tree.
elsif Serious_Errors_Detected = 0 then
- declare
- E : Entity_Id;
-
- begin
- E := First_Entity (Current_Scope);
- while Present (E) loop
- Resolve_Aspect_Expressions (E);
- Next_Entity (E);
- end loop;
- end;
+ Resolve_Aspects;
end if;
-- If next node is a body then freeze all types before the body.
@@ -2420,49 +2634,97 @@ package body Sem_Ch3 is
elsif not Analyzed (Next_Decl) and then Is_Body (Next_Decl) then
- -- When a controlled type is frozen, the expander generates stream
- -- and controlled type support routines. If the freeze is caused
- -- by the stand alone body of Initialize, Adjust and Finalize, the
- -- expander will end up using the wrong version of these routines
- -- as the body has not been processed yet. To remedy this, detect
- -- a late controlled primitive and create a proper spec for it.
- -- This ensures that the primitive will override its inherited
- -- counterpart before the freeze takes place.
+ -- Check for an edge case that may cause premature freezing of
+ -- a private type. If there is a type which depends on another
+ -- private type from an enclosing package that is in the same
+ -- scope as a non-completing expression function then we cannot
+ -- freeze here.
- -- If the declaration we just processed is a body, do not attempt
- -- to examine Next_Decl as the late primitive idiom can only apply
- -- to the first encountered body.
+ Ignore_Freezing := False;
- -- The spec of the late primitive is not generated in ASIS mode to
- -- ensure a consistent list of primitives that indicates the true
- -- semantic structure of the program (which is not relevant when
- -- generating executable code.
+ if Nkind (Next_Decl) = N_Subprogram_Body
+ and then Was_Expression_Function (Next_Decl)
+ and then not Is_Compilation_Unit (Current_Scope)
+ and then not Is_Generic_Instance (Current_Scope)
+ then
+ -- Loop through all entities in the current scope to identify
+ -- an instance of the edge case outlined above and ignore
+ -- freezing if it is detected.
- -- ??? a cleaner approach may be possible and/or this solution
- -- could be extended to general-purpose late primitives, TBD.
+ declare
+ Curr : Entity_Id := First_Entity (Current_Scope);
+ begin
+ loop
+ if Nkind (Curr) in N_Entity
+ and then Depends_On_Private (Curr)
+ then
+ Ignore_Freezing := True;
+ exit;
+ end if;
- if not ASIS_Mode and then not Body_Seen and then not Is_Body (Decl)
- then
- Body_Seen := True;
+ exit when Last_Entity (Current_Scope) = Curr;
+ Curr := Next_Entity (Curr);
+ end loop;
+ end;
+ end if;
+
+ if not Ignore_Freezing then
+
+ -- When a controlled type is frozen, the expander generates
+ -- stream and controlled-type support routines. If the freeze
+ -- is caused by the stand-alone body of Initialize, Adjust, or
+ -- Finalize, the expander will end up using the wrong version
+ -- of these routines, as the body has not been processed yet.
+ -- To remedy this, detect a late controlled primitive and
+ -- create a proper spec for it. This ensures that the primitive
+ -- will override its inherited counterpart before the freeze
+ -- takes place.
+
+ -- If the declaration we just processed is a body, do not
+ -- attempt to examine Next_Decl as the late primitive idiom can
+ -- only apply to the first encountered body.
+
+ -- The spec of the late primitive is not generated in ASIS mode
+ -- to ensure a consistent list of primitives that indicates the
+ -- true semantic structure of the program (which is not
+ -- relevant when generating executable code).
+
+ -- ??? A cleaner approach may be possible and/or this solution
+ -- could be extended to general-purpose late primitives, TBD.
+
+ if not ASIS_Mode
+ and then not Body_Seen
+ and then not Is_Body (Decl)
+ then
+ Body_Seen := True;
- if Nkind (Next_Decl) = N_Subprogram_Body then
- Handle_Late_Controlled_Primitive (Next_Decl);
+ if Nkind (Next_Decl) = N_Subprogram_Body then
+ Handle_Late_Controlled_Primitive (Next_Decl);
+ end if;
end if;
- end if;
- Adjust_Decl;
- Freeze_All (Freeze_From, Decl);
- Freeze_From := Last_Entity (Current_Scope);
+ Adjust_Decl;
+
+ -- The generated body of an expression function does not
+ -- freeze, unless it is a completion, in which case only the
+ -- expression itself freezes. This is handled when the body
+ -- itself is analyzed (see Freeze_Expr_Types, sem_ch6.adb).
+
+ Freeze_All (Freeze_From, Decl);
+ Freeze_From := Last_Entity (Current_Scope);
+ end if;
end if;
Decl := Next_Decl;
end loop;
- -- Analyze the contracts of packages and their bodies
+ -- Post-freezing actions
if Present (L) then
Context := Parent (L);
+ -- Analyze the contracts of packages and their bodies
+
if Nkind (Context) = N_Package_Specification then
-- When a package has private declarations, its contract must be
@@ -2473,15 +2735,6 @@ package body Sem_Ch3 is
if L = Private_Declarations (Context) then
Analyze_Package_Contract (Defining_Entity (Context));
- -- Build the bodies of the default initial condition procedures
- -- for all types subject to pragma Default_Initial_Condition.
- -- From a purely Ada stand point, this is a freezing activity,
- -- however freezing is not available under GNATprove_Mode. To
- -- accomodate both scenarios, the bodies are build at the end
- -- of private declaration analysis.
-
- Build_Default_Init_Cond_Procedure_Bodies (L);
-
-- Otherwise the contract is analyzed at the end of the visible
-- declarations.
@@ -2512,7 +2765,32 @@ package body Sem_Ch3 is
-- restore the original state conditions.
Remove_Visible_Refinements (Corresponding_Spec (Context));
+ Remove_Partial_Visible_Refinements (Corresponding_Spec (Context));
+
+ elsif Nkind (Context) = N_Package_Declaration then
+
+ -- Partial state refinements are visible up to the end of the
+ -- package spec declarations. Hide the partial state refinements
+ -- from visibility to restore the original state conditions.
+
+ Remove_Partial_Visible_Refinements (Corresponding_Spec (Context));
end if;
+
+ -- Verify that all abstract states found in any package declared in
+ -- the input declarative list have proper refinements. The check is
+ -- performed only when the context denotes a block, entry, package,
+ -- protected, subprogram, or task body (SPARK RM 7.2.2(3)).
+
+ Check_State_Refinements (Context);
+
+ -- Create the subprogram bodies which verify the run-time semantics
+ -- of pragmas Default_Initial_Condition and [Type_]Invariant for all
+ -- types within the current declarative list. This ensures that all
+ -- assertion expressions are preanalyzed and resolved at the end of
+ -- the declarative part. Note that the resolution happens even when
+ -- freezing does not take place.
+
+ Build_Assertion_Bodies (L, Context);
end if;
end Analyze_Declarations;
@@ -2549,44 +2827,48 @@ package body Sem_Ch3 is
----------------------------------
procedure Check_Nonoverridable_Aspects is
- Prev_Aspects : constant List_Id :=
- Aspect_Specifications (Parent (Def_Id));
- Par_Type : Entity_Id;
-
- function Has_Aspect_Spec
- (Specs : List_Id;
- Aspect_Name : Name_Id) return Boolean;
+ function Get_Aspect_Spec
+ (Specs : List_Id;
+ Aspect_Name : Name_Id) return Node_Id;
-- Check whether a list of aspect specifications includes an entry
-- for a specific aspect. The list is either that of a partial or
-- a full view.
---------------------
- -- Has_Aspect_Spec --
+ -- Get_Aspect_Spec --
---------------------
- function Has_Aspect_Spec
- (Specs : List_Id;
- Aspect_Name : Name_Id) return Boolean
+ function Get_Aspect_Spec
+ (Specs : List_Id;
+ Aspect_Name : Name_Id) return Node_Id
is
Spec : Node_Id;
+
begin
Spec := First (Specs);
while Present (Spec) loop
if Chars (Identifier (Spec)) = Aspect_Name then
- return True;
+ return Spec;
end if;
Next (Spec);
end loop;
- return False;
- end Has_Aspect_Spec;
+
+ return Empty;
+ end Get_Aspect_Spec;
+
+ -- Local variables
+
+ Prev_Aspects : constant List_Id :=
+ Aspect_Specifications (Parent (Def_Id));
+ Par_Type : Entity_Id;
+ Prev_Aspect : Node_Id;
-- Start of processing for Check_Nonoverridable_Aspects
begin
-
- -- Get parent type of derived type. Note that Prev is the entity
- -- in the partial declaration, but its contents are now those of
- -- full view, while Def_Id reflects the partial view.
+ -- Get parent type of derived type. Note that Prev is the entity in
+ -- the partial declaration, but its contents are now those of full
+ -- view, while Def_Id reflects the partial view.
if Is_Private_Type (Def_Id) then
Par_Type := Etype (Full_View (Def_Id));
@@ -2602,8 +2884,13 @@ package body Sem_Ch3 is
and then Present (Discriminant_Specifications (Parent (Prev)))
and then Present (Get_Reference_Discriminant (Par_Type))
then
- if
- not Has_Aspect_Spec (Prev_Aspects, Name_Implicit_Dereference)
+ Prev_Aspect :=
+ Get_Aspect_Spec (Prev_Aspects, Name_Implicit_Dereference);
+
+ if No (Prev_Aspect)
+ and then Present
+ (Discriminant_Specifications
+ (Original_Node (Parent (Prev))))
then
Error_Msg_N
("type does not inherit implicit dereference", Prev);
@@ -2613,14 +2900,28 @@ package body Sem_Ch3 is
-- is consistent with that of the parent.
declare
- Par_Discr : constant Entity_Id :=
+ Par_Discr : constant Entity_Id :=
Get_Reference_Discriminant (Par_Type);
- Cur_Discr : constant Entity_Id :=
+ Cur_Discr : constant Entity_Id :=
Get_Reference_Discriminant (Prev);
+
begin
if Corresponding_Discriminant (Cur_Discr) /= Par_Discr then
Error_Msg_N ("aspect incosistent with that of parent", N);
end if;
+
+ -- Check that specification in partial view matches the
+ -- inherited aspect. Compare names directly because aspect
+ -- expression may not be analyzed.
+
+ if Present (Prev_Aspect)
+ and then Nkind (Expression (Prev_Aspect)) = N_Identifier
+ and then Chars (Expression (Prev_Aspect)) /=
+ Chars (Cur_Discr)
+ then
+ Error_Msg_N
+ ("aspect incosistent with that of parent", N);
+ end if;
end;
end if;
end if;
@@ -2802,7 +3103,6 @@ package body Sem_Ch3 is
when others =>
raise Program_Error;
-
end case;
end if;
@@ -2816,13 +3116,6 @@ package body Sem_Ch3 is
Check_SPARK_05_Restriction ("controlled type is not allowed", N);
end if;
- -- A type declared within a Ghost region is automatically Ghost
- -- (SPARK RM 6.9(2)).
-
- if Ghost_Mode > None then
- Set_Is_Ghost_Entity (T);
- end if;
-
-- Some common processing for all types
Set_Depends_On_Private (T, Has_Private_Component (T));
@@ -2915,9 +3208,9 @@ package body Sem_Ch3 is
and then Chars (Def_Id) = Name_Address
and then Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (N)))
then
- Set_Is_Descendent_Of_Address (Def_Id);
- Set_Is_Descendent_Of_Address (Base_Type (Def_Id));
- Set_Is_Descendent_Of_Address (Prev);
+ Set_Is_Descendant_Of_Address (Def_Id);
+ Set_Is_Descendant_Of_Address (Base_Type (Def_Id));
+ Set_Is_Descendant_Of_Address (Prev);
end if;
Set_Optimize_Alignment_Flags (Def_Id);
@@ -2982,13 +3275,6 @@ package body Sem_Ch3 is
Set_Is_First_Subtype (T, True);
Set_Etype (T, T);
- -- An incomplete type declared within a Ghost region is automatically
- -- Ghost (SPARK RM 6.9(2)).
-
- if Ghost_Mode > None then
- Set_Is_Ghost_Entity (T);
- end if;
-
-- Ada 2005 (AI-326): Minimum decoration to give support to tagged
-- incomplete types.
@@ -3096,13 +3382,6 @@ package body Sem_Ch3 is
Generate_Definition (Id);
Enter_Name (Id);
- -- A number declared within a Ghost region is automatically Ghost
- -- (SPARK RM 6.9(2)).
-
- if Ghost_Mode > None then
- Set_Is_Ghost_Entity (Id);
- end if;
-
-- This is an optimization of a common case of an integer literal
if Nkind (E) = N_Integer_Literal then
@@ -3168,7 +3447,7 @@ package body Sem_Ch3 is
end loop;
end if;
- if Is_Integer_Type (T) then
+ if Is_Integer_Type (T) then
Resolve (E, T);
Set_Etype (Id, Universal_Integer);
Set_Ekind (Id, E_Named_Integer);
@@ -3234,6 +3513,10 @@ package body Sem_Ch3 is
-- Analyze_Object_Declaration --
--------------------------------
+ -- WARNING: This routine manages Ghost regions. Return statements must be
+ -- replaced by gotos which jump to the end of the routine and restore the
+ -- Ghost mode.
+
procedure Analyze_Object_Declaration (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Id : constant Entity_Id := Defining_Identifier (N);
@@ -3345,8 +3628,9 @@ package body Sem_Ch3 is
-- Local variables
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
- Related_Id : Entity_Id;
+ Mode : Ghost_Mode_Type;
+ Mode_Set : Boolean := False;
+ Related_Id : Entity_Id;
-- Start of processing for Analyze_Object_Declaration
@@ -3395,20 +3679,30 @@ package body Sem_Ch3 is
N_Package_Renaming_Declaration
and then not Comes_From_Source (Prev_Entity)
and then
- Is_Generic_Instance (Renamed_Entity (Prev_Entity))))
+ Is_Generic_Instance (Renamed_Entity (Prev_Entity)))
+
+ -- The entity may be a homonym of a private component of the
+ -- enclosing protected object, for which we create a local
+ -- renaming declaration. The declaration is legal, even if
+ -- useless when it just captures that component.
+
+ or else
+ (Ekind (Scope (Current_Scope)) = E_Protected_Type
+ and then Nkind (Parent (Prev_Entity)) =
+ N_Object_Renaming_Declaration))
then
Prev_Entity := Empty;
end if;
end if;
- -- The object declaration is Ghost when it is subject to pragma Ghost or
- -- completes a deferred Ghost constant. Set the mode now to ensure that
- -- any nodes generated during analysis and expansion are properly marked
- -- as Ghost.
+ if Present (Prev_Entity) then
+
+ -- The object declaration is Ghost when it completes a deferred Ghost
+ -- constant.
- Set_Ghost_Mode (N, Prev_Entity);
+ Mark_And_Set_Ghost_Completion (N, Prev_Entity, Mode);
+ Mode_Set := True;
- if Present (Prev_Entity) then
Constant_Redeclaration (Id, N, T);
Generate_Reference (Prev_Entity, Id, 'c');
@@ -3416,7 +3710,7 @@ package body Sem_Ch3 is
if Error_Posted (N) then
- -- Type mismatch or illegal redeclaration, Do not analyze
+ -- Type mismatch or illegal redeclaration; do not analyze
-- expression to avoid cascaded errors.
T := Find_Type_Of_Object (Object_Definition (N), N);
@@ -3453,13 +3747,13 @@ package body Sem_Ch3 is
end if;
-- Ada 2005 (AI-231): Propagate the null-excluding attribute and carry
- -- out some static checks
+ -- out some static checks.
if Ada_Version >= Ada_2005 and then Can_Never_Be_Null (T) then
-- In case of aggregates we must also take care of the correct
-- initialization of nested aggregates bug this is done at the
- -- point of the analysis of the aggregate (see sem_aggr.adb).
+ -- point of the analysis of the aggregate (see sem_aggr.adb) ???
if Present (Expression (N))
and then Nkind (Expression (N)) = N_Aggregate
@@ -3553,9 +3847,7 @@ package body Sem_Ch3 is
-- Special checks for protected objects not at library level
- if Is_Protected_Type (T)
- and then not Is_Library_Level_Entity (Id)
- then
+ if Has_Protected (T) and then not Is_Library_Level_Entity (Id) then
Check_Restriction (No_Local_Protected_Objects, Id);
-- Protected objects with interrupt handlers must be at library level
@@ -3567,12 +3859,21 @@ package body Sem_Ch3 is
-- AI05-0303: The AI is in fact a binding interpretation, and thus
-- applies to the '95 version of the language as well.
- if Has_Interrupt_Handler (T) and then Ada_Version < Ada_95 then
+ if Is_Protected_Type (T)
+ and then Has_Interrupt_Handler (T)
+ and then Ada_Version < Ada_95
+ then
Error_Msg_N
("interrupt object can only be declared at library level", Id);
end if;
end if;
+ -- Check for violation of No_Local_Timing_Events
+
+ if Has_Timing_Event (T) and then not Is_Library_Level_Entity (Id) then
+ Check_Restriction (No_Local_Timing_Events, Id);
+ end if;
+
-- The actual subtype of the object is the nominal subtype, unless
-- the nominal one is unconstrained and obtained from the expression.
@@ -3695,8 +3996,7 @@ package body Sem_Ch3 is
and then Analyzed (N)
and then No (Expression (N))
then
- Ghost_Mode := Save_Ghost_Mode;
- return;
+ goto Leave;
end if;
-- If E is null and has been replaced by an N_Raise_Constraint_Error
@@ -3776,12 +4076,16 @@ package body Sem_Ch3 is
-- A formal parameter of a specific tagged type whose related
-- subprogram is subject to pragma Extensions_Visible with value
-- "False" cannot be implicitly converted to a class-wide type by
- -- means of an initialization expression (SPARK RM 6.1.7(3)).
+ -- means of an initialization expression (SPARK RM 6.1.7(3)). Do
+ -- not consider internally generated expressions.
- if Is_Class_Wide_Type (T) and then Is_EVF_Expression (E) then
+ if Is_Class_Wide_Type (T)
+ and then Comes_From_Source (E)
+ and then Is_EVF_Expression (E)
+ then
Error_Msg_N
- ("formal parameter with Extensions_Visible False cannot be "
- & "implicitly converted to class-wide type", E);
+ ("formal parameter cannot be implicitly converted to "
+ & "class-wide type when Extensions_Visible is False", E);
end if;
end if;
@@ -3803,14 +4107,15 @@ package body Sem_Ch3 is
-- do this in the analyzer and not the expander because the analyzer
-- does some substantial rewriting in some cases.
- -- We need a predicate check if the type has predicates, and if either
- -- there is an initializing expression, or for default initialization
- -- when we have at least one case of an explicit default initial value
- -- and then this is not an internal declaration whose initialization
- -- comes later (as for an aggregate expansion).
+ -- We need a predicate check if the type has predicates that are not
+ -- ignored, and if either there is an initializing expression, or for
+ -- default initialization when we have at least one case of an explicit
+ -- default initial value and then this is not an internal declaration
+ -- whose initialization comes later (as for an aggregate expansion).
if not Suppress_Assignment_Checks (N)
and then Present (Predicate_Function (T))
+ and then not Predicates_Ignored (T)
and then not No_Initialization (N)
and then
(Present (E)
@@ -3824,8 +4129,16 @@ package body Sem_Ch3 is
Check_Expression_Against_Static_Predicate (E, T);
end if;
- Insert_After (N,
- Make_Predicate_Check (T, New_Occurrence_Of (Id, Loc)));
+ -- If the type is a null record and there is no explicit initial
+ -- expression, no predicate check applies.
+
+ if No (E) and then Is_Null_Record_Type (T) then
+ null;
+
+ else
+ Insert_After (N,
+ Make_Predicate_Check (T, New_Occurrence_Of (Id, Loc)));
+ end if;
end if;
-- Case of unconstrained type
@@ -3941,23 +4254,6 @@ package body Sem_Ch3 is
Set_Ekind (Id, E_Variable);
end if;
- -- An object declared within a Ghost region is automatically
- -- Ghost (SPARK RM 6.9(2)).
-
- if Ghost_Mode > None then
- Set_Is_Ghost_Entity (Id);
-
- -- The Ghost policy in effect at the point of declaration
- -- and at the point of completion must match
- -- (SPARK RM 6.9(14)).
-
- if Present (Prev_Entity)
- and then Is_Ghost_Entity (Prev_Entity)
- then
- Check_Ghost_Completion (Prev_Entity, Id);
- end if;
- end if;
-
Rewrite (N,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Id,
@@ -3967,9 +4263,7 @@ package body Sem_Ch3 is
Set_Renamed_Object (Id, E);
Freeze_Before (N, T);
Set_Is_Frozen (Id);
-
- Ghost_Mode := Save_Ghost_Mode;
- return;
+ goto Leave;
else
-- Ensure that the generated subtype has a unique external name
@@ -4006,7 +4300,10 @@ package body Sem_Ch3 is
elsif Is_Array_Type (T)
and then No_Initialization (N)
- and then Nkind (Original_Node (E)) = N_Aggregate
+ and then (Nkind (Original_Node (E)) = N_Aggregate
+ or else (Nkind (Original_Node (E)) = N_Qualified_Expression
+ and then Nkind (Original_Node (Expression
+ (Original_Node (E)))) = N_Aggregate))
then
if not Is_Entity_Name (Object_Definition (N)) then
Act_T := Etype (E);
@@ -4036,9 +4333,10 @@ package body Sem_Ch3 is
elsif Nkind (E) = N_Aggregate
and then Present (Component_Associations (E))
- and then Present (Choices (First (Component_Associations (E))))
- and then Nkind (First
- (Choices (First (Component_Associations (E))))) = N_Others_Choice
+ and then Present (Choice_List (First (Component_Associations (E))))
+ and then
+ Nkind (First (Choice_List (First (Component_Associations (E))))) =
+ N_Others_Choice
then
null;
@@ -4140,22 +4438,6 @@ package body Sem_Ch3 is
Init_Esize (Id);
Set_Optimize_Alignment_Flags (Id);
- -- An object declared within a Ghost region is automatically Ghost
- -- (SPARK RM 6.9(2)).
-
- if Ghost_Mode > None
- or else (Present (Prev_Entity) and then Is_Ghost_Entity (Prev_Entity))
- then
- Set_Is_Ghost_Entity (Id);
-
- -- The Ghost policy in effect at the point of declaration and at the
- -- point of completion must match (SPARK RM 6.9(14)).
-
- if Present (Prev_Entity) and then Is_Ghost_Entity (Prev_Entity) then
- Check_Ghost_Completion (Prev_Entity, Id);
- end if;
- end if;
-
-- Deal with aliased case
if Aliased_Present (N) then
@@ -4290,7 +4572,7 @@ package body Sem_Ch3 is
-- type, rewrite the declaration as a renaming of the result of the
-- call. The exceptions below are cases where the copy is expected,
-- either by the back end (Aliased case) or by the semantics, as for
- -- initializing controlled types or copying tags for classwide types.
+ -- initializing controlled types or copying tags for class-wide types.
if Present (E)
and then Nkind (E) = N_Explicit_Dereference
@@ -4337,15 +4619,6 @@ package body Sem_Ch3 is
Set_In_Private_Part (Id);
end if;
- -- Check for violation of No_Local_Timing_Events
-
- if Restriction_Check_Required (No_Local_Timing_Events)
- and then not Is_Library_Level_Entity (Id)
- and then Is_RTE (Etype (Id), RE_Timing_Event)
- then
- Check_Restriction (No_Local_Timing_Events, N);
- end if;
-
<<Leave>>
-- Initialize the refined state of a variable here because this is a
-- common destination for legal and illegal object declarations.
@@ -4367,7 +4640,9 @@ package body Sem_Ch3 is
Check_No_Hidden_State (Id);
end if;
- Ghost_Mode := Save_Ghost_Mode;
+ if Mode_Set then
+ Restore_Ghost_Mode (Mode);
+ end if;
end Analyze_Object_Declaration;
---------------------------
@@ -4390,6 +4665,8 @@ package body Sem_Ch3 is
procedure Analyze_Private_Extension_Declaration (N : Node_Id) is
Indic : constant Node_Id := Subtype_Indication (N);
T : constant Entity_Id := Defining_Identifier (N);
+ Iface : Entity_Id;
+ Iface_Elmt : Elmt_Id;
Parent_Base : Entity_Id;
Parent_Type : Entity_Id;
@@ -4455,8 +4732,8 @@ package body Sem_Ch3 is
elsif Is_Concurrent_Type (Parent_Type) then
Error_Msg_N
- ("parent type of a private extension cannot be "
- & "a synchronized tagged type (RM 3.9.1 (3/1))", N);
+ ("parent type of a private extension cannot be a synchronized "
+ & "tagged type (RM 3.9.1 (3/1))", N);
Set_Etype (T, Any_Type);
Set_Ekind (T, E_Limited_Private_Type);
@@ -4477,7 +4754,6 @@ package body Sem_Ch3 is
if (not Is_Package_Or_Generic_Package (Current_Scope)
and then Nkind (Parent (N)) /= N_Generic_Subprogram_Declaration)
or else In_Private_Part (Current_Scope)
-
then
Error_Msg_N ("invalid context for private extension", N);
end if;
@@ -4490,9 +4766,8 @@ package body Sem_Ch3 is
Init_Size_Align (T);
Set_Default_SSO (T);
- Set_Etype (T, Parent_Base);
- Set_Has_Task (T, Has_Task (Parent_Base));
- Set_Has_Protected (T, Has_Task (Parent_Base));
+ Set_Etype (T, Parent_Base);
+ Propagate_Concurrent_Flags (T, Parent_Base);
Set_Convention (T, Convention (Parent_Type));
Set_First_Rep_Item (T, First_Rep_Item (Parent_Type));
@@ -4505,13 +4780,35 @@ package body Sem_Ch3 is
Build_Derived_Record_Type (N, Parent_Type, T);
- -- Propagate inherited invariant information. The new type has
- -- invariants, if the parent type has inheritable invariants,
- -- and these invariants can in turn be inherited.
+ -- A private extension inherits the Default_Initial_Condition pragma
+ -- coming from any parent type within the derivation chain.
+
+ if Has_DIC (Parent_Type) then
+ Set_Has_Inherited_DIC (T);
+ end if;
+
+ -- A private extension inherits any class-wide invariants coming from a
+ -- parent type or an interface. Note that the invariant procedure of the
+ -- parent type should not be inherited because the private extension may
+ -- define invariants of its own.
+
+ if Has_Inherited_Invariants (Parent_Type)
+ or else Has_Inheritable_Invariants (Parent_Type)
+ then
+ Set_Has_Inherited_Invariants (T);
+
+ elsif Present (Interfaces (T)) then
+ Iface_Elmt := First_Elmt (Interfaces (T));
+ while Present (Iface_Elmt) loop
+ Iface := Node (Iface_Elmt);
+
+ if Has_Inheritable_Invariants (Iface) then
+ Set_Has_Inherited_Invariants (T);
+ exit;
+ end if;
- if Has_Inheritable_Invariants (Parent_Type) then
- Set_Has_Inheritable_Invariants (T);
- Set_Has_Invariants (T);
+ Next_Elmt (Iface_Elmt);
+ end loop;
end if;
-- Ada 2005 (AI-443): Synchronized private extension or a rewritten
@@ -4533,33 +4830,29 @@ package body Sem_Ch3 is
(not Is_Interface (Parent_Type)
or else not Is_Synchronized_Interface (Parent_Type))
then
- Error_Msg_NE ("parent type of & must be tagged limited " &
- "or synchronized", N, T);
+ Error_Msg_NE
+ ("parent type of & must be tagged limited or synchronized",
+ N, T);
end if;
-- The progenitors (if any) must be limited or synchronized
-- interfaces.
if Present (Interfaces (T)) then
- declare
- Iface : Entity_Id;
- Iface_Elmt : Elmt_Id;
-
- begin
- Iface_Elmt := First_Elmt (Interfaces (T));
- while Present (Iface_Elmt) loop
- Iface := Node (Iface_Elmt);
+ Iface_Elmt := First_Elmt (Interfaces (T));
+ while Present (Iface_Elmt) loop
+ Iface := Node (Iface_Elmt);
- if not Is_Limited_Interface (Iface)
- and then not Is_Synchronized_Interface (Iface)
- then
- Error_Msg_NE ("progenitor & must be limited " &
- "or synchronized", N, Iface);
- end if;
+ if not Is_Limited_Interface (Iface)
+ and then not Is_Synchronized_Interface (Iface)
+ then
+ Error_Msg_NE
+ ("progenitor & must be limited or synchronized",
+ N, Iface);
+ end if;
- Next_Elmt (Iface_Elmt);
- end loop;
- end;
+ Next_Elmt (Iface_Elmt);
+ end loop;
end if;
-- Regular derived extension, the parent must be a limited or
@@ -4698,6 +4991,24 @@ package body Sem_Ch3 is
then
Set_Has_Predicates (Id);
Set_Has_Delayed_Freeze (Id);
+
+ -- Generated subtypes inherit the predicate function from the parent
+ -- (no aspects to examine on the generated declaration).
+
+ if not Comes_From_Source (N) then
+ Set_Ekind (Id, Ekind (T));
+
+ if Present (Predicate_Function (T)) then
+ Set_Predicate_Function (Id, Predicate_Function (T));
+
+ elsif Present (Ancestor_Subtype (T))
+ and then Has_Predicates (Ancestor_Subtype (T))
+ and then Present (Predicate_Function (Ancestor_Subtype (T)))
+ then
+ Set_Predicate_Function (Id,
+ Predicate_Function (Ancestor_Subtype (T)));
+ end if;
+ end if;
end if;
-- Subtype of Boolean cannot have a constraint in SPARK
@@ -4769,8 +5080,8 @@ package body Sem_Ch3 is
case Ekind (T) is
when Array_Kind =>
- Set_Ekind (Id, E_Array_Subtype);
- Copy_Array_Subtype_Attributes (Id, T);
+ Set_Ekind (Id, E_Array_Subtype);
+ Copy_Array_Subtype_Attributes (Id, T);
when Decimal_Fixed_Point_Kind =>
Set_Ekind (Id, E_Decimal_Fixed_Point_Subtype);
@@ -4842,7 +5153,9 @@ package body Sem_Ch3 is
Set_Equivalent_Type (Id, Equivalent_Type (T));
end if;
- when E_Record_Type | E_Record_Subtype =>
+ when E_Record_Subtype
+ | E_Record_Type
+ =>
Set_Ekind (Id, E_Record_Subtype);
if Ekind (T) = E_Record_Subtype
@@ -4997,7 +5310,7 @@ package body Sem_Ch3 is
Set_Stored_Constraint_From_Discriminant_Constraint (Id);
end if;
- when Incomplete_Kind =>
+ when Incomplete_Kind =>
if Ada_Version >= Ada_2005 then
-- In Ada 2005 an incomplete type can be explicitly tagged:
@@ -5059,11 +5372,36 @@ package body Sem_Ch3 is
Set_Is_Generic_Actual_Type (Id, Is_Generic_Actual_Type (T));
end if;
+ -- If this is a subtype declaration for an actual in an instance,
+ -- inherit static and dynamic predicates if any.
+
+ -- If declaration has no aspect specifications, inherit predicate
+ -- info as well. Unclear how to handle the case of both specified
+ -- and inherited predicates ??? Other inherited aspects, such as
+ -- invariants, should be OK, but the combination with later pragmas
+ -- may also require special merging.
+
+ if Has_Predicates (T)
+ and then Present (Predicate_Function (T))
+ and then
+ ((In_Instance and then not Comes_From_Source (N))
+ or else No (Aspect_Specifications (N)))
+ then
+ Set_Subprograms_For_Type (Id, Subprograms_For_Type (T));
+
+ if Has_Static_Predicate (T) then
+ Set_Has_Static_Predicate (Id);
+ Set_Static_Discrete_Predicate (Id, Static_Discrete_Predicate (T));
+ end if;
+ end if;
+
+ -- Remaining processing depends on characteristics of base type
+
T := Etype (Id);
Set_Is_Immediately_Visible (Id, True);
Set_Depends_On_Private (Id, Has_Private_Component (T));
- Set_Is_Descendent_Of_Address (Id, Is_Descendent_Of_Address (T));
+ Set_Is_Descendant_Of_Address (Id, Is_Descendant_Of_Address (T));
if Is_Interface (T) then
Set_Is_Interface (Id);
@@ -5118,9 +5456,9 @@ package body Sem_Ch3 is
if Nkind (Subtype_Indication (N)) = N_Subtype_Indication then
if Is_Scalar_Type (Etype (Id))
- and then Scalar_Range (Id) /=
- Scalar_Range (Etype (Subtype_Mark
- (Subtype_Indication (N))))
+ and then Scalar_Range (Id) /=
+ Scalar_Range
+ (Etype (Subtype_Mark (Subtype_Indication (N))))
then
Apply_Range_Check
(Scalar_Range (Id),
@@ -5191,28 +5529,6 @@ package body Sem_Ch3 is
end if;
end if;
- -- A type invariant applies to any subtype in its scope, in particular
- -- to a generic actual.
-
- if Has_Invariants (T) and then In_Open_Scopes (Scope (T)) then
- Set_Has_Invariants (Id);
- Set_Invariant_Procedure (Id, Invariant_Procedure (T));
- end if;
-
- -- Make sure that generic actual types are properly frozen. The subtype
- -- is marked as a generic actual type when the enclosing instance is
- -- analyzed, so here we identify the subtype from the tree structure.
-
- if Expander_Active
- and then Is_Generic_Actual_Type (Id)
- and then In_Instance
- and then not Comes_From_Source (N)
- and then Nkind (Subtype_Indication (N)) /= N_Subtype_Indication
- and then Is_Frozen (T)
- then
- Freeze_Before (N, Id);
- end if;
-
Set_Optimize_Alignment_Flags (Id);
Check_Eliminated (Id);
@@ -5348,13 +5664,13 @@ package body Sem_Ch3 is
procedure Array_Type_Declaration (T : in out Entity_Id; Def : Node_Id) is
Component_Def : constant Node_Id := Component_Definition (Def);
Component_Typ : constant Node_Id := Subtype_Indication (Component_Def);
+ P : constant Node_Id := Parent (Def);
Element_Type : Entity_Id;
Implicit_Base : Entity_Id;
Index : Node_Id;
- Related_Id : Entity_Id := Empty;
Nb_Index : Nat;
- P : constant Node_Id := Parent (Def);
Priv : Entity_Id;
+ Related_Id : Entity_Id := Empty;
begin
if Nkind (Def) = N_Constrained_Array_Definition then
@@ -5410,8 +5726,8 @@ package body Sem_Ch3 is
then
declare
Loc : constant Source_Ptr := Sloc (Def);
- New_E : Entity_Id;
Decl : Entity_Id;
+ New_E : Entity_Id;
begin
New_E := Make_Temporary (Loc, 'T');
@@ -5537,23 +5853,20 @@ package body Sem_Ch3 is
-- Complete setup of implicit base type
- Set_First_Index (Implicit_Base, First_Index (T));
- Set_Component_Type (Implicit_Base, Element_Type);
- Set_Has_Task (Implicit_Base, Has_Task (Element_Type));
- Set_Has_Protected (Implicit_Base, Has_Protected (Element_Type));
- Set_Component_Size (Implicit_Base, Uint_0);
- Set_Packed_Array_Impl_Type (Implicit_Base, Empty);
- Set_Has_Controlled_Component (Implicit_Base,
- Has_Controlled_Component (Element_Type)
- or else Is_Controlled_Active (Element_Type));
- Set_Finalize_Storage_Only (Implicit_Base,
- Finalize_Storage_Only (Element_Type));
-
- -- Inherit the "ghostness" from the constrained array type
+ Set_Component_Size (Implicit_Base, Uint_0);
+ Set_Component_Type (Implicit_Base, Element_Type);
+ Set_Finalize_Storage_Only
+ (Implicit_Base,
+ Finalize_Storage_Only (Element_Type));
+ Set_First_Index (Implicit_Base, First_Index (T));
+ Set_Has_Controlled_Component
+ (Implicit_Base,
+ Has_Controlled_Component (Element_Type)
+ or else Is_Controlled_Active (Element_Type));
+ Set_Packed_Array_Impl_Type
+ (Implicit_Base, Empty);
- if Ghost_Mode > None or else Is_Ghost_Entity (T) then
- Set_Is_Ghost_Entity (Implicit_Base);
- end if;
+ Propagate_Concurrent_Flags (Implicit_Base, Element_Type);
-- Unconstrained array case
@@ -5566,8 +5879,7 @@ package body Sem_Ch3 is
Set_Is_Constrained (T, False);
Set_First_Index (T, First (Subtype_Marks (Def)));
Set_Has_Delayed_Freeze (T, True);
- Set_Has_Task (T, Has_Task (Element_Type));
- Set_Has_Protected (T, Has_Protected (Element_Type));
+ Propagate_Concurrent_Flags (T, Element_Type);
Set_Has_Controlled_Component (T, Has_Controlled_Component
(Element_Type)
or else
@@ -5709,9 +6021,10 @@ package body Sem_Ch3 is
Set_Is_Internal (Anon);
case Nkind (N) is
- when N_Component_Declaration |
- N_Unconstrained_Array_Definition |
- N_Constrained_Array_Definition =>
+ when N_Constrained_Array_Definition
+ | N_Component_Declaration
+ | N_Unconstrained_Array_Definition
+ =>
Comp := Component_Definition (N);
Acc := Access_Definition (Comp);
@@ -5804,15 +6117,20 @@ package body Sem_Ch3 is
end if;
-- Insert the new declaration in the nearest enclosing scope. If the
- -- node is a body and N is its return type, the declaration belongs in
- -- the enclosing scope.
+ -- parent is a body and N is its return type, the declaration belongs
+ -- in the enclosing scope. Likewise if N is the type of a parameter.
P := Parent (N);
- if Nkind (P) = N_Subprogram_Body
- and then Nkind (N) = N_Function_Specification
+ if Nkind (N) = N_Function_Specification
+ and then Nkind (P) = N_Subprogram_Body
then
P := Parent (P);
+ elsif Nkind (N) = N_Parameter_Specification
+ and then Nkind (P) in N_Subprogram_Specification
+ and then Nkind (Parent (P)) = N_Subprogram_Body
+ then
+ P := Parent (Parent (P));
end if;
while Present (P) and then not Has_Declarations (P) loop
@@ -5927,6 +6245,11 @@ package body Sem_Ch3 is
begin
Copy_Node (Pbase, Ibase);
+ -- Restore Itype status after Copy_Node
+
+ Set_Is_Itype (Ibase);
+ Set_Associated_Node_For_Itype (Ibase, N);
+
Set_Chars (Ibase, Svg_Chars);
Set_Next_Entity (Ibase, Svg_Next_E);
Set_Sloc (Ibase, Sloc (Derived_Type));
@@ -5958,16 +6281,6 @@ package body Sem_Ch3 is
if Null_Exclusion_Present (Type_Definition (N)) then
Set_Can_Never_Be_Null (Derived_Type);
- -- What is with the "AND THEN FALSE" here ???
-
- if Can_Never_Be_Null (Parent_Type)
- and then False
- then
- Error_Msg_NE
- ("`NOT NULL` not allowed (& already excludes null)",
- N, Parent_Type);
- end if;
-
elsif Can_Never_Be_Null (Parent_Type) then
Set_Can_Never_Be_Null (Derived_Type);
end if;
@@ -5979,6 +6292,7 @@ package body Sem_Ch3 is
-- ??? THIS CODE SHOULD NOT BE HERE REALLY.
Desig_Type := Designated_Type (Derived_Type);
+
if Is_Composite_Type (Desig_Type)
and then (not Is_Array_Type (Desig_Type))
and then Has_Discriminants (Desig_Type)
@@ -6032,12 +6346,6 @@ package body Sem_Ch3 is
Copy_Array_Base_Type_Attributes (Implicit_Base, Parent_Base);
Set_Has_Delayed_Freeze (Implicit_Base, True);
-
- -- Inherit the "ghostness" from the parent base type
-
- if Ghost_Mode > None or else Is_Ghost_Entity (Parent_Base) then
- Set_Is_Ghost_Entity (Implicit_Base);
- end if;
end Make_Implicit_Base;
-- Start of processing for Build_Derived_Array_Type
@@ -6616,8 +6924,12 @@ package body Sem_Ch3 is
-- If we constructed a default range for the case where no range
-- was given, then the expressions in the range must not freeze
-- since they do not correspond to expressions in the source.
+ -- However, if the type inherits predicates the expressions will
+ -- be elaborated earlier and must freeze.
- if Nkind (Indic) /= N_Subtype_Indication then
+ if Nkind (Indic) /= N_Subtype_Indication
+ and then not Has_Predicates (Derived_Type)
+ then
Set_Must_Not_Freeze (Lo);
Set_Must_Not_Freeze (Hi);
Set_Must_Not_Freeze (Rang_Expr);
@@ -6745,10 +7057,10 @@ package body Sem_Ch3 is
Set_Is_Known_Valid (Derived_Type, Is_Known_Valid (Parent_Type));
end if;
- Set_Is_Descendent_Of_Address (Derived_Type,
- Is_Descendent_Of_Address (Parent_Type));
- Set_Is_Descendent_Of_Address (Implicit_Base,
- Is_Descendent_Of_Address (Parent_Type));
+ Set_Is_Descendant_Of_Address (Derived_Type,
+ Is_Descendant_Of_Address (Parent_Type));
+ Set_Is_Descendant_Of_Address (Implicit_Base,
+ Is_Descendant_Of_Address (Parent_Type));
-- Set remaining type-specific fields, depending on numeric type
@@ -7201,6 +7513,7 @@ package body Sem_Ch3 is
Set_Full_View (Derived_Type, Full_Der);
else
Set_Underlying_Full_View (Derived_Type, Full_Der);
+ Set_Is_Underlying_Full_View (Full_Der);
end if;
if not Is_Base_Type (Derived_Type) then
@@ -7258,6 +7571,7 @@ package body Sem_Ch3 is
Set_Full_View (Derived_Type, Full_Der);
else
Set_Underlying_Full_View (Derived_Type, Full_Der);
+ Set_Is_Underlying_Full_View (Full_Der);
end if;
-- In any case, the primitive operations are inherited from the
@@ -7364,6 +7678,7 @@ package body Sem_Ch3 is
else
Build_Full_Derivation;
Set_Underlying_Full_View (Derived_Type, Full_Der);
+ Set_Is_Underlying_Full_View (Full_Der);
end if;
-- The full view will be used to swap entities on entry/exit to
@@ -8391,7 +8706,7 @@ package body Sem_Ch3 is
-- However, if the record contains an array constrained by
-- the discriminant but with some different bound, the compiler
- -- attemps to create a smaller range for the discriminant type.
+ -- tries to create a smaller range for the discriminant type.
-- (See exp_ch3.Adjust_Discriminants). In this case, where
-- the discriminant type is a scalar type, the check must use
-- the original discriminant type in the parent declaration.
@@ -8691,36 +9006,6 @@ package body Sem_Ch3 is
end;
end if;
- -- Propagate inherited invariant information of parents
- -- and progenitors
-
- if Ada_Version >= Ada_2012
- and then not Is_Interface (Derived_Type)
- then
- if Has_Inheritable_Invariants (Parent_Type) then
- Set_Has_Invariants (Derived_Type);
- Set_Has_Inheritable_Invariants (Derived_Type);
-
- elsif not Is_Empty_Elmt_List (Ifaces_List) then
- declare
- AI : Elmt_Id;
-
- begin
- AI := First_Elmt (Ifaces_List);
- while Present (AI) loop
- if Has_Inheritable_Invariants (Node (AI)) then
- Set_Has_Invariants (Derived_Type);
- Set_Has_Inheritable_Invariants (Derived_Type);
-
- exit;
- end if;
-
- Next_Elmt (AI);
- end loop;
- end;
- end if;
- end if;
-
-- A type extension is automatically Ghost when one of its
-- progenitors is Ghost (SPARK RM 6.9(9)). This property is
-- also inherited when the parent type is Ghost, but this is
@@ -8757,6 +9042,9 @@ package body Sem_Ch3 is
-- STEP 5a: Copy the parent record declaration for untagged types
+ Set_Has_Implicit_Dereference
+ (Derived_Type, Has_Implicit_Dereference (Parent_Type));
+
if not Is_Tagged then
-- Discriminant_Constraint (Derived_Type) has been properly
@@ -8799,8 +9087,6 @@ package body Sem_Ch3 is
Set_Stored_Constraint
(Derived_Type, Expand_To_Stored_Constraint (Parent_Type, Discs));
Replace_Components (Derived_Type, New_Decl);
- Set_Has_Implicit_Dereference
- (Derived_Type, Has_Implicit_Dereference (Parent_Type));
end if;
-- Insert the new derived type declaration
@@ -8913,12 +9199,11 @@ package body Sem_Ch3 is
begin
-- Set common attributes
- Set_Scope (Derived_Type, Current_Scope);
+ Set_Scope (Derived_Type, Current_Scope);
- Set_Etype (Derived_Type, Parent_Base);
- Set_Ekind (Derived_Type, Ekind (Parent_Base));
- Set_Has_Task (Derived_Type, Has_Task (Parent_Base));
- Set_Has_Protected (Derived_Type, Has_Protected (Parent_Base));
+ Set_Etype (Derived_Type, Parent_Base);
+ Set_Ekind (Derived_Type, Ekind (Parent_Base));
+ Propagate_Concurrent_Flags (Derived_Type, Parent_Base);
Set_Size_Info (Derived_Type, Parent_Type);
Set_RM_Size (Derived_Type, RM_Size (Parent_Type));
@@ -8953,13 +9238,62 @@ package body Sem_Ch3 is
Set_Default_SSO (Derived_Type);
end if;
- -- Propagate invariant information. The new type has invariants if
- -- they are inherited from the parent type, and these invariants can
- -- be further inherited, so both flags are set.
+ -- A derived type inherits the Default_Initial_Condition pragma coming
+ -- from any parent type within the derivation chain.
+
+ if Has_DIC (Parent_Type) then
+ Set_Has_Inherited_DIC (Derived_Type);
+ end if;
- -- We similarly inherit predicates
+ -- A derived type inherits any class-wide invariants coming from a
+ -- parent type or an interface. Note that the invariant procedure of
+ -- the parent type should not be inherited because the derived type may
+ -- define invariants of its own.
- if Has_Predicates (Parent_Type) then
+ if not Is_Interface (Derived_Type) then
+ if Has_Inherited_Invariants (Parent_Type)
+ or else Has_Inheritable_Invariants (Parent_Type)
+ then
+ Set_Has_Inherited_Invariants (Derived_Type);
+
+ elsif Is_Concurrent_Type (Derived_Type)
+ or else Is_Tagged_Type (Derived_Type)
+ then
+ declare
+ Iface : Entity_Id;
+ Ifaces : Elist_Id;
+ Iface_Elmt : Elmt_Id;
+
+ begin
+ Collect_Interfaces
+ (T => Derived_Type,
+ Ifaces_List => Ifaces,
+ Exclude_Parents => True);
+
+ if Present (Ifaces) then
+ Iface_Elmt := First_Elmt (Ifaces);
+ while Present (Iface_Elmt) loop
+ Iface := Node (Iface_Elmt);
+
+ if Has_Inheritable_Invariants (Iface) then
+ Set_Has_Inherited_Invariants (Derived_Type);
+ exit;
+ end if;
+
+ Next_Elmt (Iface_Elmt);
+ end loop;
+ end if;
+ end;
+ end if;
+ end if;
+
+ -- We similarly inherit predicates. Note that for scalar derived types
+ -- the predicate is inherited from the first subtype, and not from its
+ -- (anonymous) base type.
+
+ if Has_Predicates (Parent_Type)
+ or else Has_Predicates (First_Subtype (Parent_Type))
+ then
Set_Has_Predicates (Derived_Type);
end if;
@@ -8967,18 +9301,6 @@ package body Sem_Ch3 is
Inherit_Rep_Item_Chain (Derived_Type, Parent_Type);
- -- Propagate the attributes related to pragma Default_Initial_Condition
- -- from the parent type to the private extension. A derived type always
- -- inherits the default initial condition flag from the parent type. If
- -- the derived type carries its own Default_Initial_Condition pragma,
- -- the flag is later reset in Analyze_Pragma. Note that both flags are
- -- mutually exclusive.
-
- Propagate_Default_Init_Cond_Attributes
- (From_Typ => Parent_Type,
- To_Typ => Derived_Type,
- Parent_To_Derivation => True);
-
-- If the parent type has delayed rep aspects, then mark the derived
-- type as possibly inheriting a delayed rep aspect.
@@ -8986,8 +9308,9 @@ package body Sem_Ch3 is
Set_May_Inherit_Delayed_Rep_Aspects (Derived_Type);
end if;
- -- Propagate the attributes related to pragma Ghost from the parent type
- -- to the derived type or type extension (SPARK RM 6.9(9)).
+ -- A derived type becomes Ghost when its parent type is also Ghost
+ -- (SPARK RM 6.9(9)). Note that the Ghost-related attributes are not
+ -- directly inherited because the Ghost policy in effect may differ.
if Is_Ghost_Entity (Parent_Type) then
Set_Is_Ghost_Entity (Derived_Type);
@@ -9002,9 +9325,10 @@ package body Sem_Ch3 is
when Array_Kind =>
Build_Derived_Array_Type (N, Parent_Type, Derived_Type);
- when E_Record_Type
+ when Class_Wide_Kind
| E_Record_Subtype
- | Class_Wide_Kind =>
+ | E_Record_Type
+ =>
Build_Derived_Record_Type
(N, Parent_Type, Derived_Type, Derive_Subps);
return;
@@ -9074,6 +9398,7 @@ package body Sem_Ch3 is
Set_Mechanism (D_Minal, Default_Mechanism);
Set_Etype (D_Minal, Etype (Discrim));
Set_Scope (D_Minal, Current_Scope);
+ Set_Parent (D_Minal, Parent (Discrim));
Set_Discriminal (Discrim, D_Minal);
Set_Discriminal_Link (D_Minal, Discrim);
@@ -9380,12 +9705,19 @@ package body Sem_Ch3 is
-- If any of the discriminant constraints is given by a
-- discriminant and we are in a derived type declaration we
-- have a discriminant renaming. Establish link between new
- -- and old discriminant.
+ -- and old discriminant. The new discriminant has an implicit
+ -- dereference if the old one does.
if Denotes_Discriminant (Discr_Expr (J)) then
if Derived_Def then
- Set_Corresponding_Discriminant
- (Entity (Discr_Expr (J)), Discr);
+ declare
+ New_Discr : constant Entity_Id := Entity (Discr_Expr (J));
+
+ begin
+ Set_Corresponding_Discriminant (New_Discr, Discr);
+ Set_Has_Implicit_Dereference (New_Discr,
+ Has_Implicit_Dereference (Discr));
+ end;
end if;
-- Force the evaluation of non-discriminant expressions.
@@ -9401,9 +9733,8 @@ package body Sem_Ch3 is
null;
elsif Nkind (Parent (Parent (Def))) = N_Component_Declaration
- and then
- Has_Per_Object_Constraint
- (Defining_Identifier (Parent (Parent (Def))))
+ and then Has_Per_Object_Constraint
+ (Defining_Identifier (Parent (Parent (Def))))
then
null;
@@ -9423,7 +9754,7 @@ package body Sem_Ch3 is
if Ekind (Etype (Discr)) = E_Anonymous_Access_Type
and then not Is_Class_Wide_Type
- (Designated_Type (Etype (Discr)))
+ (Designated_Type (Etype (Discr)))
and then Etype (Discr_Expr (J)) /= Any_Type
and then Is_Class_Wide_Type
(Designated_Type (Etype (Discr_Expr (J))))
@@ -9437,7 +9768,7 @@ package body Sem_Ch3 is
then
Error_Msg_NE
("constraint for discriminant& must be access to variable",
- Def, Discr);
+ Def, Discr);
end if;
end if;
@@ -9766,6 +10097,7 @@ package body Sem_Ch3 is
Analyze (Indic);
Set_Underlying_Full_View (Typ, Full_View (Subt));
+ Set_Is_Underlying_Full_View (Full_View (Subt));
end Build_Underlying_Full_View;
-------------------------------
@@ -11558,12 +11890,13 @@ package body Sem_Ch3 is
Save_Homonym := Homonym (Priv);
case Ekind (Full_Base) is
- when E_Record_Type |
- E_Record_Subtype |
- Class_Wide_Kind |
- Private_Kind |
- Task_Kind |
- Protected_Kind =>
+ when Class_Wide_Kind
+ | Private_Kind
+ | Protected_Kind
+ | Task_Kind
+ | E_Record_Subtype
+ | E_Record_Type
+ =>
Copy_Node (Priv, Full);
Set_Has_Discriminants
@@ -11640,12 +11973,22 @@ package body Sem_Ch3 is
-- already frozen. We skip this processing if the type is an anonymous
-- subtype of a record component, or is the corresponding record of a
-- protected type, since these are processed when the enclosing type
- -- is frozen.
+ -- is frozen. If the parent type is declared in a nested package then
+ -- the freezing of the private and full views also happens later.
if not Is_Type (Scope (Full)) then
- Set_Has_Delayed_Freeze (Full,
- Has_Delayed_Freeze (Full_Base)
- and then (not Is_Frozen (Full_Base)));
+ if Is_Itype (Priv)
+ and then In_Same_Source_Unit (Full, Full_Base)
+ and then Scope (Full_Base) /= Scope (Full)
+ then
+ Set_Has_Delayed_Freeze (Full);
+ Set_Has_Delayed_Freeze (Priv);
+
+ else
+ Set_Has_Delayed_Freeze (Full,
+ Has_Delayed_Freeze (Full_Base)
+ and then not Is_Frozen (Full_Base));
+ end if;
end if;
Set_Freeze_Node (Full, Empty);
@@ -11771,9 +12114,11 @@ package body Sem_Ch3 is
Append : Boolean;
Item : Node_Id;
Next_Item : Node_Id;
+ Priv_Item : Node_Id;
begin
Item := First_Rep_Item (Full);
+ Priv_Item := First_Rep_Item (Priv);
-- If no existing rep items on full type, we can just link directly
-- to the list of items on the private type, if any exist.. Same if
@@ -11782,16 +12127,26 @@ package body Sem_Ch3 is
if (No (Item)
or else Nkind (Item) /= N_Aspect_Specification
or else Entity (Item) = Full_Base)
- and then Present (First_Rep_Item (Priv))
+ and then Present (First_Rep_Item (Priv))
then
- Set_First_Rep_Item (Full, First_Rep_Item (Priv));
+ Set_First_Rep_Item (Full, Priv_Item);
-- Otherwise, search to the end of items currently linked to the full
-- subtype and append the private items to the end. However, if Priv
-- and Full already have the same list of rep items, then the append
-- is not done, as that would create a circularity.
+ --
+ -- The partial view may have a predicate and the rep item lists of
+ -- both views agree when inherited from the same ancestor. In that
+ -- case, simply propagate the list from one view to the other.
+ -- A more complex analysis needed here ???
+
+ elsif Present (Priv_Item)
+ and then Item = Next_Rep_Item (Priv_Item)
+ then
+ Set_First_Rep_Item (Full, Priv_Item);
- elsif Item /= First_Rep_Item (Priv) then
+ elsif Item /= Priv_Item then
Append := True;
loop
Next_Item := Next_Rep_Item (Item);
@@ -11825,8 +12180,18 @@ package body Sem_Ch3 is
-- in particular when the full type is a scalar type for which an
-- anonymous base type is constructed.
+ -- The predicate functions are generated either at the freeze point
+ -- of the type or at the end of the visible part, and we must avoid
+ -- generating them twice.
+
if Has_Predicates (Priv) then
Set_Has_Predicates (Full);
+
+ if Present (Predicate_Function (Priv))
+ and then No (Predicate_Function (Full))
+ then
+ Set_Predicate_Function (Full, Predicate_Function (Priv));
+ end if;
end if;
if Has_Delayed_Aspects (Priv) then
@@ -12995,15 +13360,13 @@ package body Sem_Ch3 is
Related_Nod : Node_Id;
For_Access : Boolean := False)
is
- E : constant Entity_Id := Entity (Subtype_Mark (S));
- T : Entity_Id;
- C : Node_Id;
- Elist : Elist_Id := New_Elmt_List;
+ E : Entity_Id := Entity (Subtype_Mark (S));
+ T : Entity_Id;
procedure Fixup_Bad_Constraint;
- -- This is called after finding a bad constraint, and after having
- -- posted an appropriate error message. The mission is to leave the
- -- entity T in as reasonable state as possible.
+ -- Called after finding a bad constraint, and after having posted an
+ -- appropriate error message. The goal is to leave type Def_Id in as
+ -- reasonable state as possible.
--------------------------
-- Fixup_Bad_Constraint --
@@ -13027,6 +13390,11 @@ package body Sem_Ch3 is
Set_Error_Posted (Def_Id);
end Fixup_Bad_Constraint;
+ -- Local variables
+
+ C : Node_Id;
+ Constr : Elist_Id := New_Elmt_List;
+
-- Start of processing for Constrain_Discriminated_Type
begin
@@ -13044,17 +13412,36 @@ package body Sem_Ch3 is
T := Designated_Type (T);
end if;
- -- Ada 2005 (AI-412): Constrained incomplete subtypes are illegal.
- -- Avoid generating an error for access-to-incomplete subtypes.
+ -- In an instance it may be necessary to retrieve the full view of a
+ -- type with unknown discriminants, or a full view with defaulted
+ -- discriminants. In other contexts the constraint is illegal.
+
+ if In_Instance
+ and then Is_Private_Type (T)
+ and then Present (Full_View (T))
+ and then
+ (Has_Unknown_Discriminants (T)
+ or else
+ (not Has_Discriminants (T)
+ and then Has_Discriminants (Full_View (T))
+ and then Present (Discriminant_Default_Value
+ (First_Discriminant (Full_View (T))))))
+ then
+ T := Full_View (T);
+ E := Full_View (E);
+ end if;
+
+ -- Ada 2005 (AI-412): Constrained incomplete subtypes are illegal. Avoid
+ -- generating an error for access-to-incomplete subtypes.
if Ada_Version >= Ada_2005
and then Ekind (T) = E_Incomplete_Type
and then Nkind (Parent (S)) = N_Subtype_Declaration
and then not Is_Itype (Def_Id)
then
- -- A little sanity check, emit an error message if the type
- -- has discriminants to begin with. Type T may be a regular
- -- incomplete type or imported via a limited with clause.
+ -- A little sanity check: emit an error message if the type has
+ -- discriminants to begin with. Type T may be a regular incomplete
+ -- type or imported via a limited with clause.
if Has_Discriminants (T)
or else (From_Limited_With (T)
@@ -13095,23 +13482,23 @@ package body Sem_Ch3 is
return;
end if;
- -- T may be an unconstrained subtype (e.g. a generic actual).
- -- Constraint applies to the base type.
+ -- T may be an unconstrained subtype (e.g. a generic actual). Constraint
+ -- applies to the base type.
T := Base_Type (T);
- Elist := Build_Discriminant_Constraints (T, S);
+ Constr := Build_Discriminant_Constraints (T, S);
-- If the list returned was empty we had an error in building the
-- discriminant constraint. We have also already signalled an error
-- in the incomplete type case
- if Is_Empty_Elmt_List (Elist) then
+ if Is_Empty_Elmt_List (Constr) then
Fixup_Bad_Constraint;
return;
end if;
- Build_Discriminated_Subtype (T, Def_Id, Elist, Related_Nod, For_Access);
+ Build_Discriminated_Subtype (T, Def_Id, Constr, Related_Nod, For_Access);
end Constrain_Discriminated_Type;
---------------------------
@@ -13643,8 +14030,7 @@ package body Sem_Ch3 is
Set_Component_Size (T1, Component_Size (T2));
Set_Has_Controlled_Component (T1, Has_Controlled_Component (T2));
Set_Has_Non_Standard_Rep (T1, Has_Non_Standard_Rep (T2));
- Set_Has_Protected (T1, Has_Protected (T2));
- Set_Has_Task (T1, Has_Task (T2));
+ Propagate_Concurrent_Flags (T1, T2);
Set_Is_Packed (T1, Is_Packed (T2));
Set_Has_Aliased_Components (T1, Has_Aliased_Components (T2));
Set_Has_Atomic_Components (T1, Has_Atomic_Components (T2));
@@ -13867,8 +14253,8 @@ package body Sem_Ch3 is
-- Inherit the discriminants of the parent type
Add_Discriminants : declare
- Num_Disc : Int;
- Num_Gird : Int;
+ Num_Disc : Nat;
+ Num_Gird : Nat;
begin
Num_Disc := 0;
@@ -13963,7 +14349,8 @@ package body Sem_Ch3 is
Governed_By => Assoc_List,
Into => Comp_List,
Report_Errors => Errors);
- pragma Assert (not Errors);
+ pragma Assert (not Errors
+ or else Serious_Errors_Detected > 0);
Create_All_Components;
@@ -14351,7 +14738,7 @@ package body Sem_Ch3 is
-----------------------
procedure Derive_Subprogram
- (New_Subp : in out Entity_Id;
+ (New_Subp : out Entity_Id;
Parent_Subp : Entity_Id;
Derived_Type : Entity_Id;
Parent_Type : Entity_Id;
@@ -14518,7 +14905,7 @@ package body Sem_Ch3 is
-- of the derived type are not relevant, and thus we can use
-- the base type for the formals. However, the return type may be
-- used in a context that requires that the proper static bounds
- -- be used (a case statement, for example) and for those cases
+ -- be used (a case statement, for example) and for those cases
-- we must use the derived type (first subtype), not its base.
-- If the derived_type_definition has no constraints, we know that
@@ -14590,9 +14977,10 @@ package body Sem_Ch3 is
or else Is_Internal (Parent_Subp)
or else Is_Private_Overriding
or else Is_Internal_Name (Chars (Parent_Subp))
- or else Nam_In (Chars (Parent_Subp), Name_Initialize,
- Name_Adjust,
- Name_Finalize)
+ or else (Is_Controlled (Parent_Type)
+ and then Nam_In (Chars (Parent_Subp), Name_Adjust,
+ Name_Finalize,
+ Name_Initialize))
then
Set_Derived_Name;
@@ -14649,8 +15037,8 @@ package body Sem_Ch3 is
then
Set_Derived_Name;
- -- Otherwise, the type is inheriting a private operation, so enter
- -- it with a special name so it can't be overridden.
+ -- Otherwise, the type is inheriting a private operation, so enter it
+ -- with a special name so it can't be overridden.
else
Set_Chars (New_Subp, New_External_Name (Chars (Parent_Subp), 'P'));
@@ -14728,12 +15116,6 @@ package body Sem_Ch3 is
Set_Alias (New_Subp, Actual_Subp);
end if;
- -- Inherit the "ghostness" from the parent subprogram
-
- if Is_Ghost_Entity (Alias (New_Subp)) then
- Set_Is_Ghost_Entity (New_Subp);
- end if;
-
-- Derived subprograms of a tagged type must inherit the convention
-- of the parent subprogram (a requirement of AI-117). Derived
-- subprograms of untagged types simply get convention Ada by default.
@@ -14932,7 +15314,7 @@ package body Sem_Ch3 is
-- the list of primitives of Derived_Type exactly in the same order.
procedure Derive_Interface_Subprogram
- (New_Subp : in out Entity_Id;
+ (New_Subp : out Entity_Id;
Subp : Entity_Id;
Actual_Subp : Entity_Id);
-- Derive New_Subp from the ultimate alias of the parent subprogram Subp
@@ -14940,6 +15322,10 @@ package body Sem_Ch3 is
-- Actual_Subp is the actual subprogram corresponding with the generic
-- subprogram Subp.
+ ------------------------
+ -- Check_Derived_Type --
+ ------------------------
+
function Check_Derived_Type return Boolean is
E : Entity_Id;
Elmt : Elmt_Id;
@@ -14950,7 +15336,7 @@ package body Sem_Ch3 is
begin
-- Traverse list of entities in the current scope searching for
- -- an incomplete type whose full-view is derived type
+ -- an incomplete type whose full-view is derived type.
E := First_Entity (Scope (Derived_Type));
while Present (E) and then E /= Derived_Type loop
@@ -15018,7 +15404,7 @@ package body Sem_Ch3 is
---------------------------------
procedure Derive_Interface_Subprogram
- (New_Subp : in out Entity_Id;
+ (New_Subp : out Entity_Id;
Subp : Entity_Id;
Actual_Subp : Entity_Id)
is
@@ -16302,63 +16688,93 @@ package body Sem_Ch3 is
function Find_Type_Name (N : Node_Id) return Entity_Id is
Id : constant Entity_Id := Defining_Identifier (N);
- Prev : Entity_Id;
New_Id : Entity_Id;
+ Prev : Entity_Id;
Prev_Par : Node_Id;
procedure Check_Duplicate_Aspects;
-- Check that aspects specified in a completion have not been specified
- -- already in the partial view. Type_Invariant and others can be
- -- specified on either view but never on both.
+ -- already in the partial view.
procedure Tag_Mismatch;
- -- Diagnose a tagged partial view whose full view is untagged.
- -- We post the message on the full view, with a reference to
- -- the previous partial view. The partial view can be private
- -- or incomplete, and these are handled in a different manner,
- -- so we determine the position of the error message from the
- -- respective slocs of both.
+ -- Diagnose a tagged partial view whose full view is untagged. We post
+ -- the message on the full view, with a reference to the previous
+ -- partial view. The partial view can be private or incomplete, and
+ -- these are handled in a different manner, so we determine the position
+ -- of the error message from the respective slocs of both.
-----------------------------
-- Check_Duplicate_Aspects --
-----------------------------
procedure Check_Duplicate_Aspects is
- Prev_Aspects : constant List_Id := Aspect_Specifications (Prev_Par);
- Full_Aspects : constant List_Id := Aspect_Specifications (N);
- F_Spec, P_Spec : Node_Id;
+ function Get_Partial_View_Aspect (Asp : Node_Id) return Node_Id;
+ -- Return the corresponding aspect of the partial view which matches
+ -- the aspect id of Asp. Return Empty is no such aspect exists.
+
+ -----------------------------
+ -- Get_Partial_View_Aspect --
+ -----------------------------
+
+ function Get_Partial_View_Aspect (Asp : Node_Id) return Node_Id is
+ Asp_Id : constant Aspect_Id := Get_Aspect_Id (Asp);
+ Prev_Asps : constant List_Id := Aspect_Specifications (Prev_Par);
+ Prev_Asp : Node_Id;
+
+ begin
+ if Present (Prev_Asps) then
+ Prev_Asp := First (Prev_Asps);
+ while Present (Prev_Asp) loop
+ if Get_Aspect_Id (Prev_Asp) = Asp_Id then
+ return Prev_Asp;
+ end if;
+
+ Next (Prev_Asp);
+ end loop;
+ end if;
+
+ return Empty;
+ end Get_Partial_View_Aspect;
+
+ -- Local variables
+
+ Full_Asps : constant List_Id := Aspect_Specifications (N);
+ Full_Asp : Node_Id;
+ Part_Asp : Node_Id;
+
+ -- Start of processing for Check_Duplicate_Aspects
begin
- if Present (Full_Aspects) then
- F_Spec := First (Full_Aspects);
- while Present (F_Spec) loop
- if Present (Prev_Aspects) then
- P_Spec := First (Prev_Aspects);
- while Present (P_Spec) loop
- if Chars (Identifier (P_Spec)) =
- Chars (Identifier (F_Spec))
- then
- Error_Msg_N
- ("aspect already specified in private declaration",
- F_Spec);
- Remove (F_Spec);
- return;
- end if;
+ if Present (Full_Asps) then
+ Full_Asp := First (Full_Asps);
+ while Present (Full_Asp) loop
+ Part_Asp := Get_Partial_View_Aspect (Full_Asp);
- Next (P_Spec);
- end loop;
+ -- An aspect and its class-wide counterpart are two distinct
+ -- aspects and may apply to both views of an entity.
+
+ if Present (Part_Asp)
+ and then Class_Present (Part_Asp) = Class_Present (Full_Asp)
+ then
+ Error_Msg_N
+ ("aspect already specified in private declaration",
+ Full_Asp);
+
+ Remove (Full_Asp);
+ return;
end if;
if Has_Discriminants (Prev)
and then not Has_Unknown_Discriminants (Prev)
- and then Chars (Identifier (F_Spec)) =
- Name_Implicit_Dereference
+ and then Get_Aspect_Id (Full_Asp) =
+ Aspect_Implicit_Dereference
then
- Error_Msg_N ("cannot specify aspect " &
- "if partial view has known discriminants", F_Spec);
+ Error_Msg_N
+ ("cannot specify aspect if partial view has known "
+ & "discriminants", Full_Asp);
end if;
- Next (F_Spec);
+ Next (Full_Asp);
end loop;
end if;
end Check_Duplicate_Aspects;
@@ -16481,9 +16897,9 @@ package body Sem_Ch3 is
Set_Ekind (Id, Ekind (Prev)); -- will be reset later
Set_Class_Wide_Type (Id, Class_Wide_Type (Prev));
- -- The type of the classwide type is the current Id. Previously
+ -- Type of the class-wide type is the current Id. Previously
-- this was not done for private declarations because of order-
- -- of elaboration issues in the back-end, but gigi now handles
+ -- of-elaboration issues in the back end, but gigi now handles
-- this properly.
Set_Etype (Class_Wide_Type (Id), Id);
@@ -17783,8 +18199,9 @@ package body Sem_Ch3 is
is
begin
case T_Kind is
- when Enumeration_Kind |
- Integer_Kind =>
+ when Enumeration_Kind
+ | Integer_Kind
+ =>
return Constraint_Kind = N_Range_Constraint;
when Decimal_Fixed_Point_Kind =>
@@ -17799,14 +18216,15 @@ package body Sem_Ch3 is
return Nkind_In (Constraint_Kind, N_Digits_Constraint,
N_Range_Constraint);
- when Access_Kind |
- Array_Kind |
- E_Record_Type |
- E_Record_Subtype |
- Class_Wide_Kind |
- E_Incomplete_Type |
- Private_Kind |
- Concurrent_Kind =>
+ when Access_Kind
+ | Array_Kind
+ | Class_Wide_Kind
+ | Concurrent_Kind
+ | Private_Kind
+ | E_Incomplete_Type
+ | E_Record_Subtype
+ | E_Record_Type
+ =>
return Constraint_Kind = N_Index_Or_Discriminant_Constraint;
when others =>
@@ -17895,11 +18313,38 @@ package body Sem_Ch3 is
then
return True;
- -- In the body of an instantiation, no need to check for the visibility
- -- of a component.
+ -- In the body of an instantiation, check the visibility of a component
+ -- in case it has a homograph that is a primitive operation of a private
+ -- type which was not visible in the generic unit.
+
+ -- Should Is_Prefixed_Call be propagated from template to instance???
elsif In_Instance_Body then
- return True;
+ if not Is_Tagged_Type (Original_Type)
+ or else not Is_Private_Type (Original_Type)
+ then
+ return True;
+
+ else
+ declare
+ Subp_Elmt : Elmt_Id;
+
+ begin
+ Subp_Elmt := First_Elmt (Primitive_Operations (Original_Type));
+ while Present (Subp_Elmt) loop
+
+ -- The component is hidden by a primitive operation
+
+ if Chars (Node (Subp_Elmt)) = Chars (C) then
+ return False;
+ end if;
+
+ Next_Elmt (Subp_Elmt);
+ end loop;
+
+ return True;
+ end;
+ end if;
-- If the component has been declared in an ancestor which is currently
-- a private type, then it is not visible. The same applies if the
@@ -18042,7 +18487,8 @@ package body Sem_Ch3 is
Set_Freeze_Node (CW_Type, Empty);
-- Customize the class-wide type: It has no prim. op., it cannot be
- -- abstract and its Etype points back to the specific root type.
+ -- abstract, its Etype points back to the specific root type, and it
+ -- cannot have any invariants.
Set_Ekind (CW_Type, E_Class_Wide_Type);
Set_Is_Tagged_Type (CW_Type, True);
@@ -18051,6 +18497,9 @@ package body Sem_Ch3 is
Set_Is_Constrained (CW_Type, False);
Set_Is_First_Subtype (CW_Type, Is_First_Subtype (T));
Set_Default_SSO (CW_Type);
+ Set_Has_Inheritable_Invariants (CW_Type, False);
+ Set_Has_Inherited_Invariants (CW_Type, False);
+ Set_Has_Own_Invariants (CW_Type, False);
if Ekind (T) = E_Class_Wide_Subtype then
Set_Etype (CW_Type, Etype (Base_Type (T)));
@@ -18073,12 +18522,6 @@ package body Sem_Ch3 is
-- The class-wide type of a class-wide type is itself (RM 3.9(14))
Set_Class_Wide_Type (CW_Type, CW_Type);
-
- -- Inherit the "ghostness" from the root tagged type
-
- if Ghost_Mode > None or else Is_Ghost_Entity (T) then
- Set_Is_Ghost_Entity (CW_Type);
- end if;
end Make_Class_Wide_Type;
----------------
@@ -18586,11 +19029,14 @@ package body Sem_Ch3 is
is
begin
-- An object of a limited interface type can be initialized with any
- -- expression of a nonlimited descendant type.
+ -- expression of a nonlimited descendant type. However this does not
+ -- apply if this is a view conversion of some other expression. This
+ -- is checked below.
if Is_Class_Wide_Type (Typ)
and then Is_Limited_Interface (Typ)
and then not Is_Limited_Type (Etype (Exp))
+ and then Nkind (Exp) /= N_Type_Conversion
then
return True;
end if;
@@ -18614,7 +19060,11 @@ package body Sem_Ch3 is
end if;
case Nkind (Original_Node (Exp)) is
- when N_Aggregate | N_Extension_Aggregate | N_Function_Call | N_Op =>
+ when N_Aggregate
+ | N_Extension_Aggregate
+ | N_Function_Call
+ | N_Op
+ =>
return True;
when N_Identifier =>
@@ -18634,16 +19084,18 @@ package body Sem_Ch3 is
-- A return statement for a build-in-place function returning a
-- synchronized type also introduces an unchecked conversion.
- when N_Type_Conversion |
- N_Unchecked_Type_Conversion =>
+ when N_Type_Conversion
+ | N_Unchecked_Type_Conversion
+ =>
return not Comes_From_Source (Exp)
and then
OK_For_Limited_Init_In_05
(Typ, Expression (Original_Node (Exp)));
- when N_Indexed_Component |
- N_Selected_Component |
- N_Explicit_Dereference =>
+ when N_Explicit_Dereference
+ | N_Indexed_Component
+ | N_Selected_Component
+ =>
return Nkind (Exp) = N_Function_Call;
-- A use of 'Input is a function call, hence allowed. Normally the
@@ -19214,6 +19666,10 @@ package body Sem_Ch3 is
-- Process_Full_View --
-----------------------
+ -- WARNING: This routine manages Ghost regions. Return statements must be
+ -- replaced by gotos which jump to the end of the routine and restore the
+ -- Ghost mode.
+
procedure Process_Full_View (N : Node_Id; Full_T, Priv_T : Entity_Id) is
procedure Collect_Implemented_Interfaces
(Typ : Entity_Id;
@@ -19308,11 +19764,14 @@ package body Sem_Ch3 is
Full_Indic : Node_Id;
Full_Parent : Entity_Id;
+ Mode : Ghost_Mode_Type;
Priv_Parent : Entity_Id;
-- Start of processing for Process_Full_View
begin
+ Mark_And_Set_Ghost_Completion (N, Priv_T, Mode);
+
-- First some sanity checks that must be done after semantic
-- decoration of the full view and thus cannot be placed with other
-- similar checks in Find_Type_Name
@@ -19425,7 +19884,7 @@ package body Sem_Ch3 is
-- error situation [7.3(8)].
if Priv_Parent = Any_Type or else Full_Parent = Any_Type then
- return;
+ goto Leave;
-- Ada 2005 (AI-251): Interfaces in the full type can be given in
-- any order. Therefore we don't have to check that its parent must
@@ -19445,8 +19904,8 @@ package body Sem_Ch3 is
and then not Is_Ancestor (Base_Type (Priv_Parent), Full_Parent)
then
Error_Msg_N
- ("parent of full type must descend from parent"
- & " of private extension", Full_Indic);
+ ("parent of full type must descend from parent of private "
+ & "extension", Full_Indic);
-- First check a formal restriction, and then proceed with checking
-- Ada rules. Since the formal restriction is not a serious error, we
@@ -19500,9 +19959,9 @@ package body Sem_Ch3 is
while Present (Priv_Discr) and then Present (Full_Discr) loop
if Original_Record_Component (Priv_Discr) =
Original_Record_Component (Full_Discr)
- or else
- Corresponding_Discriminant (Priv_Discr) =
- Corresponding_Discriminant (Full_Discr)
+ or else
+ Corresponding_Discriminant (Priv_Discr) =
+ Corresponding_Discriminant (Full_Discr)
then
null;
else
@@ -19515,8 +19974,8 @@ package body Sem_Ch3 is
if Present (Priv_Discr) or else Present (Full_Discr) then
Error_Msg_N
- ("full view must inherit discriminants of the parent"
- & " type used in the private extension", Full_Indic);
+ ("full view must inherit discriminants of the parent "
+ & "type used in the private extension", Full_Indic);
elsif Priv_Constr and then not Full_Constr then
Error_Msg_N
@@ -19534,13 +19993,13 @@ package body Sem_Ch3 is
-- known or unknown discriminants, then the full type
-- declaration shall define a definite subtype.
- elsif not Has_Unknown_Discriminants (Priv_T)
+ elsif not Has_Unknown_Discriminants (Priv_T)
and then not Has_Discriminants (Priv_T)
and then not Is_Constrained (Full_T)
then
Error_Msg_N
- ("full view must define a constrained type if partial view"
- & " has no discriminants", Full_T);
+ ("full view must define a constrained type if partial view "
+ & "has no discriminants", Full_T);
end if;
-- ??????? Do we implement the following properly ?????
@@ -19758,19 +20217,26 @@ package body Sem_Ch3 is
(Subp_Id => Prim,
Obj_Typ => Conc_Typ,
Formals =>
- Parameter_Specifications (
- Parent (Prim))));
+ Parameter_Specifications
+ (Parent (Prim))));
Insert_After (Curr_Nod, Wrap_Spec);
Curr_Nod := Wrap_Spec;
Analyze (Wrap_Spec);
+
+ -- Remove the wrapper from visibility to avoid
+ -- spurious conflict with the wrapped entity.
+
+ Set_Is_Immediately_Visible
+ (Defining_Entity (Specification (Wrap_Spec)),
+ False);
end if;
Next_Elmt (Prim_Elmt);
end loop;
- return;
+ goto Leave;
end;
-- For non-concurrent types, transfer explicit primitives, but
@@ -19828,7 +20294,7 @@ package body Sem_Ch3 is
end if;
elsif Is_Dispatching_Operation (Prim)
- and then Disp_Typ /= Full_T
+ and then Disp_Typ /= Full_T
then
-- Verify that it is not otherwise controlled by a
@@ -19851,9 +20317,7 @@ package body Sem_Ch3 is
Set_Class_Wide_Type
(Base_Type (Full_T), Class_Wide_Type (Priv_T));
- Set_Has_Task (Class_Wide_Type (Priv_T), Has_Task (Full_T));
- Set_Has_Protected
- (Class_Wide_Type (Priv_T), Has_Protected (Full_T));
+ Propagate_Concurrent_Flags (Class_Wide_Type (Priv_T), Full_T);
end if;
end;
end if;
@@ -19909,103 +20373,39 @@ package body Sem_Ch3 is
Set_Has_Specified_Stream_Output (Full_T);
end if;
- -- Propagate the attributes related to pragma Default_Initial_Condition
- -- from the private to the full view. Note that both flags are mutually
- -- exclusive.
+ -- Propagate Default_Initial_Condition-related attributes from the
+ -- partial view to the full view and its base type.
- if Has_Default_Init_Cond (Priv_T)
- or else Has_Inherited_Default_Init_Cond (Priv_T)
- then
- Propagate_Default_Init_Cond_Attributes
- (From_Typ => Priv_T,
- To_Typ => Full_T,
- Private_To_Full_View => True);
-
- -- In the case where the full view is derived from another private type,
- -- the attributes related to pragma Default_Initial_Condition must be
- -- propagated from the full to the private view to maintain consistency
- -- of views.
-
- -- package Pack is
- -- type Parent_Typ is private
- -- with Default_Initial_Condition ...;
- -- private
- -- type Parent_Typ is ...;
- -- end Pack;
-
- -- with Pack; use Pack;
- -- package Pack_2 is
- -- type Deriv_Typ is private; -- must inherit
- -- private
- -- type Deriv_Typ is new Parent_Typ; -- must inherit
- -- end Pack_2;
-
- elsif Has_Default_Init_Cond (Full_T)
- or else Has_Inherited_Default_Init_Cond (Full_T)
- then
- Propagate_Default_Init_Cond_Attributes
- (From_Typ => Full_T,
- To_Typ => Priv_T,
- Private_To_Full_View => True);
- end if;
-
- if Is_Ghost_Entity (Priv_T) then
+ Propagate_DIC_Attributes (Full_T, From_Typ => Priv_T);
+ Propagate_DIC_Attributes (Base_Type (Full_T), From_Typ => Priv_T);
- -- The Ghost policy in effect at the point of declaration and at the
- -- point of completion must match (SPARK RM 6.9(14)).
+ -- Propagate invariant-related attributes from the partial view to the
+ -- full view and its base type.
- Check_Ghost_Completion (Priv_T, Full_T);
-
- -- In the case where the private view of a tagged type lacks a parent
- -- type and is subject to pragma Ghost, ensure that the parent type
- -- specified by the full view is also Ghost (SPARK RM 6.9(9)).
-
- if Is_Derived_Type (Full_T) then
- Check_Ghost_Derivation (Full_T);
- end if;
+ Propagate_Invariant_Attributes (Full_T, From_Typ => Priv_T);
+ Propagate_Invariant_Attributes (Base_Type (Full_T), From_Typ => Priv_T);
- -- Propagate the attributes related to pragma Ghost from the private
- -- to the full view.
+ -- AI12-0041: Detect an attempt to inherit a class-wide type invariant
+ -- in the full view without advertising the inheritance in the partial
+ -- view. This can only occur when the partial view has no parent type
+ -- and the full view has an interface as a parent. Any other scenarios
+ -- are illegal because implemented interfaces must match between the
+ -- two views.
- Mark_Full_View_As_Ghost (Priv_T, Full_T);
- end if;
-
- -- Propagate invariants to full type
-
- if Has_Invariants (Priv_T) then
- Set_Has_Invariants (Full_T);
- Set_Invariant_Procedure (Full_T, Invariant_Procedure (Priv_T));
- end if;
-
- if Has_Inheritable_Invariants (Priv_T) then
- Set_Has_Inheritable_Invariants (Full_T);
- end if;
-
- -- Check hidden inheritance of class-wide type invariants
-
- if Ada_Version >= Ada_2012
- and then not Has_Inheritable_Invariants (Full_T)
- and then In_Private_Part (Current_Scope)
- and then Has_Interfaces (Full_T)
- then
+ if Is_Tagged_Type (Priv_T) and then Is_Tagged_Type (Full_T) then
declare
- Ifaces : Elist_Id;
- AI : Elmt_Id;
+ Full_Par : constant Entity_Id := Etype (Full_T);
+ Priv_Par : constant Entity_Id := Etype (Priv_T);
begin
- Collect_Interfaces (Full_T, Ifaces, Exclude_Parents => True);
-
- AI := First_Elmt (Ifaces);
- while Present (AI) loop
- if Has_Inheritable_Invariants (Node (AI)) then
- Error_Msg_N
- ("hidden inheritance of class-wide type invariants " &
- "not allowed", N);
- exit;
- end if;
-
- Next_Elmt (AI);
- end loop;
+ if not Is_Interface (Priv_Par)
+ and then Is_Interface (Full_Par)
+ and then Has_Inheritable_Invariants (Full_Par)
+ then
+ Error_Msg_N
+ ("hidden inheritance of class-wide type invariants not "
+ & "allowed", N);
+ end if;
end;
end if;
@@ -20015,12 +20415,15 @@ package body Sem_Ch3 is
-- built. Still it is a cheap check and seems safer to make it.
if Has_Predicates (Priv_T) then
+ Set_Has_Predicates (Full_T);
+
if Present (Predicate_Function (Priv_T)) then
Set_Predicate_Function (Full_T, Predicate_Function (Priv_T));
end if;
-
- Set_Has_Predicates (Full_T);
end if;
+
+ <<Leave>>
+ Restore_Ghost_Mode (Mode);
end Process_Full_View;
-----------------------------------
@@ -20480,14 +20883,14 @@ package body Sem_Ch3 is
May_Have_Null_Exclusion : Boolean;
- procedure Check_Incomplete (T : Entity_Id);
+ procedure Check_Incomplete (T : Node_Id);
-- Called to verify that an incomplete type is not used prematurely
----------------------
-- Check_Incomplete --
----------------------
- procedure Check_Incomplete (T : Entity_Id) is
+ procedure Check_Incomplete (T : Node_Id) is
begin
-- Ada 2005 (AI-412): Incomplete subtypes are legal
@@ -20737,10 +21140,11 @@ package body Sem_Ch3 is
Constrain_Integer (Def_Id, S);
Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id);
- when E_Record_Type |
- E_Record_Subtype |
- Class_Wide_Kind |
- E_Incomplete_Type =>
+ when Class_Wide_Kind
+ | E_Incomplete_Type
+ | E_Record_Subtype
+ | E_Record_Type
+ =>
Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
if Ekind (Def_Id) = E_Incomplete_Type then
@@ -20749,7 +21153,13 @@ package body Sem_Ch3 is
when Private_Kind =>
Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
- Set_Private_Dependents (Def_Id, New_Elmt_List);
+
+ -- The base type may be private but Def_Id may be a full view
+ -- in an instance.
+
+ if Is_Private_Type (Def_Id) then
+ Set_Private_Dependents (Def_Id, New_Elmt_List);
+ end if;
-- In case of an invalid constraint prevent further processing
-- since the type constructed is missing expected fields.
@@ -20810,124 +21220,6 @@ package body Sem_Ch3 is
end if;
end Process_Subtype;
- --------------------------------------------
- -- Propagate_Default_Init_Cond_Attributes --
- --------------------------------------------
-
- procedure Propagate_Default_Init_Cond_Attributes
- (From_Typ : Entity_Id;
- To_Typ : Entity_Id;
- Parent_To_Derivation : Boolean := False;
- Private_To_Full_View : Boolean := False)
- is
- procedure Remove_Default_Init_Cond_Procedure (Typ : Entity_Id);
- -- Remove the default initial procedure (if any) from the rep chain of
- -- type Typ.
-
- ----------------------------------------
- -- Remove_Default_Init_Cond_Procedure --
- ----------------------------------------
-
- procedure Remove_Default_Init_Cond_Procedure (Typ : Entity_Id) is
- Found : Boolean := False;
- Prev : Entity_Id;
- Subp : Entity_Id;
-
- begin
- Prev := Typ;
- Subp := Subprograms_For_Type (Typ);
- while Present (Subp) loop
- if Is_Default_Init_Cond_Procedure (Subp) then
- Found := True;
- exit;
- end if;
-
- Prev := Subp;
- Subp := Subprograms_For_Type (Subp);
- end loop;
-
- if Found then
- Set_Subprograms_For_Type (Prev, Subprograms_For_Type (Subp));
- Set_Subprograms_For_Type (Subp, Empty);
- end if;
- end Remove_Default_Init_Cond_Procedure;
-
- -- Local variables
-
- Inherit_Procedure : Boolean := False;
-
- -- Start of processing for Propagate_Default_Init_Cond_Attributes
-
- begin
- if Has_Default_Init_Cond (From_Typ) then
-
- -- A derived type inherits the attributes from its parent type
-
- if Parent_To_Derivation then
- Set_Has_Inherited_Default_Init_Cond (To_Typ);
-
- -- A full view shares the attributes with its private view
-
- else
- Set_Has_Default_Init_Cond (To_Typ);
- end if;
-
- Inherit_Procedure := True;
-
- -- Due to the order of expansion, a derived private type is processed
- -- by two routines which both attempt to set the attributes related
- -- to pragma Default_Initial_Condition - Build_Derived_Type and then
- -- Process_Full_View.
-
- -- package Pack is
- -- type Parent_Typ is private
- -- with Default_Initial_Condition ...;
- -- private
- -- type Parent_Typ is ...;
- -- end Pack;
-
- -- with Pack; use Pack;
- -- package Pack_2 is
- -- type Deriv_Typ is private
- -- with Default_Initial_Condition ...;
- -- private
- -- type Deriv_Typ is new Parent_Typ;
- -- end Pack_2;
-
- -- When Build_Derived_Type operates, it sets the attributes on the
- -- full view without taking into account that the private view may
- -- define its own default initial condition procedure. This becomes
- -- apparent in Process_Full_View which must undo some of the work by
- -- Build_Derived_Type and propagate the attributes from the private
- -- to the full view.
-
- if Private_To_Full_View then
- Set_Has_Inherited_Default_Init_Cond (To_Typ, False);
- Remove_Default_Init_Cond_Procedure (To_Typ);
- end if;
-
- -- A type must inherit the default initial condition procedure from a
- -- parent type when the parent itself is inheriting the procedure or
- -- when it is defining one. This circuitry is also used when dealing
- -- with the private / full view of a type.
-
- elsif Has_Inherited_Default_Init_Cond (From_Typ)
- or (Parent_To_Derivation
- and Present (Get_Pragma
- (From_Typ, Pragma_Default_Initial_Condition)))
- then
- Set_Has_Inherited_Default_Init_Cond (To_Typ);
- Inherit_Procedure := True;
- end if;
-
- if Inherit_Procedure
- and then No (Default_Init_Cond_Procedure (To_Typ))
- then
- Set_Default_Init_Cond_Procedure
- (To_Typ, Default_Init_Cond_Procedure (From_Typ));
- end if;
- end Propagate_Default_Init_Cond_Attributes;
-
-----------------------------
-- Record_Type_Declaration --
-----------------------------
@@ -21211,13 +21503,7 @@ package body Sem_Ch3 is
Init_Component_Location (Component);
end if;
- if Has_Task (Etype (Component)) then
- Set_Has_Task (T);
- end if;
-
- if Has_Protected (Etype (Component)) then
- Set_Has_Protected (T);
- end if;
+ Propagate_Concurrent_Flags (T, Etype (Component));
if Ekind (Component) /= E_Component then
null;
diff --git a/gcc/ada/sem_ch3.ads b/gcc/ada/sem_ch3.ads
index 57184ed58a..9f4c6cf05e 100644
--- a/gcc/ada/sem_ch3.ads
+++ b/gcc/ada/sem_ch3.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -120,7 +120,7 @@ package Sem_Ch3 is
-- expressions because the constructor (if any) is on the C++ side.
procedure Derive_Subprogram
- (New_Subp : in out Entity_Id;
+ (New_Subp : out Entity_Id;
Parent_Subp : Entity_Id;
Derived_Type : Entity_Id;
Parent_Type : Entity_Id;
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 94ecc23582..1cdb7a0328 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -231,18 +231,17 @@ package body Sem_Ch4 is
R : Node_Id;
Op_Id : Entity_Id;
T1 : Entity_Id);
- -- For equality and comparison operators, the result is always boolean,
- -- and the legality of the operation is determined from the visibility
- -- of the operand types. If one of the operands has a universal interpre-
- -- tation, the legality check uses some compatible non-universal
- -- interpretation of the other operand. N can be an operator node, or
- -- a function call whose name is an operator designator. Any_Access, which
- -- is the initial type of the literal NULL, is a universal type for the
- -- purpose of this routine.
+ -- For equality and comparison operators, the result is always boolean, and
+ -- the legality of the operation is determined from the visibility of the
+ -- operand types. If one of the operands has a universal interpretation,
+ -- the legality check uses some compatible non-universal interpretation of
+ -- the other operand. N can be an operator node, or a function call whose
+ -- name is an operator designator. Any_Access, which is the initial type of
+ -- the literal NULL, is a universal type for the purpose of this routine.
function Find_Primitive_Operation (N : Node_Id) return Boolean;
- -- Find candidate interpretations for the name Obj.Proc when it appears
- -- in a subprogram renaming declaration.
+ -- Find candidate interpretations for the name Obj.Proc when it appears in
+ -- a subprogram renaming declaration.
procedure Find_Unary_Types
(R : Node_Id;
@@ -324,18 +323,6 @@ package body Sem_Ch4 is
-- subprogram, and the call F (X) interpreted as F.all (X). In this case
-- the call may be overloaded with both interpretations.
- function Try_Object_Operation
- (N : Node_Id;
- CW_Test_Only : Boolean := False) return Boolean;
- -- Ada 2005 (AI-252): Support the object.operation notation. If node N
- -- is a call in this notation, it is transformed into a normal subprogram
- -- call where the prefix is a parameter, and True is returned. If node
- -- N is not of this form, it is unchanged, and False is returned. If
- -- CW_Test_Only is true then N is an N_Selected_Component node which
- -- is part of a call to an entry or procedure of a tagged concurrent
- -- type and this routine is invoked to search for class-wide subprograms
- -- conflicting with the target entity.
-
procedure wpo (T : Entity_Id);
pragma Warnings (Off, wpo);
-- Used for debugging: obtain list of primitive operations even if
@@ -583,6 +570,48 @@ package body Sem_Ch4 is
-- so that the bounds of the subtype indication are attached to
-- the tree in case the allocator is inside a generic unit.
+ -- Finally, if there is no subtype indication and the type is
+ -- a tagged unconstrained type with discriminants, the designated
+ -- object is constrained by their default values, and it is
+ -- simplest to introduce an explicit constraint now. In some cases
+ -- this is done during expansion, but freeze actions are certain
+ -- to be emitted in the proper order if constraint is explicit.
+
+ if Is_Entity_Name (E) and then Expander_Active then
+ Find_Type (E);
+ Type_Id := Entity (E);
+
+ if Is_Tagged_Type (Type_Id)
+ and then Has_Discriminants (Type_Id)
+ and then not Is_Constrained (Type_Id)
+ and then
+ Present
+ (Discriminant_Default_Value
+ (First_Discriminant (Type_Id)))
+ then
+ declare
+ Constr : constant List_Id := New_List;
+ Loc : constant Source_Ptr := Sloc (E);
+ Discr : Entity_Id := First_Discriminant (Type_Id);
+
+ begin
+ if Present (Discriminant_Default_Value (Discr)) then
+ while Present (Discr) loop
+ Append (Discriminant_Default_Value (Discr), Constr);
+ Next_Discriminant (Discr);
+ end loop;
+
+ Rewrite (E,
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark => New_Occurrence_Of (Type_Id, Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints => Constr)));
+ end if;
+ end;
+ end if;
+ end if;
+
if Nkind (E) = N_Subtype_Indication then
-- A constraint is only allowed for a composite type in Ada
@@ -599,7 +628,7 @@ package body Sem_Ch4 is
Error_Msg_N ("constraint not allowed here", E);
if Nkind (Constraint (E)) =
- N_Index_Or_Discriminant_Constraint
+ N_Index_Or_Discriminant_Constraint
then
Error_Msg_N -- CODEFIX
("\if qualified expression was meant, " &
@@ -687,6 +716,23 @@ package body Sem_Ch4 is
then
null;
+ -- An unusual case arises when the parent of a derived type is
+ -- a limited record extension with unknown discriminants, and
+ -- its full view has no discriminants.
+ --
+ -- A more general fix might be to create the proper underlying
+ -- type for such a derived type, but it is a record type with
+ -- no private attributes, so this required extending the
+ -- meaning of this attribute. ???
+
+ elsif Ekind (Etype (Type_Id)) = E_Record_Type_With_Private
+ and then Present (Underlying_Type (Etype (Type_Id)))
+ and then
+ not Has_Discriminants (Underlying_Type (Etype (Type_Id)))
+ and then not Comes_From_Source (Parent (N))
+ then
+ null;
+
elsif Is_Class_Wide_Type (Type_Id) then
Error_Msg_N
("initialization required in class-wide allocation", N);
@@ -770,6 +816,14 @@ package body Sem_Ch4 is
Check_Restriction (No_Local_Protected_Objects, N);
end if;
+ -- Likewise for No_Local_Timing_Events
+
+ if Has_Timing_Event (Designated_Type (Acc_Type))
+ and then not Is_Library_Level_Entity (Acc_Type)
+ then
+ Check_Restriction (No_Local_Timing_Events, N);
+ end if;
+
-- If the No_Streams restriction is set, check that the type of the
-- object is not, and does not contain, any subtype derived from
-- Ada.Streams.Root_Stream_Type. Note that we guard the call to
@@ -876,7 +930,8 @@ package body Sem_Ch4 is
-- the type-checking is similar to that of other calls.
procedure Analyze_Call (N : Node_Id) is
- Actuals : constant List_Id := Parameter_Associations (N);
+ Actuals : constant List_Id := Parameter_Associations (N);
+ Loc : constant Source_Ptr := Sloc (N);
Nam : Node_Id;
X : Interp_Index;
It : Interp;
@@ -1273,24 +1328,41 @@ package body Sem_Ch4 is
-- If the interpretation succeeds, mark the proper type of the
-- prefix (any valid candidate will do). If not, remove the
- -- candidate interpretation. This only needs to be done for
- -- overloaded protected operations, for other entities disambi-
- -- guation is done directly in Resolve.
+ -- candidate interpretation. If this is a parameterless call
+ -- on an anonymous access to subprogram, X is a variable with
+ -- an access discriminant D, the entity in the interpretation is
+ -- D, so rewrite X as X.D.all.
if Success then
if Deref
and then Nkind (Parent (N)) /= N_Explicit_Dereference
then
- Set_Entity (Nam, It.Nam);
- Insert_Explicit_Dereference (Nam);
- Set_Etype (Nam, Nam_Ent);
+ if Ekind (It.Nam) = E_Discriminant
+ and then Has_Implicit_Dereference (It.Nam)
+ then
+ Rewrite (Name (N),
+ Make_Explicit_Dereference (Loc,
+ Prefix =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (Entity (Nam), Loc),
+ Selector_Name =>
+ New_Occurrence_Of (It.Nam, Loc))));
+
+ Analyze (N);
+ return;
+
+ else
+ Set_Entity (Nam, It.Nam);
+ Insert_Explicit_Dereference (Nam);
+ Set_Etype (Nam, Nam_Ent);
+ end if;
else
Set_Etype (Nam, It.Typ);
end if;
- elsif Nkind_In (Name (N), N_Selected_Component,
- N_Function_Call)
+ elsif Nkind_In (Name (N), N_Function_Call, N_Selected_Component)
then
Remove_Interp (X);
end if;
@@ -1440,7 +1512,7 @@ package body Sem_Ch4 is
Others_Present : Boolean;
-- Indicates if Others was present
- Wrong_Alt : Node_Id;
+ Wrong_Alt : Node_Id := Empty;
-- For error reporting
-- Start of processing for Analyze_Case_Expression
@@ -2175,12 +2247,12 @@ package body Sem_Ch4 is
begin
Set_Etype (N, Any_Type);
- -- Loop through intepretations of Then_Expr
+ -- Loop through interpretations of Then_Expr
Get_First_Interp (Then_Expr, I, It);
while Present (It.Nam) loop
- -- Add possible intepretation of Then_Expr if no Else_Expr, or
+ -- Add possible interpretation of Then_Expr if no Else_Expr, or
-- Else_Expr is present and has a compatible type.
if No (Else_Expr)
@@ -2335,15 +2407,19 @@ package body Sem_Ch4 is
end if;
if Is_Array_Type (Array_Type) then
- null;
+
+ -- In order to correctly access First_Index component later,
+ -- replace string literal subtype by its parent type.
+
+ if Ekind (Array_Type) = E_String_Literal_Subtype then
+ Array_Type := Etype (Array_Type);
+ end if;
elsif Present (Pent) and then Ekind (Pent) = E_Entry_Family then
Analyze (Exp);
Set_Etype (N, Any_Type);
- if not Has_Compatible_Type
- (Exp, Entry_Index_Type (Pent))
- then
+ if not Has_Compatible_Type (Exp, Entry_Index_Type (Pent)) then
Error_Msg_N ("invalid index type in entry name", N);
elsif Present (Next (Exp)) then
@@ -3037,6 +3113,21 @@ package body Sem_Ch4 is
Subp_Type : constant Entity_Id := Etype (Nam);
Norm_OK : Boolean;
+ function Compatible_Types_In_Predicate
+ (T1 : Entity_Id;
+ T2 : Entity_Id) return Boolean;
+ -- For an Ada 2012 predicate or invariant, a call may mention an
+ -- incomplete type, while resolution of the corresponding predicate
+ -- function may see the full view, as a consequence of the delayed
+ -- resolution of the corresponding expressions. This may occur in
+ -- the body of a predicate function, or in a call to such. Anomalies
+ -- involving private and full views can also happen. In each case,
+ -- rewrite node or add conversions to remove spurious type errors.
+
+ procedure Indicate_Name_And_Type;
+ -- If candidate interpretation matches, indicate name and type of result
+ -- on call node.
+
function Operator_Hidden_By (Fun : Entity_Id) return Boolean;
-- There may be a user-defined operator that hides the current
-- interpretation. We must check for this independently of the
@@ -3050,9 +3141,59 @@ package body Sem_Ch4 is
-- Finally, The abstract operations on address do not hide the
-- predefined operator (this is the purpose of making them abstract).
- procedure Indicate_Name_And_Type;
- -- If candidate interpretation matches, indicate name and type of
- -- result on call node.
+ -----------------------------------
+ -- Compatible_Types_In_Predicate --
+ -----------------------------------
+
+ function Compatible_Types_In_Predicate
+ (T1 : Entity_Id;
+ T2 : Entity_Id) return Boolean
+ is
+ function Common_Type (T : Entity_Id) return Entity_Id;
+ -- Find non-private full view if any, without going to ancestor type
+ -- (as opposed to Underlying_Type).
+
+ -----------------
+ -- Common_Type --
+ -----------------
+
+ function Common_Type (T : Entity_Id) return Entity_Id is
+ begin
+ if Is_Private_Type (T) and then Present (Full_View (T)) then
+ return Base_Type (Full_View (T));
+ else
+ return Base_Type (T);
+ end if;
+ end Common_Type;
+
+ -- Start of processing for Compatible_Types_In_Predicate
+
+ begin
+ if (Ekind (Current_Scope) = E_Function
+ and then Is_Predicate_Function (Current_Scope))
+ or else
+ (Ekind (Nam) = E_Function
+ and then Is_Predicate_Function (Nam))
+ then
+ if Is_Incomplete_Type (T1)
+ and then Present (Full_View (T1))
+ and then Full_View (T1) = T2
+ then
+ Set_Etype (Formal, Etype (Actual));
+ return True;
+
+ elsif Common_Type (T1) = Common_Type (T2) then
+ Rewrite (Actual, Unchecked_Convert_To (Etype (Formal), Actual));
+ return True;
+
+ else
+ return False;
+ end if;
+
+ else
+ return False;
+ end if;
+ end Compatible_Types_In_Predicate;
----------------------------
-- Indicate_Name_And_Type --
@@ -3124,10 +3265,10 @@ package body Sem_Ch4 is
-- a visible integer type.
return Hides_Op (Fun, Nam)
- or else Is_Descendent_Of_Address (Etype (Form1))
+ or else Is_Descendant_Of_Address (Etype (Form1))
or else
(Present (Form2)
- and then Is_Descendent_Of_Address (Etype (Form2)));
+ and then Is_Descendant_Of_Address (Etype (Form2)));
end Operator_Hidden_By;
-- Start of processing for Analyze_One_Call
@@ -3316,13 +3457,13 @@ package body Sem_Ch4 is
-- The actual can be compatible with the formal, but we must
-- also check that the context is not an address type that is
-- visibly an integer type. In this case the use of literals is
- -- illegal, except in the body of descendents of system, where
+ -- illegal, except in the body of descendants of system, where
-- arithmetic operations on address are of course used.
if Has_Compatible_Type (Actual, Etype (Formal))
and then
(Etype (Actual) /= Universal_Integer
- or else not Is_Descendent_Of_Address (Etype (Formal))
+ or else not Is_Descendant_Of_Address (Etype (Formal))
or else
Is_Predefined_File_Name
(Unit_File_Name (Get_Source_Unit (N))))
@@ -3347,18 +3488,79 @@ package body Sem_Ch4 is
Next_Actual (Actual);
Next_Formal (Formal);
- -- For an Ada 2012 predicate or invariant, a call may mention
- -- an incomplete type, while resolution of the corresponding
- -- predicate function may see the full view, as a consequence
- -- of the delayed resolution of the corresponding expressions.
+ -- Under relaxed RM semantics silently replace occurrences of
+ -- null by System.Address_Null. We only do this if we know that
+ -- an error will otherwise be issued.
- elsif Ekind (Etype (Formal)) = E_Incomplete_Type
- and then Full_View (Etype (Formal)) = Etype (Actual)
+ elsif Null_To_Null_Address_Convert_OK (Actual, Etype (Formal))
+ and then (Report and not Is_Indexed and not Is_Indirect)
then
- Set_Etype (Formal, Etype (Actual));
+ Replace_Null_By_Null_Address (Actual);
+ Analyze_And_Resolve (Actual, Etype (Formal));
Next_Actual (Actual);
Next_Formal (Formal);
+ elsif Compatible_Types_In_Predicate
+ (Etype (Formal), Etype (Actual))
+ then
+ Next_Actual (Actual);
+ Next_Formal (Formal);
+
+ -- In a complex case where an enclosing generic and a nested
+ -- generic package, both declared with partially parameterized
+ -- formal subprograms with the same names, are instantiated
+ -- with the same type, the types of the actual parameter and
+ -- that of the formal may appear incompatible at first sight.
+
+ -- generic
+ -- type Outer_T is private;
+ -- with function Func (Formal : Outer_T)
+ -- return ... is <>;
+
+ -- package Outer_Gen is
+ -- generic
+ -- type Inner_T is private;
+ -- with function Func (Formal : Inner_T) -- (1)
+ -- return ... is <>;
+
+ -- package Inner_Gen is
+ -- function Inner_Func (Formal : Inner_T) -- (2)
+ -- return ... is (Func (Formal));
+ -- end Inner_Gen;
+ -- end Outer_Generic;
+
+ -- package Outer_Inst is new Outer_Gen (Actual_T);
+ -- package Inner_Inst is new Outer_Inst.Inner_Gen (Actual_T);
+
+ -- In the example above, the type of parameter
+ -- Inner_Func.Formal at (2) is incompatible with the type of
+ -- Func.Formal at (1) in the context of instantiations
+ -- Outer_Inst and Inner_Inst. In reality both types are generic
+ -- actual subtypes renaming base type Actual_T as part of the
+ -- generic prologues for the instantiations.
+
+ -- Recognize this case and add a type conversion to allow this
+ -- kind of generic actual subtype conformance. Note that this
+ -- is done only when the call is non-overloaded because the
+ -- resolution mechanism already has the means to disambiguate
+ -- similar cases.
+
+ elsif not Is_Overloaded (Name (N))
+ and then Is_Type (Etype (Actual))
+ and then Is_Type (Etype (Formal))
+ and then Is_Generic_Actual_Type (Etype (Actual))
+ and then Is_Generic_Actual_Type (Etype (Formal))
+ and then Base_Type (Etype (Actual)) =
+ Base_Type (Etype (Formal))
+ then
+ Rewrite (Actual,
+ Convert_To (Etype (Formal), Relocate_Node (Actual)));
+ Analyze_And_Resolve (Actual, Etype (Formal));
+ Next_Actual (Actual);
+ Next_Formal (Formal);
+
+ -- Handle failed type check
+
else
if Debug_Flag_E then
Write_Str (" type checking fails in call ");
@@ -3481,36 +3683,40 @@ package body Sem_Ch4 is
-- Otherwise action depends on operator
case Op_Name is
- when Name_Op_Add |
- Name_Op_Subtract |
- Name_Op_Multiply |
- Name_Op_Divide |
- Name_Op_Mod |
- Name_Op_Rem |
- Name_Op_Expon =>
+ when Name_Op_Add
+ | Name_Op_Divide
+ | Name_Op_Expon
+ | Name_Op_Mod
+ | Name_Op_Multiply
+ | Name_Op_Rem
+ | Name_Op_Subtract
+ =>
Find_Arithmetic_Types (Act1, Act2, Op_Id, N);
- when Name_Op_And |
- Name_Op_Or |
- Name_Op_Xor =>
+ when Name_Op_And
+ | Name_Op_Or
+ | Name_Op_Xor
+ =>
Find_Boolean_Types (Act1, Act2, Op_Id, N);
- when Name_Op_Lt |
- Name_Op_Le |
- Name_Op_Gt |
- Name_Op_Ge =>
+ when Name_Op_Ge
+ | Name_Op_Gt
+ | Name_Op_Le
+ | Name_Op_Lt
+ =>
Find_Comparison_Types (Act1, Act2, Op_Id, N);
- when Name_Op_Eq |
- Name_Op_Ne =>
+ when Name_Op_Eq
+ | Name_Op_Ne
+ =>
Find_Equality_Types (Act1, Act2, Op_Id, N);
- when Name_Op_Concat =>
+ when Name_Op_Concat =>
Find_Concatenation_Types (Act1, Act2, Op_Id, N);
-- Is this when others, or should it be an abort???
- when others =>
+ when others =>
null;
end case;
@@ -3518,17 +3724,18 @@ package body Sem_Ch4 is
else
case Op_Name is
- when Name_Op_Subtract |
- Name_Op_Add |
- Name_Op_Abs =>
+ when Name_Op_Abs
+ | Name_Op_Add
+ | Name_Op_Subtract
+ =>
Find_Unary_Types (Act1, Op_Id, N);
- when Name_Op_Not =>
+ when Name_Op_Not =>
Find_Negation_Types (Act1, Op_Id, N);
-- Is this when others correct, or should it be an abort???
- when others =>
+ when others =>
null;
end case;
end if;
@@ -3867,7 +4074,16 @@ package body Sem_Ch4 is
if Warn_On_Suspicious_Contract
and then not Referenced (Loop_Id, Cond)
then
- Error_Msg_N ("?T?unused variable &", Loop_Id);
+ -- Generating C, this check causes spurious warnings on inlined
+ -- postconditions; we can safely disable it because this check
+ -- was previously performed when analyzing the internally built
+ -- postconditions procedure.
+
+ if Modify_Tree_For_C and then In_Inlined_Body then
+ null;
+ else
+ Error_Msg_N ("?T?unused variable &", Loop_Id);
+ end if;
end if;
-- Diagnose a possible misuse of the SOME existential quantifier. When
@@ -4108,6 +4324,9 @@ package body Sem_Ch4 is
-- conformant. If the parent node is not analyzed yet it may be an
-- indexed component rather than a function call.
+ function Has_Dereference (Nod : Node_Id) return Boolean;
+ -- Check whether prefix includes a dereference at any level.
+
--------------------------------
-- Find_Component_In_Instance --
--------------------------------
@@ -4209,6 +4428,30 @@ package body Sem_Ch4 is
return True;
end Has_Mode_Conformant_Spec;
+ ---------------------
+ -- Has_Dereference --
+ ---------------------
+
+ function Has_Dereference (Nod : Node_Id) return Boolean is
+ begin
+ if Nkind (Nod) = N_Explicit_Dereference then
+ return True;
+
+ -- When expansion is disabled an explicit dereference may not have
+ -- been inserted, but if this is an access type the indirection makes
+ -- the call safe.
+
+ elsif Is_Access_Type (Etype (Nod)) then
+ return True;
+
+ elsif Nkind_In (Nod, N_Indexed_Component, N_Selected_Component) then
+ return Has_Dereference (Prefix (Nod));
+
+ else
+ return False;
+ end if;
+ end Has_Dereference;
+
-- Start of processing for Analyze_Selected_Component
begin
@@ -4592,8 +4835,15 @@ package body Sem_Ch4 is
In_Scope := In_Open_Scopes (Prefix_Type);
while Present (Comp) loop
+
+ -- Do not examine private operations of the type if not within
+ -- its scope.
+
if Chars (Comp) = Chars (Sel) then
- if Is_Overloadable (Comp) then
+ if Is_Overloadable (Comp)
+ and then (In_Scope
+ or else Comp /= First_Private_Entity (Type_To_Use))
+ then
Add_One_Interp (Sel, Comp, Etype (Comp));
-- If the prefix is tagged, the correct interpretation may
@@ -4603,10 +4853,9 @@ package body Sem_Ch4 is
-- a visible entity is found.
if Is_Tagged_Type (Prefix_Type)
- and then
- Nkind_In (Parent (N), N_Procedure_Call_Statement,
- N_Function_Call,
- N_Indexed_Component)
+ and then Nkind_In (Parent (N), N_Function_Call,
+ N_Indexed_Component,
+ N_Procedure_Call_Statement)
and then Has_Mode_Conformant_Spec (Comp)
then
Has_Candidate := True;
@@ -4657,21 +4906,32 @@ package body Sem_Ch4 is
end loop;
-- If the scope is a current instance, the prefix cannot be an
- -- expression of the same type (that would represent an attempt
- -- to reach an internal operation of another synchronized object).
+ -- expression of the same type, unless the selector designates a
+ -- public operation (otherwise that would represent an attempt to
+ -- reach an internal entity of another synchronized object).
-- This is legal if prefix is an access to such type and there is
- -- a dereference.
+ -- a dereference, or is a component with a dereferenced prefix.
+ -- It is also legal if the prefix is a component of a task type,
+ -- and the selector is one of the task operations.
if In_Scope
and then not Is_Entity_Name (Name)
- and then Nkind (Name) /= N_Explicit_Dereference
+ and then not Has_Dereference (Name)
then
- Error_Msg_NE
- ("invalid reference to internal operation of some object of "
- & "type &", N, Type_To_Use);
- Set_Entity (Sel, Any_Id);
- Set_Etype (Sel, Any_Type);
- return;
+ if Is_Task_Type (Prefix_Type)
+ and then Present (Entity (Sel))
+ and then Ekind_In (Entity (Sel), E_Entry, E_Entry_Family)
+ then
+ null;
+
+ else
+ Error_Msg_NE
+ ("invalid reference to internal operation of some object of "
+ & "type &", N, Type_To_Use);
+ Set_Entity (Sel, Any_Id);
+ Set_Etype (Sel, Any_Type);
+ return;
+ end if;
end if;
-- If there is no visible entity with the given name or none of the
@@ -5158,12 +5418,16 @@ package body Sem_Ch4 is
-- A formal parameter of a specific tagged type whose related subprogram
-- is subject to pragma Extensions_Visible with value "False" cannot
- -- appear in a class-wide conversion (SPARK RM 6.1.7(3)).
+ -- appear in a class-wide conversion (SPARK RM 6.1.7(3)). Do not check
+ -- internally generated expressions.
- if Is_Class_Wide_Type (Typ) and then Is_EVF_Expression (Expr) then
+ if Is_Class_Wide_Type (Typ)
+ and then Comes_From_Source (Expr)
+ and then Is_EVF_Expression (Expr)
+ then
Error_Msg_N
- ("formal parameter with Extensions_Visible False cannot be "
- & "converted to class-wide type", Expr);
+ ("formal parameter cannot be converted to class-wide type when "
+ & "Extensions_Visible is False", Expr);
end if;
end Analyze_Type_Conversion;
@@ -5574,7 +5838,7 @@ package body Sem_Ch4 is
case Nr_Of_Suggestions is
when 1 => Suggestion_1 := Comp;
when 2 => Suggestion_2 := Comp;
- when others => exit;
+ when others => null;
end case;
end if;
end if;
@@ -5644,8 +5908,41 @@ package body Sem_Ch4 is
end loop;
end if;
- -- Analyze each candidate call again, with full error reporting
- -- for each.
+ -- Before listing the possible candidates, check whether this is
+ -- a prefix of a selected component that has been rewritten as a
+ -- parameterless function call because there is a callable candidate
+ -- interpretation. If there is a hidden package in the list of homonyms
+ -- of the function name (bad programming style in any case) suggest that
+ -- this is the intended entity.
+
+ if No (Parameter_Associations (N))
+ and then Nkind (Parent (N)) = N_Selected_Component
+ and then Nkind (Parent (Parent (N))) in N_Declaration
+ and then Is_Overloaded (Nam)
+ then
+ declare
+ Ent : Entity_Id;
+
+ begin
+ Ent := Current_Entity (Nam);
+ while Present (Ent) loop
+ if Ekind (Ent) = E_Package then
+ Error_Msg_N
+ ("no legal interpretations as function call,!", Nam);
+ Error_Msg_NE ("\package& is not visible", N, Ent);
+
+ Rewrite (Parent (N),
+ New_Occurrence_Of (Any_Type, Sloc (N)));
+ return;
+ end if;
+
+ Ent := Homonym (Ent);
+ end loop;
+ end;
+ end if;
+
+ -- Analyze each candidate call again, with full error reporting for
+ -- each.
Error_Msg_N
("no candidate interpretations match the actuals:!", Nam);
@@ -6456,7 +6753,6 @@ package body Sem_Ch4 is
-- Now test the entity we got to see if it is a bad case
case Ekind (Entity (Enode)) is
-
when E_Package =>
Error_Msg_N
("package name cannot be used as operand", Enode);
@@ -6481,13 +6777,15 @@ package body Sem_Ch4 is
Error_Msg_N
("exception name cannot be used as operand", Enode);
- when E_Block | E_Label | E_Loop =>
+ when E_Block
+ | E_Label
+ | E_Loop
+ =>
Error_Msg_N
("label name cannot be used as operand", Enode);
when others =>
return False;
-
end case;
return True;
@@ -6602,7 +6900,7 @@ package body Sem_Ch4 is
-- Boolean, then we know that the other operand cannot resolve to
-- Boolean (since we got no interpretations), but in that case we
-- pretty much know that the other operand should be Boolean, so
- -- resolve it that way (generating an error)
+ -- resolve it that way (generating an error).
elsif Nkind_In (N, N_Op_And, N_Op_Or, N_Op_Xor) then
if Etype (L) = Standard_Boolean then
@@ -6673,8 +6971,8 @@ package body Sem_Ch4 is
return;
elsif Allow_Integer_Address
- and then Is_Descendent_Of_Address (Etype (L))
- and then Is_Descendent_Of_Address (Etype (R))
+ and then Is_Descendant_Of_Address (Etype (L))
+ and then Is_Descendant_Of_Address (Etype (R))
and then not Error_Posted (N)
then
declare
@@ -6705,6 +7003,20 @@ package body Sem_Ch4 is
return;
end;
+
+ -- Under relaxed RM semantics silently replace occurrences of
+ -- null by System.Address_Null.
+
+ elsif Null_To_Null_Address_Convert_OK (N) then
+ Replace_Null_By_Null_Address (N);
+
+ if Nkind_In (N, N_Op_Ge, N_Op_Gt, N_Op_Le, N_Op_Lt) then
+ Analyze_Comparison_Op (N);
+ else
+ Analyze_Arithmetic_Op (N);
+ end if;
+
+ return;
end if;
-- Comparisons on A'Access are common enough to deserve a
@@ -6774,6 +7086,14 @@ package body Sem_Ch4 is
Unchecked_Convert_To (Etype (L), Relocate_Node (R)));
Analyze_Equality_Op (N);
return;
+
+ -- Under relaxed RM semantics silently replace occurrences of
+ -- null by System.Address_Null.
+
+ elsif Null_To_Null_Address_Convert_OK (N) then
+ Replace_Null_By_Null_Address (N);
+ Analyze_Equality_Op (N);
+ return;
end if;
end if;
@@ -6909,7 +7229,7 @@ package body Sem_Ch4 is
procedure Remove_Abstract_Operations (N : Node_Id) is
Abstract_Op : Entity_Id := Empty;
- Address_Descendent : Boolean := False;
+ Address_Descendant : Boolean := False;
I : Interp_Index;
It : Interp;
@@ -6946,8 +7266,8 @@ package body Sem_Ch4 is
Formal := Next_Entity (Formal);
end if;
- if Is_Descendent_Of_Address (Etype (Formal)) then
- Address_Descendent := True;
+ if Is_Descendant_Of_Address (Etype (Formal)) then
+ Address_Descendant := True;
Remove_Interp (I);
end if;
@@ -6974,8 +7294,8 @@ package body Sem_Ch4 is
then
Abstract_Op := It.Nam;
- if Is_Descendent_Of_Address (It.Typ) then
- Address_Descendent := True;
+ if Is_Descendant_Of_Address (It.Typ) then
+ Address_Descendant := True;
Remove_Interp (I);
exit;
@@ -7068,7 +7388,7 @@ package body Sem_Ch4 is
Get_First_Interp (N, I, It);
while Present (It.Nam) loop
- if Is_Descendent_Of_Address (It.Typ) then
+ if Is_Descendant_Of_Address (It.Typ) then
Remove_Interp (I);
elsif not Is_Type (It.Nam) then
@@ -7143,7 +7463,7 @@ package body Sem_Ch4 is
-- predefined operators when addresses are involved since this
-- case is handled separately.
- elsif Ada_Version >= Ada_2005 and then not Address_Descendent then
+ elsif Ada_Version >= Ada_2005 and then not Address_Descendant then
while Present (It.Nam) loop
if Is_Numeric_Type (It.Typ)
and then Scope (It.Typ) = Standard_Standard
@@ -7172,11 +7492,22 @@ package body Sem_Ch4 is
Prefix : Node_Id;
Exprs : List_Id) return Boolean
is
+ Pref_Typ : constant Entity_Id := Etype (Prefix);
+
function Constant_Indexing_OK return Boolean;
-- Constant_Indexing is legal if there is no Variable_Indexing defined
-- for the type, or else node not a target of assignment, or an actual
-- for an IN OUT or OUT formal (RM 4.1.6 (11)).
+ function Find_Indexing_Operations
+ (T : Entity_Id;
+ Nam : Name_Id;
+ Is_Constant : Boolean) return Node_Id;
+ -- Return a reference to the primitive operation of type T denoted by
+ -- name Nam. If the operation is overloaded, the reference carries all
+ -- interpretations. Flag Is_Constant should be set when the context is
+ -- constant indexing.
+
--------------------------
-- Constant_Indexing_OK --
--------------------------
@@ -7185,9 +7516,7 @@ package body Sem_Ch4 is
Par : Node_Id;
begin
- if No (Find_Value_Of_Aspect
- (Etype (Prefix), Aspect_Variable_Indexing))
- then
+ if No (Find_Value_Of_Aspect (Pref_Typ, Aspect_Variable_Indexing)) then
return True;
elsif not Is_Variable (Prefix) then
@@ -7318,7 +7647,7 @@ package body Sem_Ch4 is
end if;
end;
- elsif Nkind ((Par)) in N_Op then
+ elsif Nkind (Par) in N_Op then
return True;
end if;
@@ -7330,6 +7659,226 @@ package body Sem_Ch4 is
return True;
end Constant_Indexing_OK;
+ ------------------------------
+ -- Find_Indexing_Operations --
+ ------------------------------
+
+ function Find_Indexing_Operations
+ (T : Entity_Id;
+ Nam : Name_Id;
+ Is_Constant : Boolean) return Node_Id
+ is
+ procedure Inspect_Declarations
+ (Typ : Entity_Id;
+ Ref : in out Node_Id);
+ -- Traverse the declarative list where type Typ resides and collect
+ -- all suitable interpretations in node Ref.
+
+ procedure Inspect_Primitives
+ (Typ : Entity_Id;
+ Ref : in out Node_Id);
+ -- Traverse the list of primitive operations of type Typ and collect
+ -- all suitable interpretations in node Ref.
+
+ function Is_OK_Candidate
+ (Subp_Id : Entity_Id;
+ Typ : Entity_Id) return Boolean;
+ -- Determine whether subprogram Subp_Id is a suitable indexing
+ -- operation for type Typ. To qualify as such, the subprogram must
+ -- be a function, have at least two parameters, and the type of the
+ -- first parameter must be either Typ, or Typ'Class, or access [to
+ -- constant] with designated type Typ or Typ'Class.
+
+ procedure Record_Interp (Subp_Id : Entity_Id; Ref : in out Node_Id);
+ -- Store subprogram Subp_Id as an interpretation in node Ref
+
+ --------------------------
+ -- Inspect_Declarations --
+ --------------------------
+
+ procedure Inspect_Declarations
+ (Typ : Entity_Id;
+ Ref : in out Node_Id)
+ is
+ Typ_Decl : constant Node_Id := Declaration_Node (Typ);
+ Decl : Node_Id;
+ Subp_Id : Entity_Id;
+
+ begin
+ -- Ensure that the routine is not called with itypes, which lack a
+ -- declarative node.
+
+ pragma Assert (Present (Typ_Decl));
+ pragma Assert (Is_List_Member (Typ_Decl));
+
+ Decl := First (List_Containing (Typ_Decl));
+ while Present (Decl) loop
+ if Nkind (Decl) = N_Subprogram_Declaration then
+ Subp_Id := Defining_Entity (Decl);
+
+ if Is_OK_Candidate (Subp_Id, Typ) then
+ Record_Interp (Subp_Id, Ref);
+ end if;
+ end if;
+
+ Next (Decl);
+ end loop;
+ end Inspect_Declarations;
+
+ ------------------------
+ -- Inspect_Primitives --
+ ------------------------
+
+ procedure Inspect_Primitives
+ (Typ : Entity_Id;
+ Ref : in out Node_Id)
+ is
+ Prim_Elmt : Elmt_Id;
+ Prim_Id : Entity_Id;
+
+ begin
+ Prim_Elmt := First_Elmt (Primitive_Operations (Typ));
+ while Present (Prim_Elmt) loop
+ Prim_Id := Node (Prim_Elmt);
+
+ if Is_OK_Candidate (Prim_Id, Typ) then
+ Record_Interp (Prim_Id, Ref);
+ end if;
+
+ Next_Elmt (Prim_Elmt);
+ end loop;
+ end Inspect_Primitives;
+
+ ---------------------
+ -- Is_OK_Candidate --
+ ---------------------
+
+ function Is_OK_Candidate
+ (Subp_Id : Entity_Id;
+ Typ : Entity_Id) return Boolean
+ is
+ Formal : Entity_Id;
+ Formal_Typ : Entity_Id;
+ Param_Typ : Node_Id;
+
+ begin
+ -- To classify as a suitable candidate, the subprogram must be a
+ -- function whose name matches the argument of aspect Constant or
+ -- Variable_Indexing.
+
+ if Ekind (Subp_Id) = E_Function and then Chars (Subp_Id) = Nam then
+ Formal := First_Formal (Subp_Id);
+
+ -- The candidate requires at least two parameters
+
+ if Present (Formal) and then Present (Next_Formal (Formal)) then
+ Formal_Typ := Empty;
+ Param_Typ := Parameter_Type (Parent (Formal));
+
+ -- Use the designated type when the first parameter is of an
+ -- access type.
+
+ if Nkind (Param_Typ) = N_Access_Definition
+ and then Present (Subtype_Mark (Param_Typ))
+ then
+ -- When the context is a constant indexing, the access
+ -- definition must be access-to-constant. This does not
+ -- apply to variable indexing.
+
+ if not Is_Constant
+ or else Constant_Present (Param_Typ)
+ then
+ Formal_Typ := Etype (Subtype_Mark (Param_Typ));
+ end if;
+
+ -- Otherwise use the parameter type
+
+ else
+ Formal_Typ := Etype (Param_Typ);
+ end if;
+
+ if Present (Formal_Typ) then
+
+ -- Use the specific type when the parameter type is
+ -- class-wide.
+
+ if Is_Class_Wide_Type (Formal_Typ) then
+ Formal_Typ := Etype (Base_Type (Formal_Typ));
+ end if;
+
+ -- Use the full view when the parameter type is private
+ -- or incomplete.
+
+ if Is_Incomplete_Or_Private_Type (Formal_Typ)
+ and then Present (Full_View (Formal_Typ))
+ then
+ Formal_Typ := Full_View (Formal_Typ);
+ end if;
+
+ -- The type of the first parameter must denote the type
+ -- of the container or acts as its ancestor type.
+
+ return
+ Formal_Typ = Typ
+ or else Is_Ancestor (Formal_Typ, Typ);
+ end if;
+ end if;
+ end if;
+
+ return False;
+ end Is_OK_Candidate;
+
+ -------------------
+ -- Record_Interp --
+ -------------------
+
+ procedure Record_Interp (Subp_Id : Entity_Id; Ref : in out Node_Id) is
+ begin
+ if Present (Ref) then
+ Add_One_Interp (Ref, Subp_Id, Etype (Subp_Id));
+
+ -- Otherwise this is the first interpretation. Create a reference
+ -- where all remaining interpretations will be collected.
+
+ else
+ Ref := New_Occurrence_Of (Subp_Id, Sloc (T));
+ end if;
+ end Record_Interp;
+
+ -- Local variables
+
+ Ref : Node_Id;
+ Typ : Entity_Id;
+
+ -- Start of processing for Find_Indexing_Operations
+
+ begin
+ Typ := T;
+
+ -- Use the specific type when the parameter type is class-wide
+
+ if Is_Class_Wide_Type (Typ) then
+ Typ := Root_Type (Typ);
+ end if;
+
+ Ref := Empty;
+ Typ := Underlying_Type (Base_Type (Typ));
+
+ Inspect_Primitives (Typ, Ref);
+
+ -- Now look for explicit declarations of an indexing operation.
+ -- If the type is private the operation may be declared in the
+ -- visible part that contains the partial view.
+
+ if Is_Private_Type (T) then
+ Inspect_Declarations (T, Ref);
+ end if;
+
+ Inspect_Declarations (Typ, Ref);
+
+ return Ref;
+ end Find_Indexing_Operations;
+
-- Local variables
Loc : constant Source_Ptr := Sloc (N);
@@ -7339,6 +7888,11 @@ package body Sem_Ch4 is
Func_Name : Node_Id;
Indexing : Node_Id;
+ Is_Constant_Indexing : Boolean := False;
+ -- This flag reflects the nature of the container indexing. Note that
+ -- the context may be suited for constant indexing, but the type may
+ -- lack a Constant_Indexing annotation.
+
-- Start of processing for Try_Container_Indexing
begin
@@ -7349,7 +7903,7 @@ package body Sem_Ch4 is
return True;
end if;
- C_Type := Etype (Prefix);
+ C_Type := Pref_Typ;
-- If indexing a class-wide container, obtain indexing primitive from
-- specific type.
@@ -7358,33 +7912,43 @@ package body Sem_Ch4 is
C_Type := Etype (Base_Type (C_Type));
end if;
- -- Check whether type has a specified indexing aspect
+ -- Check whether the type has a specified indexing aspect
Func_Name := Empty;
+ -- The context is suitable for constant indexing, so obtain the name of
+ -- the indexing function from aspect Constant_Indexing.
+
if Constant_Indexing_OK then
Func_Name :=
- Find_Value_Of_Aspect (Etype (Prefix), Aspect_Constant_Indexing);
+ Find_Value_Of_Aspect (Pref_Typ, Aspect_Constant_Indexing);
end if;
- if No (Func_Name) then
+ if Present (Func_Name) then
+ Is_Constant_Indexing := True;
+
+ -- Otherwise attempt variable indexing
+
+ else
Func_Name :=
- Find_Value_Of_Aspect (Etype (Prefix), Aspect_Variable_Indexing);
+ Find_Value_Of_Aspect (Pref_Typ, Aspect_Variable_Indexing);
end if;
- -- If aspect does not exist the expression is illegal. Error is
- -- diagnosed in caller.
+ -- The type is not subject to either form of indexing, therefore the
+ -- indexed component does not denote container indexing. If this is a
+ -- true error, it is diagnosed by the caller.
if No (Func_Name) then
- -- The prefix itself may be an indexing of a container: rewrite as
- -- such and re-analyze.
+ -- The prefix itself may be an indexing of a container. Rewrite it
+ -- as such and retry.
- if Has_Implicit_Dereference (Etype (Prefix)) then
- Build_Explicit_Dereference
- (Prefix, First_Discriminant (Etype (Prefix)));
+ if Has_Implicit_Dereference (Pref_Typ) then
+ Build_Explicit_Dereference (Prefix, First_Discriminant (Pref_Typ));
return Try_Container_Indexing (N, Prefix, Exprs);
+ -- Otherwise this is definitely not container indexing
+
else
return False;
end if;
@@ -7403,9 +7967,13 @@ package body Sem_Ch4 is
-- are derived from other types with a Reference aspect.
elsif Is_Derived_Type (C_Type)
- and then Etype (First_Formal (Entity (Func_Name))) /= Etype (Prefix)
+ and then Etype (First_Formal (Entity (Func_Name))) /= Pref_Typ
then
- Func_Name := Find_Primitive_Operations (C_Type, Chars (Func_Name));
+ Func_Name :=
+ Find_Indexing_Operations
+ (T => C_Type,
+ Nam => Chars (Func_Name),
+ Is_Constant => Is_Constant_Indexing);
end if;
Assoc := New_List (Relocate_Node (Prefix));
@@ -7452,10 +8020,12 @@ package body Sem_Ch4 is
if not Is_Overloaded (Func_Name) then
Func := Entity (Func_Name);
+
Indexing :=
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Func, Loc),
Parameter_Associations => Assoc);
+
Set_Parent (Indexing, Parent (N));
Set_Generalized_Indexing (N, Indexing);
Analyze (Indexing);
@@ -7480,7 +8050,6 @@ package body Sem_Ch4 is
Name =>
Make_Identifier (Loc, Chars (Func_Name)),
Parameter_Associations => Assoc);
-
Set_Parent (Indexing, Parent (N));
Set_Generalized_Indexing (N, Indexing);
Set_Etype (N, Any_Type);
@@ -7495,27 +8064,54 @@ package body Sem_Ch4 is
Get_First_Interp (Func_Name, I, It);
Set_Etype (Indexing, Any_Type);
+ -- Analyze each candidate function with the given actuals
+
while Present (It.Nam) loop
Analyze_One_Call (Indexing, It.Nam, False, Success);
+ Get_Next_Interp (I, It);
+ end loop;
- if Success then
+ -- If there are several successful candidates, resolution will
+ -- be by result. Mark the interpretations of the function name
+ -- itself.
- -- Function in current interpretation is a valid candidate.
- -- Its result type is also a potential type for the
- -- original Indexed_Component node.
+ if Is_Overloaded (Indexing) then
+ Get_First_Interp (Indexing, I, It);
+ while Present (It.Nam) loop
Add_One_Interp (Name (Indexing), It.Nam, It.Typ);
+ Get_Next_Interp (I, It);
+ end loop;
+
+ else
+ Set_Etype (Name (Indexing), Etype (Indexing));
+ end if;
+
+ -- Now add the candidate interpretations to the indexing node
+ -- itself, to be replaced later by the function call.
+
+ if Is_Overloaded (Name (Indexing)) then
+ Get_First_Interp (Name (Indexing), I, It);
+
+ while Present (It.Nam) loop
Add_One_Interp (N, It.Nam, It.Typ);
- -- Add implicit dereference interpretation to original node
+ -- Add dereference interpretation if the result type has
+ -- implicit reference discriminants.
if Has_Discriminants (Etype (It.Nam)) then
Check_Implicit_Dereference (N, Etype (It.Nam));
end if;
- end if;
- Get_Next_Interp (I, It);
- end loop;
+ Get_Next_Interp (I, It);
+ end loop;
+
+ else
+ Set_Etype (N, Etype (Name (Indexing)));
+ if Has_Discriminants (Etype (N)) then
+ Check_Implicit_Dereference (N, Etype (N));
+ end if;
+ end if;
end;
end if;
@@ -8467,6 +9063,15 @@ package body Sem_Ch4 is
-- is visible a direct call to it will dispatch to the private one,
-- which is therefore a valid candidate.
+ function Names_Match
+ (Obj_Type : Entity_Id;
+ Prim_Op : Entity_Id;
+ Subprog : Entity_Id) return Boolean;
+ -- Return True if the names of Prim_Op and Subprog match. If Obj_Type
+ -- is a protected type then compare also the original name of Prim_Op
+ -- with the name of Subprog (since the expander may have added a
+ -- prefix to its original name --see Exp_Ch9.Build_Selected_Name).
+
function Valid_First_Argument_Of (Op : Entity_Id) return Boolean;
-- Verify that the prefix, dereferenced if need be, is a valid
-- controlling argument in a call to Op. The remaining actuals
@@ -8643,6 +9248,35 @@ package body Sem_Ch4 is
and then not Is_Hidden (Visible_Op);
end Is_Private_Overriding;
+ -----------------
+ -- Names_Match --
+ -----------------
+
+ function Names_Match
+ (Obj_Type : Entity_Id;
+ Prim_Op : Entity_Id;
+ Subprog : Entity_Id) return Boolean is
+ begin
+ -- Common case: exact match
+
+ if Chars (Prim_Op) = Chars (Subprog) then
+ return True;
+
+ -- For protected type primitives the expander may have built the
+ -- name of the dispatching primitive prepending the type name to
+ -- avoid conflicts with the name of the protected subprogram (see
+ -- Exp_Ch9.Build_Selected_Name).
+
+ elsif Is_Protected_Type (Obj_Type) then
+ return
+ Present (Original_Protected_Subprogram (Prim_Op))
+ and then Chars (Original_Protected_Subprogram (Prim_Op)) =
+ Chars (Subprog);
+ end if;
+
+ return False;
+ end Names_Match;
+
-----------------------------
-- Valid_First_Argument_Of --
-----------------------------
@@ -8657,21 +9291,29 @@ package body Sem_Ch4 is
Typ := Corresponding_Record_Type (Typ);
end if;
- -- Simple case. Object may be a subtype of the tagged type or
- -- may be the corresponding record of a synchronized type.
+ -- Simple case. Object may be a subtype of the tagged type or may
+ -- be the corresponding record of a synchronized type.
return Obj_Type = Typ
or else Base_Type (Obj_Type) = Typ
or else Corr_Type = Typ
+ -- Object may be of a derived type whose parent has unknown
+ -- discriminants, in which case the type matches the underlying
+ -- record view of its base.
+
+ or else
+ (Has_Unknown_Discriminants (Typ)
+ and then Typ = Underlying_Record_View (Base_Type (Obj_Type)))
+
-- Prefix can be dereferenced
or else
(Is_Access_Type (Corr_Type)
and then Designated_Type (Corr_Type) = Typ)
- -- Formal is an access parameter, for which the object
- -- can provide an access.
+ -- Formal is an access parameter, for which the object can
+ -- provide an access.
or else
(Ekind (Typ) = E_Anonymous_Access_Type
@@ -8709,7 +9351,7 @@ package body Sem_Ch4 is
while Present (Elmt) loop
Prim_Op := Node (Elmt);
- if Chars (Prim_Op) = Chars (Subprog)
+ if Names_Match (Obj_Type, Prim_Op, Subprog)
and then Present (First_Formal (Prim_Op))
and then Valid_First_Argument_Of (Prim_Op)
and then
diff --git a/gcc/ada/sem_ch4.ads b/gcc/ada/sem_ch4.ads
index 0a196439fb..a6105c1d5f 100644
--- a/gcc/ada/sem_ch4.ads
+++ b/gcc/ada/sem_ch4.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -64,4 +64,16 @@ package Sem_Ch4 is
-- The resolution of the construct requires some semantic information
-- on the prefix and the indexes.
+ function Try_Object_Operation
+ (N : Node_Id;
+ CW_Test_Only : Boolean := False) return Boolean;
+ -- Ada 2005 (AI-252): Support the object.operation notation. If node N
+ -- is a call in this notation, it is transformed into a normal subprogram
+ -- call where the prefix is a parameter, and True is returned. If node
+ -- N is not of this form, it is unchanged, and False is returned. If
+ -- CW_Test_Only is true then N is an N_Selected_Component node which
+ -- is part of a call to an entry or procedure of a tagged concurrent
+ -- type and this routine is invoked to search for class-wide subprograms
+ -- conflicting with the target entity.
+
end Sem_Ch4;
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index b4e82783b2..bc7693cb5c 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -30,7 +30,6 @@ with Einfo; use Einfo;
with Errout; use Errout;
with Expander; use Expander;
with Exp_Ch6; use Exp_Ch6;
-with Exp_Ch7; use Exp_Ch7;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Ghost; use Ghost;
@@ -42,7 +41,6 @@ with Nmake; use Nmake;
with Opt; use Opt;
with Restrict; use Restrict;
with Rident; use Rident;
-with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Case; use Sem_Case;
@@ -66,6 +64,11 @@ with Uintp; use Uintp;
package body Sem_Ch5 is
+ Current_LHS : Node_Id := Empty;
+ -- Holds the left-hand side of the assignment statement being analyzed.
+ -- Used to determine the type of a target_name appearing on the RHS, for
+ -- AI12-0125 and the use of '@' as an abbreviation for the LHS.
+
Unblocked_Exit_Count : Nat := 0;
-- This variable is used when processing if statements, case statements,
-- and block statements. It counts the number of exit points that are not
@@ -90,6 +93,10 @@ package body Sem_Ch5 is
-- Analyze_Assignment --
------------------------
+ -- WARNING: This routine manages Ghost regions. Return statements must be
+ -- replaced by gotos which jump to the end of the routine and restore the
+ -- Ghost mode.
+
procedure Analyze_Assignment (N : Node_Id) is
Lhs : constant Node_Id := Name (N);
Rhs : constant Node_Id := Expression (N);
@@ -272,11 +279,15 @@ package body Sem_Ch5 is
-- Local variables
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
+ Mode : Ghost_Mode_Type;
-- Start of processing for Analyze_Assignment
begin
+ -- Save LHS for use in target names (AI12-125)
+
+ Current_LHS := Lhs;
+
Mark_Coextensions (N, Rhs);
-- Analyze the target of the assignment first in case the expression
@@ -289,7 +300,7 @@ package body Sem_Ch5 is
-- Ghost entity. Set the mode now to ensure that any nodes generated
-- during analysis and expansion are properly marked as Ghost.
- Set_Ghost_Mode (N);
+ Mark_And_Set_Ghost_Assignment (N, Mode);
Analyze (Rhs);
-- Ensure that we never do an assignment on a variable marked as
@@ -328,6 +339,14 @@ package body Sem_Ch5 is
then
null;
+ -- This may be a call to a parameterless function through an
+ -- implicit dereference, so discard interpretation as well.
+
+ elsif Is_Entity_Name (Lhs)
+ and then Has_Implicit_Dereference (It.Typ)
+ then
+ null;
+
elsif Has_Compatible_Type (Rhs, It.Typ) then
if T1 /= Any_Type then
@@ -358,8 +377,8 @@ package body Sem_Ch5 is
if PIt = No_Interp then
Error_Msg_N
- ("ambiguous left-hand side"
- & " in assignment", Lhs);
+ ("ambiguous left-hand side in "
+ & "assignment", Lhs);
exit;
else
Resolve (Prefix (Lhs), PIt.Typ);
@@ -394,8 +413,7 @@ package body Sem_Ch5 is
Error_Msg_N
("no valid types for left-hand side for assignment", Lhs);
Kill_Lhs;
- Ghost_Mode := Save_Ghost_Mode;
- return;
+ goto Leave;
end if;
end if;
@@ -441,11 +459,7 @@ package body Sem_Ch5 is
-- objects have been previously expanded into calls to the
-- Get_Ceiling run-time subprogram.
- or else
- (Nkind (Ent) = N_Function_Call
- and then (Entity (Name (Ent)) = RTE (RE_Get_Ceiling)
- or else
- Entity (Name (Ent)) = RTE (RO_PE_Get_Ceiling)))
+ or else Is_Expanded_Priority_Attribute (Ent)
then
-- The enclosing subprogram cannot be a protected function
@@ -470,21 +484,20 @@ package body Sem_Ch5 is
-- effect (AARM D.5.2 (5/2)).
if Locking_Policy /= 'C' then
- Error_Msg_N ("assignment to the attribute PRIORITY has " &
- "no effect??", Lhs);
- Error_Msg_N ("\since no Locking_Policy has been " &
- "specified??", Lhs);
+ Error_Msg_N
+ ("assignment to the attribute PRIORITY has no effect??",
+ Lhs);
+ Error_Msg_N
+ ("\since no Locking_Policy has been specified??", Lhs);
end if;
- Ghost_Mode := Save_Ghost_Mode;
- return;
+ goto Leave;
end if;
end if;
end;
Diagnose_Non_Variable_Lhs (Lhs);
- Ghost_Mode := Save_Ghost_Mode;
- return;
+ goto Leave;
-- Error of assigning to limited type. We do however allow this in
-- certain cases where the front end generates the assignments.
@@ -503,17 +516,14 @@ package body Sem_Ch5 is
Explain_Limited_Type (T1, Lhs);
end if;
- Ghost_Mode := Save_Ghost_Mode;
- return;
+ goto Leave;
-- A class-wide type may be a limited view. This illegal case is not
-- caught by previous checks.
- elsif Ekind (T1) = E_Class_Wide_Type
- and then From_Limited_With (T1)
- then
+ elsif Ekind (T1) = E_Class_Wide_Type and then From_Limited_With (T1) then
Error_Msg_NE ("invalid use of limited view of&", Lhs, T1);
- return;
+ goto Leave;
-- Enforce RM 3.9.3 (8): the target of an assignment operation cannot be
-- abstract. This is only checked when the assignment Comes_From_Source,
@@ -551,15 +561,24 @@ package body Sem_Ch5 is
then
Error_Msg_N ("invalid use of incomplete type", Lhs);
Kill_Lhs;
- Ghost_Mode := Save_Ghost_Mode;
- return;
+ goto Leave;
end if;
-- Now we can complete the resolution of the right hand side
Set_Assignment_Type (Lhs, T1);
+
Resolve (Rhs, T1);
+ -- If the right-hand side contains target names, expansion has been
+ -- disabled to prevent expansion that might move target names out of
+ -- the context of the assignment statement. Restore the expander mode
+ -- now so that assignment statement can be properly expanded.
+
+ if Nkind (N) = N_Assignment_Statement and then Has_Target_Names (N) then
+ Expander_Mode_Restore;
+ end if;
+
-- This is the point at which we check for an unset reference
Check_Unset_Reference (Rhs);
@@ -569,8 +588,7 @@ package body Sem_Ch5 is
if Rhs = Error then
Kill_Lhs;
- Ghost_Mode := Save_Ghost_Mode;
- return;
+ goto Leave;
end if;
T2 := Etype (Rhs);
@@ -578,8 +596,7 @@ package body Sem_Ch5 is
if not Covers (T1, T2) then
Wrong_Type (Rhs, Etype (Lhs));
Kill_Lhs;
- Ghost_Mode := Save_Ghost_Mode;
- return;
+ goto Leave;
end if;
-- Ada 2005 (AI-326): In case of explicit dereference of incomplete
@@ -606,8 +623,7 @@ package body Sem_Ch5 is
if T1 = Any_Type or else T2 = Any_Type then
Kill_Lhs;
- Ghost_Mode := Save_Ghost_Mode;
- return;
+ goto Leave;
end if;
-- If the rhs is class-wide or dynamically tagged, then require the lhs
@@ -699,8 +715,7 @@ package body Sem_Ch5 is
-- to reset Is_True_Constant, and desirable for xref purposes.
Note_Possible_Modification (Lhs, Sure => True);
- Ghost_Mode := Save_Ghost_Mode;
- return;
+ goto Leave;
-- If we know the right hand side is non-null, then we convert to the
-- target type, since we don't need a run time check in that case.
@@ -803,7 +818,7 @@ package body Sem_Ch5 is
Set_Referenced_Modified (Lhs, Out_Param => False);
end if;
- -- RM 7.3.2 (12/3) An assignment to a view conversion (from a type
+ -- RM 7.3.2 (12/3): An assignment to a view conversion (from a type
-- to one of its ancestors) requires an invariant check. Apply check
-- only if expression comes from source, otherwise it will be applied
-- when value is assigned to source entity.
@@ -836,10 +851,24 @@ package body Sem_Ch5 is
-- warnings when an assignment is rewritten as another
-- assignment, and gets tied up with itself.
+ -- There may have been a previous reference to a component of
+ -- the variable, which in general removes the Last_Assignment
+ -- field of the variable to indicate a relevant use of the
+ -- previous assignment. However, if the assignment is to a
+ -- subcomponent the reference may not have registered, because
+ -- it is not possible to determine whether the context is an
+ -- assignment. In those cases we generate a Deferred_Reference,
+ -- to be used at the end of compilation to generate the right
+ -- kind of reference, and we suppress a potential warning for
+ -- a useless assignment, which might be premature. This may
+ -- lose a warning in rare cases, but seems preferable to a
+ -- misleading warning.
+
if Warn_On_Modified_Unread
and then Is_Assignable (Ent)
and then Comes_From_Source (N)
and then In_Extended_Main_Source_Unit (Ent)
+ and then not Has_Deferred_Reference (Ent)
then
Warn_On_Useless_Assignment (Ent, N);
end if;
@@ -906,7 +935,10 @@ package body Sem_Ch5 is
end;
Analyze_Dimension (N);
- Ghost_Mode := Save_Ghost_Mode;
+
+ <<Leave>>
+ Current_LHS := Empty;
+ Restore_Ghost_Mode (Mode);
end Analyze_Assignment;
-----------------------------
@@ -1068,7 +1100,6 @@ package body Sem_Ch5 is
end if;
Check_References (Ent);
- Warn_On_Useless_Assignments (Ent);
End_Scope;
if Unblocked_Exit_Count = 0 then
@@ -1753,15 +1784,6 @@ package body Sem_Ch5 is
------------------------------------
procedure Analyze_Iterator_Specification (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Def_Id : constant Node_Id := Defining_Identifier (N);
- Subt : constant Node_Id := Subtype_Indication (N);
- Iter_Name : constant Node_Id := Name (N);
-
- Ent : Entity_Id;
- Typ : Entity_Id;
- Bas : Entity_Id;
-
procedure Check_Reverse_Iteration (Typ : Entity_Id);
-- For an iteration over a container, if the loop carries the Reverse
-- indicator, verify that the container type has an Iterate aspect that
@@ -1795,7 +1817,15 @@ package body Sem_Ch5 is
Ent : Entity_Id;
begin
- Ent := First_Entity (Scope (Typ));
+ -- If iterator type is derived, the cursor is declared in the scope
+ -- of the parent type.
+
+ if Is_Derived_Type (Typ) then
+ Ent := First_Entity (Scope (Etype (Typ)));
+ else
+ Ent := First_Entity (Scope (Typ));
+ end if;
+
while Present (Ent) loop
exit when Chars (Ent) = Name_Cursor;
Next_Entity (Ent);
@@ -1815,7 +1845,17 @@ package body Sem_Ch5 is
return Etype (Ent);
end Get_Cursor_Type;
- -- Start of processing for Analyze_iterator_Specification
+ -- Local variables
+
+ Def_Id : constant Node_Id := Defining_Identifier (N);
+ Iter_Name : constant Node_Id := Name (N);
+ Loc : constant Source_Ptr := Sloc (N);
+ Subt : constant Node_Id := Subtype_Indication (N);
+
+ Bas : Entity_Id;
+ Typ : Entity_Id;
+
+ -- Start of processing for Analyze_Iterator_Specification
begin
Enter_Name (Def_Id);
@@ -1916,13 +1956,12 @@ package body Sem_Ch5 is
and then (Nkind (Parent (N)) /= N_Quantified_Expression
or else Operating_Mode = Check_Semantics)
- -- Do not perform this expansion in SPARK mode, since the formal
- -- verification directly deals with the source form of the iterator.
- -- Ditto for ASIS, where the temporary may hide the transformation
- -- of a selected component into a prefixed function call.
+ -- Do not perform this expansion for ASIS and when expansion is
+ -- disabled, where the temporary may hide the transformation of a
+ -- selected component into a prefixed function call, and references
+ -- need to see the original expression.
- and then not GNATprove_Mode
- and then not ASIS_Mode
+ and then Expander_Active
then
declare
Id : constant Entity_Id := Make_Temporary (Loc, 'R', Iter_Name);
@@ -1987,16 +2026,6 @@ package body Sem_Ch5 is
Name =>
New_Copy_Tree (Iter_Name, New_Sloc => Loc));
- -- Create a transient scope to ensure that all the temporaries
- -- generated by Remove_Side_Effects as part of processing this
- -- renaming declaration (if any) are attached by Insert_Actions
- -- to it. It has no effect on the generated code if no actions
- -- are added to it (see Wrap_Transient_Declaration).
-
- if Expander_Active then
- Establish_Transient_Scope (Name (Decl), Sec_Stack => True);
- end if;
-
Insert_Actions (Parent (Parent (N)), New_List (Decl));
Rewrite (Name (N), New_Occurrence_Of (Id, Loc));
Set_Etype (Id, Typ);
@@ -2145,11 +2174,15 @@ package body Sem_Ch5 is
else
declare
- Element : constant Entity_Id :=
- Find_Value_Of_Aspect (Typ, Aspect_Iterator_Element);
- Iterator : constant Entity_Id :=
- Find_Value_Of_Aspect (Typ, Aspect_Default_Iterator);
- Cursor_Type : Entity_Id;
+ Element : constant Entity_Id :=
+ Find_Value_Of_Aspect
+ (Typ, Aspect_Iterator_Element);
+ Iterator : constant Entity_Id :=
+ Find_Value_Of_Aspect
+ (Typ, Aspect_Default_Iterator);
+ Orig_Iter_Name : constant Node_Id :=
+ Original_Node (Iter_Name);
+ Cursor_Type : Entity_Id;
begin
if No (Element) then
@@ -2187,8 +2220,9 @@ package body Sem_Ch5 is
if not Is_Variable (Iter_Name)
and then not Has_Aspect (Typ, Aspect_Constant_Indexing)
then
- Error_Msg_N ("iteration over constant container "
- & "require constant_indexing aspect", N);
+ Error_Msg_N
+ ("iteration over constant container require "
+ & "constant_indexing aspect", N);
-- The Iterate function may have an in_out parameter,
-- and a constant container is thus illegal.
@@ -2199,15 +2233,24 @@ package body Sem_Ch5 is
E_In_Parameter
and then not Is_Variable (Iter_Name)
then
- Error_Msg_N
- ("variable container expected", N);
+ Error_Msg_N ("variable container expected", N);
end if;
- if Nkind (Original_Node (Iter_Name))
- = N_Selected_Component
+ -- Detect a case where the iterator denotes a component
+ -- of a mutable object which depends on a discriminant.
+ -- Note that the iterator may denote a function call in
+ -- qualified form, in which case this check should not
+ -- be performed.
+
+ if Nkind (Orig_Iter_Name) = N_Selected_Component
and then
- Is_Dependent_Component_Of_Mutable_Object
- (Original_Node (Iter_Name))
+ Present (Entity (Selector_Name (Orig_Iter_Name)))
+ and then Ekind_In
+ (Entity (Selector_Name (Orig_Iter_Name)),
+ E_Component,
+ E_Discriminant)
+ and then Is_Dependent_Component_Of_Mutable_Object
+ (Orig_Iter_Name)
then
Error_Msg_N
("container cannot be a discriminant-dependent "
@@ -2259,9 +2302,11 @@ package body Sem_Ch5 is
-- If that object is a selected component, verify that it is not
-- a component of an unconstrained mutable object.
- if Nkind (Iter_Name) = N_Identifier then
+ if Nkind (Iter_Name) = N_Identifier
+ or else (not Expander_Active and Comes_From_Source (Iter_Name))
+ then
declare
- Orig_Node : constant Node_Id := Original_Node (Iter_Name);
+ Orig_Node : constant Node_Id := Original_Node (Iter_Name);
Iter_Kind : constant Node_Kind := Nkind (Orig_Node);
Obj : Node_Id;
@@ -2298,28 +2343,14 @@ package body Sem_Ch5 is
Get_Cursor_Type
(Parent (Find_Value_Of_Aspect (Typ, Aspect_Iterable)),
Typ));
- Ent := Etype (Def_Id);
else
Set_Etype (Def_Id, Get_Cursor_Type (Typ));
+ Check_Reverse_Iteration (Etype (Iter_Name));
end if;
end if;
end if;
-
- -- A loop parameter cannot be effectively volatile (SPARK RM 7.1.3(4)).
- -- This check is relevant only when SPARK_Mode is on as it is not a
- -- standard Ada legality check.
-
- -- Not clear whether this applies to element iterators, where the
- -- cursor is not an explicit entity ???
-
- if SPARK_Mode = On
- and then not Of_Present (N)
- and then Is_Effectively_Volatile (Ent)
- then
- Error_Msg_N ("loop parameter cannot be volatile", Ent);
- end if;
end Analyze_Iterator_Specification;
-------------------
@@ -2747,8 +2778,9 @@ package body Sem_Ch5 is
-- a) a function call,
-- b) an identifier that is not a type,
- -- c) an attribute reference 'Old (within a postcondition)
- -- d) an unchecked conversion
+ -- c) an attribute reference 'Old (within a postcondition),
+ -- d) an unchecked conversion or a qualified expression with
+ -- the proper iterator type.
-- then it is an iteration over a container. It was classified as
-- a loop specification by the parser, and must be rewritten now
@@ -2758,13 +2790,19 @@ package body Sem_Ch5 is
-- conversion is always an object.
if Nkind (DS_Copy) = N_Function_Call
+
or else (Is_Entity_Name (DS_Copy)
and then not Is_Type (Entity (DS_Copy)))
+
or else (Nkind (DS_Copy) = N_Attribute_Reference
and then Nam_In (Attribute_Name (DS_Copy),
- Name_Old, Name_Loop_Entry))
- or else Nkind (DS_Copy) = N_Unchecked_Type_Conversion
+ Name_Loop_Entry, Name_Old))
+
or else Has_Aspect (Etype (DS_Copy), Aspect_Iterable)
+
+ or else Nkind (DS_Copy) = N_Unchecked_Type_Conversion
+ or else (Nkind (DS_Copy) = N_Qualified_Expression
+ and then Is_Iterator (Etype (DS_Copy)))
then
-- This is an iterator specification. Rewrite it as such and
-- analyze it to capture function calls that may require
@@ -3138,11 +3176,13 @@ package body Sem_Ch5 is
Set_Parent (DS_Copy, Parent (DS));
Preanalyze_Range (DS_Copy);
- -- Check for a call to Iterate ()
+ -- Check for a call to Iterate () or an expression with
+ -- an iterator type.
return
- Nkind (DS_Copy) = N_Function_Call
- and then Needs_Finalization (Etype (DS_Copy));
+ (Nkind (DS_Copy) = N_Function_Call
+ and then Needs_Finalization (Etype (DS_Copy)))
+ or else Is_Iterator (Etype (DS_Copy));
end;
end if;
end Is_Container_Iterator;
@@ -3213,7 +3253,7 @@ package body Sem_Ch5 is
-- Verify that the loop name is hot hidden by an unrelated
-- declaration in an inner scope.
- elsif Ekind (Ent) /= E_Label and then Ekind (Ent) /= E_Loop then
+ elsif Ekind (Ent) /= E_Label and then Ekind (Ent) /= E_Loop then
Error_Msg_Sloc := Sloc (Ent);
Error_Msg_N ("implicit label declaration for & is hidden#", Id);
@@ -3257,6 +3297,19 @@ package body Sem_Ch5 is
Set_Has_Created_Identifier (N);
end if;
+ -- If the iterator specification has a syntactic error, transform
+ -- construct into an infinite loop to prevent a crash and perform
+ -- some analysis.
+
+ if Present (Iter)
+ and then Present (Iterator_Specification (Iter))
+ and then Error_Posted (Iterator_Specification (Iter))
+ then
+ Set_Iteration_Scheme (N, Empty);
+ Analyze (N);
+ return;
+ end if;
+
-- Iteration over a container in Ada 2012 involves the creation of a
-- controlled iterator object. Wrap the loop in a block to ensure the
-- timely finalization of the iterator and release of container locks.
@@ -3386,13 +3439,16 @@ package body Sem_Ch5 is
-- expanded).
-- In other cases in GNATprove mode then we want to analyze the loop
- -- body now, since no rewriting will occur.
+ -- body now, since no rewriting will occur. Within a generic the
+ -- GNATprove mode is irrelevant, we must analyze the generic for
+ -- non-local name capture.
if Present (Iter)
and then Present (Iterator_Specification (Iter))
then
if GNATprove_Mode
and then Is_Iterator_Over_Array (Iterator_Specification (Iter))
+ and then not Inside_A_Generic
then
null;
@@ -3477,6 +3533,31 @@ package body Sem_Ch5 is
null;
end Analyze_Null_Statement;
+ -------------------------
+ -- Analyze_Target_Name --
+ -------------------------
+
+ procedure Analyze_Target_Name (N : Node_Id) is
+ begin
+ if No (Current_LHS) then
+ Error_Msg_N ("target name can only appear within an assignment", N);
+ Set_Etype (N, Any_Type);
+
+ else
+ Set_Has_Target_Names (Parent (Current_LHS));
+ Set_Etype (N, Etype (Current_LHS));
+
+ -- Disable expansion for the rest of the analysis of the current
+ -- right-hand side. The enclosing assignment statement will be
+ -- rewritten during expansion, together with occurrences of the
+ -- target name.
+
+ if Expander_Active then
+ Expander_Mode_Save_And_Set (False);
+ end if;
+ end if;
+ end Analyze_Target_Name;
+
------------------------
-- Analyze_Statements --
------------------------
diff --git a/gcc/ada/sem_ch5.ads b/gcc/ada/sem_ch5.ads
index 9c2908384e..99a29510d7 100644
--- a/gcc/ada/sem_ch5.ads
+++ b/gcc/ada/sem_ch5.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -42,6 +42,7 @@ package Sem_Ch5 is
procedure Analyze_Loop_Statement (N : Node_Id);
procedure Analyze_Null_Statement (N : Node_Id);
procedure Analyze_Statements (L : List_Id);
+ procedure Analyze_Target_Name (N : Node_Id);
procedure Analyze_Label_Entity (E : Entity_Id);
-- This procedure performs direct analysis of the label entity E. It
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index a5003bb78c..5a54515c4b 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -62,6 +62,7 @@ with Sem_Ch3; use Sem_Ch3;
with Sem_Ch4; use Sem_Ch4;
with Sem_Ch5; use Sem_Ch5;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch9; use Sem_Ch9;
with Sem_Ch10; use Sem_Ch10;
with Sem_Ch12; use Sem_Ch12;
with Sem_Ch13; use Sem_Ch13;
@@ -232,13 +233,6 @@ package body Sem_Ch6 is
Set_Categorization_From_Scope (Subp_Id, Scop);
- -- An abstract subprogram declared within a Ghost region is rendered
- -- Ghost (SPARK RM 6.9(2)).
-
- if Ghost_Mode > None then
- Set_Is_Ghost_Entity (Subp_Id);
- end if;
-
if Ekind (Scope (Subp_Id)) = E_Protected_Type then
Error_Msg_N ("abstract subprogram not allowed in protected type", N);
@@ -274,17 +268,18 @@ package body Sem_Ch6 is
LocX : constant Source_Ptr := Sloc (Expr);
Spec : constant Node_Id := Specification (N);
- Def_Id : Entity_Id;
+ Asp : Node_Id;
+ Def_Id : Entity_Id;
+ New_Body : Node_Id;
+ New_Spec : Node_Id;
+ Orig_N : Node_Id;
+ Ret : Node_Id;
+ Ret_Type : Entity_Id;
Prev : Entity_Id;
-- If the expression is a completion, Prev is the entity whose
-- declaration is completed. Def_Id is needed to analyze the spec.
- New_Body : Node_Id;
- New_Spec : Node_Id;
- Ret : Node_Id;
- Asp : Node_Id;
-
begin
-- This is one of the occasions on which we transform the tree during
-- semantic analysis. If this is a completion, transform the expression
@@ -362,7 +357,7 @@ package body Sem_Ch6 is
Set_Is_Inlined (Prev);
-- If the expression function is a completion, the previous declaration
- -- must come from source. We know already that appears in the current
+ -- must come from source. We know already that it appears in the current
-- scope. The entity itself may be internally created if within a body
-- to be inlined.
@@ -371,8 +366,10 @@ package body Sem_Ch6 is
and then not Is_Formal_Subprogram (Prev)
then
Set_Has_Completion (Prev, False);
+ Set_Is_Inlined (Prev);
+ Ret_Type := Etype (Prev);
- -- An expression function that is a completion freezes the
+ -- An expression function which acts as a completion freezes the
-- expression. This means freezing the return type, and if it is
-- an access type, freezing its designated type as well.
@@ -380,7 +377,31 @@ package body Sem_Ch6 is
-- expression itself, because a freeze node might appear in a nested
-- scope, leading to an elaboration order issue in gigi.
- Freeze_Before (N, Etype (Prev));
+ Freeze_Before (N, Ret_Type);
+
+ -- An entity can only be frozen if it is complete, so if the type
+ -- is still unfrozen it must still be incomplete in some way, e.g.
+ -- a private type without a full view, or a type derived from such
+ -- in an enclosing scope. Except in a generic context, such use of
+ -- an incomplete type is an error. On the other hand, if this is a
+ -- limited view of a type, the type is declared in another unit and
+ -- frozen there. We must be in a context seeing the nonlimited view
+ -- of the type, which will be installed when the body is compiled.
+
+ if not Is_Frozen (Ret_Type)
+ and then not Is_Generic_Type (Ret_Type)
+ and then not Inside_A_Generic
+ then
+ if From_Limited_With (Ret_Type)
+ and then Present (Non_Limited_View (Ret_Type))
+ then
+ null;
+ else
+ Error_Msg_NE
+ ("premature use of private type&",
+ Result_Definition (Specification (N)), Ret_Type);
+ end if;
+ end if;
if Is_Access_Type (Etype (Prev)) then
Freeze_Before (N, Designated_Type (Etype (Prev)));
@@ -391,12 +412,11 @@ package body Sem_Ch6 is
Generate_Reference (Prev, Defining_Entity (N), 'b', Force => True);
Rewrite (N, New_Body);
- -- Correct the parent pointer of the aspect specification list to
- -- reference the rewritten node.
+ -- Remove any existing aspects from the original node because the act
+ -- of rewriting causes the list to be shared between the two nodes.
- if Has_Aspects (N) then
- Set_Parent (Aspect_Specifications (N), N);
- end if;
+ Orig_N := Original_Node (N);
+ Remove_Aspects (Orig_N);
-- Propagate any pragmas that apply to the expression function to the
-- proper body when the expression function acts as a completion.
@@ -405,13 +425,20 @@ package body Sem_Ch6 is
Relocate_Pragmas_To_Body (N);
Analyze (N);
+ -- Once the aspects of the generated body have been analyzed, create
+ -- a copy for ASIS purposes and associate it with the original node.
+
+ if Has_Aspects (N) then
+ Set_Aspect_Specifications (Orig_N,
+ New_Copy_List_Tree (Aspect_Specifications (N)));
+ end if;
+
-- Prev is the previous entity with the same name, but it is can
-- be an unrelated spec that is not completed by the expression
-- function. In that case the relevant entity is the one in the body.
-- Not clear that the backend can inline it in this case ???
if Has_Completion (Prev) then
- Set_Is_Inlined (Prev);
-- The formals of the expression function are body formals,
-- and do not appear in the ali file, which will only contain
@@ -451,15 +478,21 @@ package body Sem_Ch6 is
Rewrite (N, Make_Subprogram_Declaration (Loc, Specification => Spec));
- -- Correct the parent pointer of the aspect specification list to
- -- reference the rewritten node.
+ -- Remove any existing aspects from the original node because the act
+ -- of rewriting causes the list to be shared between the two nodes.
- if Has_Aspects (N) then
- Set_Parent (Aspect_Specifications (N), N);
- end if;
+ Orig_N := Original_Node (N);
+ Remove_Aspects (Orig_N);
Analyze (N);
- Def_Id := Defining_Entity (N);
+
+ -- Once the aspects of the generated spec have been analyzed, create
+ -- a copy for ASIS purposes and associate it with the original node.
+
+ if Has_Aspects (N) then
+ Set_Aspect_Specifications (Orig_N,
+ New_Copy_List_Tree (Aspect_Specifications (N)));
+ end if;
-- If aspect SPARK_Mode was specified on the body, it needs to be
-- repeated both on the generated spec and the body.
@@ -472,6 +505,8 @@ package body Sem_Ch6 is
Set_Aspect_Specifications (New_Body, New_List (Asp));
end if;
+ Def_Id := Defining_Entity (N);
+
-- Within a generic pre-analyze the original expression for name
-- capture. The body is also generated but plays no role in
-- this because it is not part of the original source.
@@ -623,7 +658,7 @@ package body Sem_Ch6 is
-- Function result subtype
procedure Check_Aggregate_Accessibility (Aggr : Node_Id);
- -- Apply legality rule of 6.5 (8.2) to the access discriminants of an
+ -- Apply legality rule of 6.5 (5.8) to the access discriminants of an
-- aggregate in a return statement.
procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id);
@@ -635,11 +670,11 @@ package body Sem_Ch6 is
-----------------------------------
procedure Check_Aggregate_Accessibility (Aggr : Node_Id) is
- Typ : constant Entity_Id := Etype (Aggr);
- Assoc : Node_Id;
- Discr : Entity_Id;
- Expr : Node_Id;
- Obj : Node_Id;
+ Typ : constant Entity_Id := Etype (Aggr);
+ Assoc : Node_Id;
+ Discr : Entity_Id;
+ Expr : Node_Id;
+ Obj : Node_Id;
begin
if Is_Record_Type (Typ) and then Has_Discriminants (Typ) then
@@ -648,6 +683,7 @@ package body Sem_Ch6 is
while Present (Discr) loop
if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then
Expr := Expression (Assoc);
+
if Nkind (Expr) = N_Attribute_Reference
and then Attribute_Name (Expr) /= Name_Unrestricted_Access
then
@@ -658,21 +694,24 @@ package body Sem_Ch6 is
Obj := Prefix (Obj);
end loop;
- -- No check needed for an aliased formal.
- -- A run-time check may still be needed ???
+ -- Do not check aliased formals or function calls. A
+ -- run-time check may still be needed ???
if Is_Entity_Name (Obj)
- and then Is_Formal (Entity (Obj))
- and then Is_Aliased (Entity (Obj))
+ and then Comes_From_Source (Obj)
then
- null;
+ if Is_Formal (Entity (Obj))
+ and then Is_Aliased (Entity (Obj))
+ then
+ null;
- elsif Object_Access_Level (Obj) >
- Scope_Depth (Scope (Scope_Id))
- then
- Error_Msg_N
- ("access discriminant in return aggregate would be "
- & "a dangling reference", Obj);
+ elsif Object_Access_Level (Obj) >
+ Scope_Depth (Scope (Scope_Id))
+ then
+ Error_Msg_N
+ ("access discriminant in return aggregate would "
+ & "be a dangling reference", Obj);
+ end if;
end if;
end if;
end if;
@@ -774,9 +813,8 @@ package body Sem_Ch6 is
-- If the return object is of an anonymous access type, then report
-- an error if the function's result type is not also anonymous.
- elsif R_Stm_Type_Is_Anon_Access
- and then not R_Type_Is_Anon_Access
- then
+ elsif R_Stm_Type_Is_Anon_Access then
+ pragma Assert (not R_Type_Is_Anon_Access);
Error_Msg_N ("anonymous access not allowed for function with "
& "named access result", Subtype_Ind);
@@ -1240,19 +1278,6 @@ package body Sem_Ch6 is
Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Gen_Id));
Set_Scope (Body_Id, Scope (Gen_Id));
- -- Inherit the "ghostness" of the generic spec. Note that this
- -- property is not directly inherited as the body may be subject
- -- to a different Ghost assertion policy.
-
- if Ghost_Mode > None or else Is_Ghost_Entity (Gen_Id) then
- Set_Is_Ghost_Entity (Body_Id);
-
- -- The Ghost policy in effect at the point of declaration and at
- -- the point of completion must match (SPARK RM 6.9(14)).
-
- Check_Ghost_Completion (Gen_Id, Body_Id);
- end if;
-
Check_Fully_Conformant (Body_Id, Gen_Id, Body_Id);
if Nkind (N) = N_Subprogram_Body_Stub then
@@ -1510,10 +1535,15 @@ package body Sem_Ch6 is
-- Analyze_Procedure_Call --
----------------------------
+ -- WARNING: This routine manages Ghost regions. Return statements must be
+ -- replaced by gotos which jump to the end of the routine and restore the
+ -- Ghost mode.
+
procedure Analyze_Procedure_Call (N : Node_Id) is
procedure Analyze_Call_And_Resolve;
- -- Do Analyze and Resolve calls for procedure call
- -- At end, check illegal order dependence.
+ -- Do Analyze and Resolve calls for procedure call. At the end, check
+ -- for illegal order dependence.
+ -- ??? where is the check for illegal order dependencies?
------------------------------
-- Analyze_Call_And_Resolve --
@@ -1535,10 +1565,9 @@ package body Sem_Ch6 is
Loc : constant Source_Ptr := Sloc (N);
P : constant Node_Id := Name (N);
Actual : Node_Id;
+ Mode : Ghost_Mode_Type;
New_N : Node_Id;
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
-
-- Start of processing for Analyze_Procedure_Call
begin
@@ -1580,7 +1609,7 @@ package body Sem_Ch6 is
-- Set the mode now to ensure that any nodes generated during analysis
-- and expansion are properly marked as Ghost.
- Set_Ghost_Mode (N);
+ Mark_And_Set_Ghost_Procedure_Call (N, Mode);
-- Otherwise analyze the parameters
@@ -1604,7 +1633,7 @@ package body Sem_Ch6 is
if Present (Actuals) then
Error_Msg_N
("no parameters allowed for this call", First (Actuals));
- return;
+ goto Leave;
end if;
Set_Etype (N, Standard_Void_Type);
@@ -1614,8 +1643,7 @@ package body Sem_Ch6 is
and then Is_Record_Type (Etype (Entity (P)))
and then Remote_AST_I_Dereference (P)
then
- Ghost_Mode := Save_Ghost_Mode;
- return;
+ goto Leave;
elsif Is_Entity_Name (P)
and then Ekind (Entity (P)) /= E_Entry_Family
@@ -1687,10 +1715,34 @@ package body Sem_Ch6 is
elsif Nkind (P) = N_Selected_Component
and then Ekind_In (Entity (Selector_Name (P)), E_Entry,
- E_Procedure,
- E_Function)
+ E_Function,
+ E_Procedure)
then
- Analyze_Call_And_Resolve;
+ -- When front-end inlining is enabled, as with SPARK_Mode, a call
+ -- in prefix notation may still be missing its controlling argument,
+ -- so perform the transformation now.
+
+ if SPARK_Mode = On and then In_Inlined_Body then
+ declare
+ Subp : constant Entity_Id := Entity (Selector_Name (P));
+ Typ : constant Entity_Id := Etype (Prefix (P));
+
+ begin
+ if Is_Tagged_Type (Typ)
+ and then Present (First_Formal (Subp))
+ and then Etype (First_Formal (Subp)) = Typ
+ and then Try_Object_Operation (P)
+ then
+ return;
+
+ else
+ Analyze_Call_And_Resolve;
+ end if;
+ end;
+
+ else
+ Analyze_Call_And_Resolve;
+ end if;
elsif Nkind (P) = N_Selected_Component
and then Ekind (Entity (Selector_Name (P))) = E_Entry_Family
@@ -1704,7 +1756,7 @@ package body Sem_Ch6 is
New_N :=
Make_Indexed_Component (Loc,
- Prefix => New_Copy (P),
+ Prefix => New_Copy (P),
Expressions => Actuals);
Set_Name (N, New_N);
Set_Etype (New_N, Standard_Void_Type);
@@ -1751,7 +1803,8 @@ package body Sem_Ch6 is
Error_Msg_N ("invalid procedure or entry call", N);
end if;
- Ghost_Mode := Save_Ghost_Mode;
+ <<Leave>>
+ Restore_Ghost_Mode (Mode);
end Analyze_Procedure_Call;
------------------------------
@@ -1759,9 +1812,8 @@ package body Sem_Ch6 is
------------------------------
procedure Analyze_Return_Statement (N : Node_Id) is
-
- pragma Assert (Nkind_In (N, N_Simple_Return_Statement,
- N_Extended_Return_Statement));
+ pragma Assert (Nkind_In (N, N_Extended_Return_Statement,
+ N_Simple_Return_Statement));
Returns_Object : constant Boolean :=
Nkind (N) = N_Extended_Return_Statement
@@ -2143,16 +2195,23 @@ package body Sem_Ch6 is
-- specification matters, and is used to create a proper declaration for
-- the subprogram, or to perform conformance checks.
+ -- WARNING: This routine manages Ghost regions. Return statements must be
+ -- replaced by gotos which jump to the end of the routine and restore the
+ -- Ghost mode.
+
procedure Analyze_Subprogram_Body_Helper (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Body_Spec : Node_Id := Specification (N);
- Body_Id : Entity_Id := Defining_Entity (Body_Spec);
- Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id);
- Conformant : Boolean;
- HSS : Node_Id;
- Prot_Typ : Entity_Id := Empty;
- Spec_Id : Entity_Id;
- Spec_Decl : Node_Id := Empty;
+ Body_Spec : Node_Id := Specification (N);
+ Body_Id : Entity_Id := Defining_Entity (Body_Spec);
+ Loc : constant Source_Ptr := Sloc (N);
+ Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id);
+
+ Conformant : Boolean;
+ Desig_View : Entity_Id := Empty;
+ Exch_Views : Elist_Id := No_Elist;
+ HSS : Node_Id;
+ Prot_Typ : Entity_Id := Empty;
+ Spec_Decl : Node_Id := Empty;
+ Spec_Id : Entity_Id;
Last_Real_Spec_Entity : Entity_Id := Empty;
-- When we analyze a separate spec, the entity chain ends up containing
@@ -2178,6 +2237,11 @@ package body Sem_Ch6 is
-- Check whether unanalyzed body has an aspect or pragma that may
-- generate a SPARK contract.
+ function Body_Has_SPARK_Mode_On return Boolean;
+ -- Check whether SPARK_Mode On applies to the subprogram body, either
+ -- because it is specified directly on the body, or because it is
+ -- inherited from the enclosing subprogram or package.
+
procedure Build_Subprogram_Declaration;
-- Create a matching subprogram declaration for subprogram body N
@@ -2209,16 +2273,25 @@ package body Sem_Ch6 is
-- mechanism is used to find the corresponding spec of the primitive
-- body.
- procedure Exchange_Limited_Views (Subp_Id : Entity_Id);
+ function Exchange_Limited_Views (Subp_Id : Entity_Id) return Elist_Id;
-- Ada 2012 (AI05-0151): Detect whether the profile of Subp_Id contains
- -- incomplete types coming from a limited context and swap their limited
- -- views with the non-limited ones.
+ -- incomplete types coming from a limited context and replace their
+ -- limited views with the non-limited ones. Return the list of changes
+ -- to be used to undo the transformation.
+
+ procedure Freeze_Expr_Types (Spec_Id : Entity_Id);
+ -- AI12-0103: N is the body associated with an expression function that
+ -- is a completion, and Spec_Id is its defining entity. Freeze before N
+ -- all the types referenced by the expression of the function.
function Is_Private_Concurrent_Primitive
(Subp_Id : Entity_Id) return Boolean;
-- Determine whether subprogram Subp_Id is a primitive of a concurrent
-- type that implements an interface and has a private view.
+ procedure Restore_Limited_Views (Restore_List : Elist_Id);
+ -- Undo the transformation done by Exchange_Limited_Views.
+
procedure Set_Trivial_Subprogram (N : Node_Id);
-- Sets the Is_Trivial_Subprogram flag in both spec and body of the
-- subprogram whose body is being analyzed. N is the statement node
@@ -2272,6 +2345,59 @@ package body Sem_Ch6 is
return False;
end Body_Has_Contract;
+ ----------------------------
+ -- Body_Has_SPARK_Mode_On --
+ ----------------------------
+
+ function Body_Has_SPARK_Mode_On return Boolean is
+ Decls : constant List_Id := Declarations (N);
+ Item : Node_Id;
+
+ begin
+ -- Check for SPARK_Mode aspect
+
+ if Present (Aspect_Specifications (N)) then
+ Item := First (Aspect_Specifications (N));
+ while Present (Item) loop
+ if Get_Aspect_Id (Item) = Aspect_SPARK_Mode then
+ return Get_SPARK_Mode_From_Annotation (Item) = On;
+ end if;
+
+ Next (Item);
+ end loop;
+ end if;
+
+ -- Check for SPARK_Mode pragma
+
+ if Present (Decls) then
+ Item := First (Decls);
+ while Present (Item) loop
+
+ -- Pragmas that apply to a subprogram body are usually grouped
+ -- together. Look for a potential pragma SPARK_Mode among them.
+
+ if Nkind (Item) = N_Pragma then
+ if Get_Pragma_Id (Item) = Pragma_SPARK_Mode then
+ return Get_SPARK_Mode_From_Annotation (Item) = On;
+ end if;
+
+ -- Otherwise the first non-pragma declarative item terminates
+ -- the region where pragma SPARK_Mode may appear.
+
+ else
+ exit;
+ end if;
+
+ Next (Item);
+ end loop;
+ end if;
+
+ -- Otherwise, the applicable SPARK_Mode is inherited from the
+ -- enclosing subprogram or package.
+
+ return SPARK_Mode = On;
+ end Body_Has_SPARK_Mode_On;
+
----------------------------------
-- Build_Subprogram_Declaration --
----------------------------------
@@ -2282,8 +2408,10 @@ package body Sem_Ch6 is
-- of subprogram body From and insert them after node To. The pragmas
-- in question are:
-- Ghost
- -- SPARK_Mode
-- Volatile_Function
+ -- Also copy pragma SPARK_Mode if present in the declarative list
+ -- of subprogram body From and insert it after node To. This pragma
+ -- should not be moved, as it applies to the body too.
------------------
-- Move_Pragmas --
@@ -2308,13 +2436,17 @@ package body Sem_Ch6 is
while Present (Decl) loop
Next_Decl := Next (Decl);
- if Nkind (Decl) = N_Pragma
- and then Nam_In (Pragma_Name (Decl), Name_Ghost,
- Name_SPARK_Mode,
- Name_Volatile_Function)
- then
- Remove (Decl);
- Insert_After (To, Decl);
+ if Nkind (Decl) = N_Pragma then
+ if Pragma_Name_Unmapped (Decl) = Name_SPARK_Mode then
+ Insert_After (To, New_Copy_Tree (Decl));
+
+ elsif Nam_In (Pragma_Name_Unmapped (Decl),
+ Name_Ghost,
+ Name_Volatile_Function)
+ then
+ Remove (Decl);
+ Insert_After (To, Decl);
+ end if;
end if;
Decl := Next_Decl;
@@ -2345,8 +2477,31 @@ package body Sem_Ch6 is
Move_Aspects (N, To => Subp_Decl);
Move_Pragmas (N, To => Subp_Decl);
+ -- Ensure that the generated corresponding spec and original body
+ -- share the same SPARK_Mode pragma or aspect. As a result, both have
+ -- the same SPARK_Mode attributes, and the global SPARK_Mode value is
+ -- correctly set for local subprograms.
+
+ Copy_SPARK_Mode_Aspect (Subp_Decl, To => N);
+
Analyze (Subp_Decl);
+ -- Propagate the attributes Rewritten_For_C and Corresponding_Proc to
+ -- the body since the expander may generate calls using that entity.
+ -- Required to ensure that Expand_Call rewrites calls to this
+ -- function by calls to the built procedure.
+
+ if Modify_Tree_For_C
+ and then Nkind (Body_Spec) = N_Function_Specification
+ and then
+ Rewritten_For_C (Defining_Entity (Specification (Subp_Decl)))
+ then
+ Set_Rewritten_For_C (Defining_Entity (Body_Spec));
+ Set_Corresponding_Procedure (Defining_Entity (Body_Spec),
+ Corresponding_Procedure
+ (Defining_Entity (Specification (Subp_Decl))));
+ end if;
+
-- Analyze any relocated source pragmas or pragmas created for aspect
-- specifications.
@@ -2381,18 +2536,6 @@ package body Sem_Ch6 is
Body_Spec := Copy_Subprogram_Spec (Body_Spec);
Set_Specification (N, Body_Spec);
Body_Id := Analyze_Subprogram_Specification (Body_Spec);
-
- -- Ensure that the generated corresponding spec and original body
- -- share the same Ghost and SPARK_Mode attributes.
-
- Set_Is_Checked_Ghost_Entity
- (Body_Id, Is_Checked_Ghost_Entity (Spec_Id));
- Set_Is_Ignored_Ghost_Entity
- (Body_Id, Is_Ignored_Ghost_Entity (Spec_Id));
-
- Set_SPARK_Pragma (Body_Id, SPARK_Pragma (Spec_Id));
- Set_SPARK_Pragma_Inherited
- (Body_Id, SPARK_Pragma_Inherited (Spec_Id));
end Build_Subprogram_Declaration;
----------------------------
@@ -2492,16 +2635,28 @@ package body Sem_Ch6 is
function Is_Inline_Pragma (N : Node_Id) return Boolean is
begin
- return
- Nkind (N) = N_Pragma
+ if Nkind (N) = N_Pragma
and then
- (Pragma_Name (N) = Name_Inline_Always
- or else (Front_End_Inlining
- and then Pragma_Name (N) = Name_Inline))
- and then
- Chars
- (Expression (First (Pragma_Argument_Associations (N)))) =
- Chars (Body_Id);
+ (Pragma_Name_Unmapped (N) = Name_Inline_Always
+ or else (Pragma_Name_Unmapped (N) = Name_Inline
+ and then
+ (Front_End_Inlining or else Optimization_Level > 0)))
+ and then Present (Pragma_Argument_Associations (N))
+ then
+ declare
+ Pragma_Arg : Node_Id :=
+ Expression (First (Pragma_Argument_Associations (N)));
+ begin
+ if Nkind (Pragma_Arg) = N_Selected_Component then
+ Pragma_Arg := Selector_Name (Pragma_Arg);
+ end if;
+
+ return Chars (Pragma_Arg) = Chars (Body_Id);
+ end;
+
+ else
+ return False;
+ end if;
end Is_Inline_Pragma;
-- Start of processing for Check_Inline_Pragma
@@ -2529,16 +2684,22 @@ package body Sem_Ch6 is
if Present (Prag) then
if Present (Spec_Id) then
- if In_Same_List (N, Unit_Declaration_Node (Spec_Id)) then
+ if Is_List_Member (N)
+ and then Is_List_Member (Unit_Declaration_Node (Spec_Id))
+ and then In_Same_List (N, Unit_Declaration_Node (Spec_Id))
+ then
Analyze (Prag);
end if;
else
- -- Create a subprogram declaration, to make treatment uniform
+ -- Create a subprogram declaration, to make treatment uniform.
+ -- Make the sloc of the subprogram name that of the entity in
+ -- the body, so that style checks find identical strings.
declare
Subp : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Chars (Body_Id));
+ Make_Defining_Identifier
+ (Sloc (Body_Id), Chars (Body_Id));
Decl : constant Node_Id :=
Make_Subprogram_Declaration (Loc,
Specification =>
@@ -2547,12 +2708,23 @@ package body Sem_Ch6 is
begin
Set_Defining_Unit_Name (Specification (Decl), Subp);
+ -- To ensure proper coverage when body is inlined, indicate
+ -- whether the subprogram comes from source.
+
+ Set_Comes_From_Source (Subp, Comes_From_Source (N));
+
if Present (First_Formal (Body_Id)) then
Plist := Copy_Parameter_List (Body_Id);
Set_Parameter_Specifications
(Specification (Decl), Plist);
end if;
+ -- Move aspects to the new spec
+
+ if Has_Aspects (N) then
+ Move_Aspects (N, To => Decl);
+ end if;
+
Insert_Before (N, Decl);
Analyze (Decl);
Analyze (Prag);
@@ -2773,7 +2945,9 @@ package body Sem_Ch6 is
-- Exchange_Limited_Views --
----------------------------
- procedure Exchange_Limited_Views (Subp_Id : Entity_Id) is
+ function Exchange_Limited_Views (Subp_Id : Entity_Id) return Elist_Id is
+ Result : Elist_Id := No_Elist;
+
procedure Detect_And_Exchange (Id : Entity_Id);
-- Determine whether Id's type denotes an incomplete type associated
-- with a limited with clause and exchange the limited view with the
@@ -2793,6 +2967,12 @@ package body Sem_Ch6 is
and then Has_Non_Limited_View (Typ)
and then not From_Limited_With (Scope (Typ))
then
+ if No (Result) then
+ Result := New_Elmt_List;
+ end if;
+
+ Prepend_Elmt (Typ, Result);
+ Prepend_Elmt (Id, Result);
Set_Etype (Id, Non_Limited_View (Typ));
end if;
end Detect_And_Exchange;
@@ -2804,14 +2984,11 @@ package body Sem_Ch6 is
-- Start of processing for Exchange_Limited_Views
begin
- if No (Subp_Id) then
- return;
-
-- Do not process subprogram bodies as they already use the non-
-- limited view of types.
- elsif not Ekind_In (Subp_Id, E_Function, E_Procedure) then
- return;
+ if not Ekind_In (Subp_Id, E_Function, E_Procedure) then
+ return No_Elist;
end if;
-- Examine all formals and swap views when applicable
@@ -2828,8 +3005,147 @@ package body Sem_Ch6 is
if Ekind (Subp_Id) = E_Function then
Detect_And_Exchange (Subp_Id);
end if;
+
+ return Result;
end Exchange_Limited_Views;
+ -----------------------
+ -- Freeze_Expr_Types --
+ -----------------------
+
+ procedure Freeze_Expr_Types (Spec_Id : Entity_Id) is
+ function Cloned_Expression return Node_Id;
+ -- Build a duplicate of the expression of the return statement that
+ -- has no defining entities shared with the original expression.
+
+ function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result;
+ -- Freeze all types referenced in the subtree rooted at Node
+
+ -----------------------
+ -- Cloned_Expression --
+ -----------------------
+
+ function Cloned_Expression return Node_Id is
+ function Clone_Id (Node : Node_Id) return Traverse_Result;
+ -- Tree traversal routine that clones the defining identifier of
+ -- iterator and loop parameter specification nodes.
+
+ ----------------
+ -- Check_Node --
+ ----------------
+
+ function Clone_Id (Node : Node_Id) return Traverse_Result is
+ begin
+ if Nkind_In (Node, N_Iterator_Specification,
+ N_Loop_Parameter_Specification)
+ then
+ Set_Defining_Identifier (Node,
+ New_Copy (Defining_Identifier (Node)));
+ end if;
+
+ return OK;
+ end Clone_Id;
+
+ -------------------
+ -- Clone_Def_Ids --
+ -------------------
+
+ procedure Clone_Def_Ids is new Traverse_Proc (Clone_Id);
+
+ -- Local variables
+
+ Return_Stmt : constant Node_Id :=
+ First
+ (Statements (Handled_Statement_Sequence (N)));
+ Dup_Expr : Node_Id;
+
+ -- Start of processing for Cloned_Expression
+
+ begin
+ pragma Assert (Nkind (Return_Stmt) = N_Simple_Return_Statement);
+
+ -- We must duplicate the expression with semantic information to
+ -- inherit the decoration of global entities in generic instances.
+
+ Dup_Expr := New_Copy_Tree (Expression (Return_Stmt));
+
+ -- Replace the defining identifier of iterators and loop param
+ -- specifications by a clone to ensure that the cloned expression
+ -- and the original expression don't have shared identifiers;
+ -- otherwise, as part of the preanalysis of the expression, these
+ -- shared identifiers may be left decorated with itypes which
+ -- will not be available in the tree passed to the backend.
+
+ Clone_Def_Ids (Dup_Expr);
+
+ return Dup_Expr;
+ end Cloned_Expression;
+
+ ----------------------
+ -- Freeze_Type_Refs --
+ ----------------------
+
+ function Freeze_Type_Refs (Node : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (Node) = N_Identifier
+ and then Present (Entity (Node))
+ then
+ if Is_Type (Entity (Node)) then
+ Freeze_Before (N, Entity (Node));
+
+ elsif Ekind_In (Entity (Node), E_Component,
+ E_Discriminant)
+ then
+ Freeze_Before (N, Scope (Entity (Node)));
+ end if;
+ end if;
+
+ return OK;
+ end Freeze_Type_Refs;
+
+ procedure Freeze_References is new Traverse_Proc (Freeze_Type_Refs);
+
+ -- Local variables
+
+ Saved_First_Entity : constant Entity_Id := First_Entity (Spec_Id);
+ Saved_Last_Entity : constant Entity_Id := Last_Entity (Spec_Id);
+ Dup_Expr : constant Node_Id := Cloned_Expression;
+
+ -- Start of processing for Freeze_Expr_Types
+
+ begin
+ -- Preanalyze a duplicate of the expression to have available the
+ -- minimum decoration needed to locate referenced unfrozen types
+ -- without adding any decoration to the function expression. This
+ -- preanalysis is performed with errors disabled to avoid reporting
+ -- spurious errors on Ghost entities (since the expression is not
+ -- fully analyzed).
+
+ Push_Scope (Spec_Id);
+ Install_Formals (Spec_Id);
+ Ignore_Errors_Enable := Ignore_Errors_Enable + 1;
+
+ Preanalyze_Spec_Expression (Dup_Expr, Etype (Spec_Id));
+
+ Ignore_Errors_Enable := Ignore_Errors_Enable - 1;
+ End_Scope;
+
+ -- Restore certain attributes of Spec_Id since the preanalysis may
+ -- have introduced itypes to this scope, thus modifying attributes
+ -- First_Entity and Last_Entity.
+
+ Set_First_Entity (Spec_Id, Saved_First_Entity);
+ Set_Last_Entity (Spec_Id, Saved_Last_Entity);
+
+ if Present (Last_Entity (Spec_Id)) then
+ Set_Next_Entity (Last_Entity (Spec_Id), Empty);
+ end if;
+
+ -- Freeze all types referenced in the expression
+
+ Freeze_References (Dup_Expr);
+ end Freeze_Expr_Types;
+
-------------------------------------
-- Is_Private_Concurrent_Primitive --
-------------------------------------
@@ -2863,6 +3179,23 @@ package body Sem_Ch6 is
return False;
end Is_Private_Concurrent_Primitive;
+ ---------------------------
+ -- Restore_Limited_Views --
+ ---------------------------
+
+ procedure Restore_Limited_Views (Restore_List : Elist_Id) is
+ Elmt : Elmt_Id := First_Elmt (Restore_List);
+ Id : Entity_Id;
+
+ begin
+ while Present (Elmt) loop
+ Id := Node (Elmt);
+ Next_Elmt (Elmt);
+ Set_Etype (Id, Node (Elmt));
+ Next_Elmt (Elmt);
+ end loop;
+ end Restore_Limited_Views;
+
----------------------------
-- Set_Trivial_Subprogram --
----------------------------
@@ -2972,8 +3305,8 @@ package body Sem_Ch6 is
-- Local variables
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
- Cloned_Body_For_C : Node_Id := Empty;
+ Mode : Ghost_Mode_Type;
+ Mode_Set : Boolean := False;
-- Start of processing for Analyze_Subprogram_Body_Helper
@@ -3025,7 +3358,9 @@ package body Sem_Ch6 is
-- the mode now to ensure that any nodes generated during analysis
-- and expansion are properly marked as Ghost.
- Set_Ghost_Mode (N, Spec_Id);
+ Mark_And_Set_Ghost_Body (N, Spec_Id, Mode);
+ Mode_Set := True;
+
Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
Set_Is_Child_Unit (Body_Id, Is_Child_Unit (Spec_Id));
@@ -3036,15 +3371,13 @@ package body Sem_Ch6 is
Check_Missing_Return;
end if;
- Ghost_Mode := Save_Ghost_Mode;
- return;
+ goto Leave;
- else
- -- Previous entity conflicts with subprogram name. Attempting to
- -- enter name will post error.
+ -- Otherwise a previous entity conflicts with the subprogram name.
+ -- Attempting to enter name will post error.
+ else
Enter_Name (Body_Id);
- Ghost_Mode := Save_Ghost_Mode;
return;
end if;
@@ -3055,7 +3388,6 @@ package body Sem_Ch6 is
-- analysis.
elsif Prev_Id = Body_Id and then Has_Completion (Body_Id) then
- Ghost_Mode := Save_Ghost_Mode;
return;
else
@@ -3072,7 +3404,8 @@ package body Sem_Ch6 is
-- Ghost. Set the mode now to ensure that any nodes generated
-- during analysis and expansion are properly marked as Ghost.
- Set_Ghost_Mode (N, Spec_Id);
+ Mark_And_Set_Ghost_Body (N, Spec_Id, Mode);
+ Mode_Set := True;
else
Spec_Id := Find_Corresponding_Spec (N);
@@ -3082,7 +3415,8 @@ package body Sem_Ch6 is
-- Ghost. Set the mode now to ensure that any nodes generated
-- during analysis and expansion are properly marked as Ghost.
- Set_Ghost_Mode (N, Spec_Id);
+ Mark_And_Set_Ghost_Body (N, Spec_Id, Mode);
+ Mode_Set := True;
-- In GNATprove mode, if the body has no previous spec, create
-- one so that the inlining machinery can operate properly.
@@ -3118,9 +3452,9 @@ package body Sem_Ch6 is
-- modular analysis of the subprogram instead of a contextual
-- analysis at each call site. The same test is performed in
-- Inline.Can_Be_Inlined_In_GNATprove_Mode. It is repeated
- -- here in another form (because the contract has not
- -- been attached to the body) to avoid frontend errors in
- -- case pragmas are used instead of aspects, because the
+ -- here in another form (because the contract has not been
+ -- attached to the body) to avoid front-end errors in case
+ -- pragmas are used instead of aspects, because the
-- corresponding pragmas in the body would not be transferred
-- to the spec, leading to legality errors.
@@ -3146,8 +3480,7 @@ package body Sem_Ch6 is
-- If this is a duplicate body, no point in analyzing it
if Error_Posted (N) then
- Ghost_Mode := Save_Ghost_Mode;
- return;
+ goto Leave;
end if;
-- A subprogram body should cause freezing of its own declaration,
@@ -3184,7 +3517,8 @@ package body Sem_Ch6 is
-- the mode now to ensure that any nodes generated during analysis
-- and expansion are properly marked as Ghost.
- Set_Ghost_Mode (N, Spec_Id);
+ Mark_And_Set_Ghost_Body (N, Spec_Id, Mode);
+ Mode_Set := True;
end if;
end if;
@@ -3210,6 +3544,35 @@ package body Sem_Ch6 is
Spec_Id := Build_Private_Protected_Declaration (N);
end if;
+ -- If we are generating C and this is a function returning a constrained
+ -- array type for which we must create a procedure with an extra out
+ -- parameter, build and analyze the body now. The procedure declaration
+ -- has already been created. We reuse the source body of the function,
+ -- because in an instance it may contain global references that cannot
+ -- be reanalyzed. The source function itself is not used any further,
+ -- so we mark it as having a completion. If the subprogram is a stub the
+ -- transformation is done later, when the proper body is analyzed.
+
+ if Expander_Active
+ and then Modify_Tree_For_C
+ and then Present (Spec_Id)
+ and then Ekind (Spec_Id) = E_Function
+ and then Nkind (N) /= N_Subprogram_Body_Stub
+ and then Rewritten_For_C (Spec_Id)
+ then
+ Set_Has_Completion (Spec_Id);
+
+ Rewrite (N, Build_Procedure_Body_Form (Spec_Id, N));
+ Analyze (N);
+
+ -- The entity for the created procedure must remain invisible, so it
+ -- does not participate in resolution of subsequent references to the
+ -- function.
+
+ Set_Is_Immediately_Visible (Corresponding_Spec (N), False);
+ goto Leave;
+ end if;
+
-- If a separate spec is present, then deal with freezing issues
if Present (Spec_Id) then
@@ -3236,6 +3599,17 @@ package body Sem_Ch6 is
then
Set_Has_Delayed_Freeze (Spec_Id);
Freeze_Before (N, Spec_Id);
+
+ -- AI12-0103: At the occurrence of an expression function
+ -- declaration that is a completion, its expression causes
+ -- freezing.
+
+ if Has_Completion (Spec_Id)
+ and then Nkind (N) = N_Subprogram_Body
+ and then Was_Expression_Function (N)
+ then
+ Freeze_Expr_Types (Spec_Id);
+ end if;
end if;
end if;
@@ -3258,26 +3632,12 @@ package body Sem_Ch6 is
if Is_Abstract_Subprogram (Spec_Id) then
Error_Msg_N ("an abstract subprogram cannot have a body", N);
- Ghost_Mode := Save_Ghost_Mode;
- return;
+ goto Leave;
else
Set_Convention (Body_Id, Convention (Spec_Id));
Set_Has_Completion (Spec_Id);
- -- Inherit the "ghostness" of the subprogram spec. Note that this
- -- property is not directly inherited as the body may be subject
- -- to a different Ghost assertion policy.
-
- if Ghost_Mode > None or else Is_Ghost_Entity (Spec_Id) then
- Set_Is_Ghost_Entity (Body_Id);
-
- -- The Ghost policy in effect at the point of declaration and
- -- at the point of completion must match (SPARK RM 6.9(14)).
-
- Check_Ghost_Completion (Spec_Id, Body_Id);
- end if;
-
if Is_Protected_Type (Scope (Spec_Id)) then
Prot_Typ := Scope (Spec_Id);
end if;
@@ -3301,10 +3661,13 @@ package body Sem_Ch6 is
Conformant := True;
-- Conversely, the spec may have been generated for specless body
- -- with an inline pragma.
+ -- with an inline pragma. The entity comes from source, which is
+ -- both semantically correct and necessary for proper inlining.
+ -- The subprogram declaration itself is not in the source.
elsif Comes_From_Source (N)
- and then not Comes_From_Source (Spec_Id)
+ and then Present (Spec_Decl)
+ and then not Comes_From_Source (Spec_Decl)
and then Has_Pragma_Inline (Spec_Id)
then
Conformant := True;
@@ -3328,8 +3691,7 @@ package body Sem_Ch6 is
if not Conformant
and then not Mode_Conformant (Body_Id, Spec_Id)
then
- Ghost_Mode := Save_Ghost_Mode;
- return;
+ goto Leave;
end if;
end if;
@@ -3440,18 +3802,26 @@ package body Sem_Ch6 is
New_Overloaded_Entity (Body_Id);
- -- A subprogram body declared within a Ghost region is automatically
- -- Ghost (SPARK RM 6.9(2)).
-
- if Ghost_Mode > None then
- Set_Is_Ghost_Entity (Body_Id);
- end if;
-
if Nkind (N) /= N_Subprogram_Body_Stub then
Set_Acts_As_Spec (N);
Generate_Definition (Body_Id);
Generate_Reference
(Body_Id, Body_Id, 'b', Set_Ref => False, Force => True);
+
+ -- If the body is an entry wrapper created for an entry with
+ -- preconditions, it must be compiled in the context of the
+ -- enclosing synchronized object, because it may mention other
+ -- operations of the type.
+
+ if Is_Entry_Wrapper (Body_Id) then
+ declare
+ Prot : constant Entity_Id := Etype (First_Entity (Body_Id));
+ begin
+ Push_Scope (Prot);
+ Install_Declarations (Prot);
+ end;
+ end if;
+
Install_Formals (Body_Id);
Push_Scope (Body_Id);
@@ -3487,12 +3857,12 @@ package body Sem_Ch6 is
-- end P; -- mode is ON
elsif not Comes_From_Source (N)
- and then Present (Prev_Id)
- and then Is_Expression_Function (Prev_Id)
+ and then Present (Spec_Id)
+ and then Is_Expression_Function (Spec_Id)
then
- Set_SPARK_Pragma (Body_Id, SPARK_Pragma (Prev_Id));
+ Set_SPARK_Pragma (Body_Id, SPARK_Pragma (Spec_Id));
Set_SPARK_Pragma_Inherited
- (Body_Id, SPARK_Pragma_Inherited (Prev_Id));
+ (Body_Id, SPARK_Pragma_Inherited (Spec_Id));
-- Set the SPARK_Mode from the current context (may be overwritten later
-- with explicit pragma). Exclude the case where the SPARK_Mode appears
@@ -3505,31 +3875,6 @@ package body Sem_Ch6 is
Set_SPARK_Pragma_Inherited (Body_Id);
end if;
- -- If the return type is an anonymous access type whose designated type
- -- is the limited view of a class-wide type and the non-limited view is
- -- available, update the return type accordingly.
-
- if Ada_Version >= Ada_2005 and then Comes_From_Source (N) then
- declare
- Etyp : Entity_Id;
- Rtyp : Entity_Id;
-
- begin
- Rtyp := Etype (Current_Scope);
-
- if Ekind (Rtyp) = E_Anonymous_Access_Type then
- Etyp := Directly_Designated_Type (Rtyp);
-
- if Is_Class_Wide_Type (Etyp)
- and then From_Limited_With (Etyp)
- then
- Set_Directly_Designated_Type
- (Etype (Current_Scope), Available_View (Etyp));
- end if;
- end if;
- end;
- end if;
-
-- If this is the proper body of a stub, we must verify that the stub
-- conforms to the body, and to the previous spec if one was present.
-- We know already that the body conforms to that spec. This test is
@@ -3579,26 +3924,10 @@ package body Sem_Ch6 is
Analyze_Aspect_Specifications_On_Body_Or_Stub (N);
end if;
- Ghost_Mode := Save_Ghost_Mode;
- return;
- end if;
-
- -- If we are generating C and this is a function returning a constrained
- -- array type for which we must create a procedure with an extra out
- -- parameter then clone the body before it is analyzed. Needed to ensure
- -- that the body of the built procedure does not have any reference to
- -- the body of the function.
-
- if Expander_Active
- and then Modify_Tree_For_C
- and then Present (Spec_Id)
- and then Ekind (Spec_Id) = E_Function
- and then Rewritten_For_C (Spec_Id)
- then
- Cloned_Body_For_C := Copy_Separate_Tree (N);
+ goto Leave;
end if;
- -- Handle frontend inlining
+ -- Handle inlining
-- Note: Normally we don't do any inlining if expansion is off, since
-- we won't generate code in any case. An exception arises in GNATprove
@@ -3611,19 +3940,18 @@ package body Sem_Ch6 is
and then Present (Spec_Id)
and then Has_Pragma_Inline (Spec_Id)
then
- -- Legacy implementation (relying on frontend inlining)
+ -- Legacy implementation (relying on front-end inlining)
if not Back_End_Inlining then
if (Has_Pragma_Inline_Always (Spec_Id)
- and then not Opt.Disable_FE_Inline_Always)
- or else
- (Has_Pragma_Inline (Spec_Id) and then Front_End_Inlining
- and then not Opt.Disable_FE_Inline)
+ and then not Opt.Disable_FE_Inline_Always)
+ or else (Front_End_Inlining
+ and then not Opt.Disable_FE_Inline)
then
Build_Body_To_Inline (N, Spec_Id);
end if;
- -- New implementation (relying on backend inlining)
+ -- New implementation (relying on back-end inlining)
else
if Has_Pragma_Inline_Always (Spec_Id)
@@ -3684,7 +4012,7 @@ package body Sem_Ch6 is
-- In GNATprove mode, inline only when there is a separate subprogram
-- declaration for now, as inlining of subprogram bodies acting as
- -- declarations, or subprogram stubs, are not supported by frontend
+ -- declarations, or subprogram stubs, are not supported by front-end
-- inlining. This inlining should occur after analysis of the body, so
-- that it is known whether the value of SPARK_Mode, which can be
-- defined by a pragma inside the body, is applicable to the body.
@@ -3695,12 +4023,16 @@ package body Sem_Ch6 is
and then Present (Spec_Id)
and then
Nkind (Unit_Declaration_Node (Spec_Id)) = N_Subprogram_Declaration
+ and then Body_Has_SPARK_Mode_On
and then Can_Be_Inlined_In_GNATprove_Mode (Spec_Id, Body_Id)
and then not Body_Has_Contract
then
Build_Body_To_Inline (N, Spec_Id);
end if;
+ -- When generating code, inherited pre/postconditions are handled when
+ -- expanding the corresponding contract.
+
-- Ada 2005 (AI-262): In library subprogram bodies, after the analysis
-- of the specification we have to install the private withed units.
-- This holds for child units as well.
@@ -3769,8 +4101,33 @@ package body Sem_Ch6 is
-- of a subprogram body may use the parameter and result profile of the
-- spec, swap any limited views with their non-limited counterpart.
- if Ada_Version >= Ada_2012 then
- Exchange_Limited_Views (Spec_Id);
+ if Ada_Version >= Ada_2012 and then Present (Spec_Id) then
+ Exch_Views := Exchange_Limited_Views (Spec_Id);
+ end if;
+
+ -- If the return type is an anonymous access type whose designated type
+ -- is the limited view of a class-wide type and the non-limited view is
+ -- available, update the return type accordingly.
+
+ if Ada_Version >= Ada_2005 and then Present (Spec_Id) then
+ declare
+ Etyp : Entity_Id;
+ Rtyp : Entity_Id;
+
+ begin
+ Rtyp := Etype (Spec_Id);
+
+ if Ekind (Rtyp) = E_Anonymous_Access_Type then
+ Etyp := Directly_Designated_Type (Rtyp);
+
+ if Is_Class_Wide_Type (Etyp)
+ and then From_Limited_With (Etyp)
+ then
+ Desig_View := Etyp;
+ Set_Directly_Designated_Type (Rtyp, Available_View (Etyp));
+ end if;
+ end if;
+ end;
end if;
-- Analyze any aspect specifications that appear on the subprogram body
@@ -3785,9 +4142,9 @@ package body Sem_Ch6 is
if Present (Spec_Id) and then Present (SPARK_Pragma (Body_Id)) then
if Present (SPARK_Pragma (Spec_Id)) then
- if Get_SPARK_Mode_From_Pragma (SPARK_Pragma (Spec_Id)) = Off
+ if Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Spec_Id)) = Off
and then
- Get_SPARK_Mode_From_Pragma (SPARK_Pragma (Body_Id)) = On
+ Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Body_Id)) = On
then
Error_Msg_Sloc := Sloc (SPARK_Pragma (Body_Id));
Error_Msg_N ("incorrect application of SPARK_Mode#", N);
@@ -3814,18 +4171,6 @@ package body Sem_Ch6 is
Analyze_Entry_Or_Subprogram_Body_Contract (Body_Id);
- -- If SPARK_Mode for body is not On, disable frontend inlining for this
- -- subprogram in GNATprove mode, as its body should not be analyzed.
-
- if SPARK_Mode /= On
- and then GNATprove_Mode
- and then Present (Spec_Id)
- and then Nkind (Parent (Parent (Spec_Id))) = N_Subprogram_Declaration
- then
- Set_Body_To_Inline (Parent (Parent (Spec_Id)), Empty);
- Set_Is_Inlined_Always (Spec_Id, False);
- end if;
-
-- Check completion, and analyze the statements
Check_Completion;
@@ -3836,6 +4181,14 @@ package body Sem_Ch6 is
Process_End_Label (HSS, 't', Current_Scope);
End_Scope;
+
+ -- If we are compiling an entry wrapper, remove the enclosing
+ -- synchronized object from the stack.
+
+ if Is_Entry_Wrapper (Body_Id) then
+ End_Scope;
+ end if;
+
Check_Subprogram_Order (N);
Set_Analyzed (Body_Id);
@@ -3937,7 +4290,7 @@ package body Sem_Ch6 is
begin
-- Skip initial labels (for one thing this occurs when we are in
- -- front end ZCX mode, but in any case it is irrelevant), and also
+ -- front-end ZCX mode, but in any case it is irrelevant), and also
-- initial Push_xxx_Error_Label nodes, which are also irrelevant.
Stm := First (Statements (HSS));
@@ -3993,7 +4346,8 @@ package body Sem_Ch6 is
-- Check for variables that are never modified
declare
- E1, E2 : Entity_Id;
+ E1 : Entity_Id;
+ E2 : Entity_Id;
begin
-- If there is a separate spec, then transfer Never_Set_In_Source
@@ -4047,17 +4401,21 @@ package body Sem_Ch6 is
end if;
end;
- -- When generating C code, transform a function that returns a
- -- constrained array type into a procedure with an out parameter
- -- that carries the return value.
+ -- Restore the limited views in the spec, if any, to let the back end
+ -- process it without running into circularities.
- if Present (Cloned_Body_For_C) then
- Rewrite (N,
- Build_Procedure_Body_Form (Spec_Id, Cloned_Body_For_C));
- Analyze (N);
+ if Exch_Views /= No_Elist then
+ Restore_Limited_Views (Exch_Views);
end if;
- Ghost_Mode := Save_Ghost_Mode;
+ if Present (Desig_View) then
+ Set_Directly_Designated_Type (Etype (Spec_Id), Desig_View);
+ end if;
+
+ <<Leave>>
+ if Mode_Set then
+ Restore_Ghost_Mode (Mode);
+ end if;
end Analyze_Subprogram_Body_Helper;
------------------------------------
@@ -4119,13 +4477,6 @@ package body Sem_Ch6 is
Set_SPARK_Pragma_Inherited (Designator);
end if;
- -- A subprogram declared within a Ghost region is automatically Ghost
- -- (SPARK RM 6.9(2)).
-
- if Ghost_Mode > None then
- Set_Is_Ghost_Entity (Designator);
- end if;
-
if Debug_Flag_C then
Write_Str ("==> subprogram spec ");
Write_Name (Chars (Designator));
@@ -4292,6 +4643,34 @@ package body Sem_Ch6 is
-- both subprogram bodies and subprogram declarations (specs).
function Analyze_Subprogram_Specification (N : Node_Id) return Entity_Id is
+ function Is_Invariant_Procedure_Or_Body (E : Entity_Id) return Boolean;
+ -- Determine whether entity E denotes the spec or body of an invariant
+ -- procedure.
+
+ ------------------------------------
+ -- Is_Invariant_Procedure_Or_Body --
+ ------------------------------------
+
+ function Is_Invariant_Procedure_Or_Body (E : Entity_Id) return Boolean is
+ Decl : constant Node_Id := Unit_Declaration_Node (E);
+ Spec : Entity_Id;
+
+ begin
+ if Nkind (Decl) = N_Subprogram_Body then
+ Spec := Corresponding_Spec (Decl);
+ else
+ Spec := E;
+ end if;
+
+ return
+ Present (Spec)
+ and then Ekind (Spec) = E_Procedure
+ and then (Is_Partial_Invariant_Procedure (Spec)
+ or else Is_Invariant_Procedure (Spec));
+ end Is_Invariant_Procedure_Or_Body;
+
+ -- Local variables
+
Designator : constant Entity_Id := Defining_Entity (N);
Formals : constant List_Id := Parameter_Specifications (N);
@@ -4351,7 +4730,27 @@ package body Sem_Ch6 is
-- Same processing for an access parameter whose designated type is
-- derived from a synchronized interface.
- if Ada_Version >= Ada_2005 then
+ -- This modification is not done for invariant procedures because
+ -- the corresponding record may not necessarely be visible when the
+ -- concurrent type acts as the full view of a private type.
+
+ -- package Pack is
+ -- type Prot is private with Type_Invariant => ...;
+ -- procedure ConcInvariant (Obj : Prot);
+ -- private
+ -- protected type Prot is ...;
+ -- type Concurrent_Record_Prot is record ...;
+ -- procedure ConcInvariant (Obj : Prot) is
+ -- ...
+ -- end ConcInvariant;
+ -- end Pack;
+
+ -- In the example above, both the spec and body of the invariant
+ -- procedure must utilize the private type as the controlling type.
+
+ if Ada_Version >= Ada_2005
+ and then not Is_Invariant_Procedure_Or_Body (Designator)
+ then
declare
Formal : Entity_Id;
Formal_Typ : Entity_Id;
@@ -4480,6 +4879,12 @@ package body Sem_Ch6 is
-- in the message, and also provides the location for posting the
-- message in the absence of a specified Err_Loc location.
+ function Conventions_Match
+ (Id1 : Entity_Id;
+ Id2 : Entity_Id) return Boolean;
+ -- Determine whether the conventions of arbitrary entities Id1 and Id2
+ -- match.
+
-----------------------
-- Conformance_Error --
-----------------------
@@ -4539,6 +4944,35 @@ package body Sem_Ch6 is
end if;
end Conformance_Error;
+ -----------------------
+ -- Conventions_Match --
+ -----------------------
+
+ function Conventions_Match
+ (Id1 : Entity_Id;
+ Id2 : Entity_Id) return Boolean
+ is
+ begin
+ -- Ignore the conventions of anonymous access-to-subprogram types
+ -- and subprogram types because these are internally generated and
+ -- the only way these may receive a convention is if they inherit
+ -- the convention of a related subprogram.
+
+ if Ekind_In (Id1, E_Anonymous_Access_Subprogram_Type,
+ E_Subprogram_Type)
+ or else
+ Ekind_In (Id2, E_Anonymous_Access_Subprogram_Type,
+ E_Subprogram_Type)
+ then
+ return True;
+
+ -- Otherwise compare the conventions directly
+
+ else
+ return Convention (Id1) = Convention (Id2);
+ end if;
+ end Conventions_Match;
+
-- Local Variables
Old_Type : constant Entity_Id := Etype (Old_Id);
@@ -4625,7 +5059,7 @@ package body Sem_Ch6 is
-- entity is inherited.
if Ctype >= Subtype_Conformant then
- if Convention (Old_Id) /= Convention (New_Id) then
+ if not Conventions_Match (Old_Id, New_Id) then
if not Is_Frozen (New_Id) then
null;
@@ -4649,18 +5083,6 @@ package body Sem_Ch6 is
then
Conformance_Error ("\formal subprograms not allowed!");
return;
-
- -- Pragma Ghost behaves as a convention in the context of subtype
- -- conformance (SPARK RM 6.9(5)). Do not check internally generated
- -- subprograms as their spec may reside in a Ghost region and their
- -- body not, or vice versa.
-
- elsif Comes_From_Source (Old_Id)
- and then Comes_From_Source (New_Id)
- and then Is_Ghost_Entity (Old_Id) /= Is_Ghost_Entity (New_Id)
- then
- Conformance_Error ("\ghost modes do not match!");
- return;
end if;
end if;
@@ -5186,9 +5608,7 @@ package body Sem_Ch6 is
procedure Possible_Freeze (T : Entity_Id);
-- T is the type of either a formal parameter or of the return type.
-- If T is not yet frozen and needs a delayed freeze, then the
- -- subprogram itself must be delayed. If T is the limited view of an
- -- incomplete type the subprogram must be frozen as well, because
- -- T may depend on local types that have not been frozen yet.
+ -- subprogram itself must be delayed.
---------------------
-- Possible_Freeze --
@@ -5204,19 +5624,6 @@ package body Sem_Ch6 is
and then not Is_Frozen (Designated_Type (T))
then
Set_Has_Delayed_Freeze (Designator);
-
- elsif Ekind (T) = E_Incomplete_Type
- and then From_Limited_With (T)
- then
- Set_Has_Delayed_Freeze (Designator);
-
- -- AI05-0151: In Ada 2012, Incomplete types can appear in the profile
- -- of a subprogram or entry declaration.
-
- elsif Ekind (T) = E_Incomplete_Type
- and then Ada_Version >= Ada_2012
- then
- Set_Has_Delayed_Freeze (Designator);
end if;
end Possible_Freeze;
@@ -6356,6 +6763,339 @@ package body Sem_Ch6 is
Get_Inst => Get_Inst);
end Check_Subtype_Conformant;
+ -----------------------------------
+ -- Check_Synchronized_Overriding --
+ -----------------------------------
+
+ procedure Check_Synchronized_Overriding
+ (Def_Id : Entity_Id;
+ Overridden_Subp : out Entity_Id)
+ is
+ Ifaces_List : Elist_Id;
+ In_Scope : Boolean;
+ Typ : Entity_Id;
+
+ function Matches_Prefixed_View_Profile
+ (Prim_Params : List_Id;
+ Iface_Params : List_Id) return Boolean;
+ -- Determine whether a subprogram's parameter profile Prim_Params
+ -- matches that of a potentially overridden interface subprogram
+ -- Iface_Params. Also determine if the type of first parameter of
+ -- Iface_Params is an implemented interface.
+
+ -----------------------------------
+ -- Matches_Prefixed_View_Profile --
+ -----------------------------------
+
+ function Matches_Prefixed_View_Profile
+ (Prim_Params : List_Id;
+ Iface_Params : List_Id) return Boolean
+ is
+ function Is_Implemented
+ (Ifaces_List : Elist_Id;
+ Iface : Entity_Id) return Boolean;
+ -- Determine if Iface is implemented by the current task or
+ -- protected type.
+
+ --------------------
+ -- Is_Implemented --
+ --------------------
+
+ function Is_Implemented
+ (Ifaces_List : Elist_Id;
+ Iface : Entity_Id) return Boolean
+ is
+ Iface_Elmt : Elmt_Id;
+
+ begin
+ Iface_Elmt := First_Elmt (Ifaces_List);
+ while Present (Iface_Elmt) loop
+ if Node (Iface_Elmt) = Iface then
+ return True;
+ end if;
+
+ Next_Elmt (Iface_Elmt);
+ end loop;
+
+ return False;
+ end Is_Implemented;
+
+ -- Local variables
+
+ Iface_Id : Entity_Id;
+ Iface_Param : Node_Id;
+ Iface_Typ : Entity_Id;
+ Prim_Id : Entity_Id;
+ Prim_Param : Node_Id;
+ Prim_Typ : Entity_Id;
+
+ -- Start of processing for Matches_Prefixed_View_Profile
+
+ begin
+ Iface_Param := First (Iface_Params);
+ Iface_Typ := Etype (Defining_Identifier (Iface_Param));
+
+ if Is_Access_Type (Iface_Typ) then
+ Iface_Typ := Designated_Type (Iface_Typ);
+ end if;
+
+ Prim_Param := First (Prim_Params);
+
+ -- The first parameter of the potentially overridden subprogram must
+ -- be an interface implemented by Prim.
+
+ if not Is_Interface (Iface_Typ)
+ or else not Is_Implemented (Ifaces_List, Iface_Typ)
+ then
+ return False;
+ end if;
+
+ -- The checks on the object parameters are done, so move on to the
+ -- rest of the parameters.
+
+ if not In_Scope then
+ Prim_Param := Next (Prim_Param);
+ end if;
+
+ Iface_Param := Next (Iface_Param);
+ while Present (Iface_Param) and then Present (Prim_Param) loop
+ Iface_Id := Defining_Identifier (Iface_Param);
+ Iface_Typ := Find_Parameter_Type (Iface_Param);
+
+ Prim_Id := Defining_Identifier (Prim_Param);
+ Prim_Typ := Find_Parameter_Type (Prim_Param);
+
+ if Ekind (Iface_Typ) = E_Anonymous_Access_Type
+ and then Ekind (Prim_Typ) = E_Anonymous_Access_Type
+ and then Is_Concurrent_Type (Designated_Type (Prim_Typ))
+ then
+ Iface_Typ := Designated_Type (Iface_Typ);
+ Prim_Typ := Designated_Type (Prim_Typ);
+ end if;
+
+ -- Case of multiple interface types inside a parameter profile
+
+ -- (Obj_Param : in out Iface; ...; Param : Iface)
+
+ -- If the interface type is implemented, then the matching type in
+ -- the primitive should be the implementing record type.
+
+ if Ekind (Iface_Typ) = E_Record_Type
+ and then Is_Interface (Iface_Typ)
+ and then Is_Implemented (Ifaces_List, Iface_Typ)
+ then
+ if Prim_Typ /= Typ then
+ return False;
+ end if;
+
+ -- The two parameters must be both mode and subtype conformant
+
+ elsif Ekind (Iface_Id) /= Ekind (Prim_Id)
+ or else not
+ Conforming_Types (Iface_Typ, Prim_Typ, Subtype_Conformant)
+ then
+ return False;
+ end if;
+
+ Next (Iface_Param);
+ Next (Prim_Param);
+ end loop;
+
+ -- One of the two lists contains more parameters than the other
+
+ if Present (Iface_Param) or else Present (Prim_Param) then
+ return False;
+ end if;
+
+ return True;
+ end Matches_Prefixed_View_Profile;
+
+ -- Start of processing for Check_Synchronized_Overriding
+
+ begin
+ Overridden_Subp := Empty;
+
+ -- Def_Id must be an entry or a subprogram. We should skip predefined
+ -- primitives internally generated by the front end; however at this
+ -- stage predefined primitives are still not fully decorated. As a
+ -- minor optimization we skip here internally generated subprograms.
+
+ if (Ekind (Def_Id) /= E_Entry
+ and then Ekind (Def_Id) /= E_Function
+ and then Ekind (Def_Id) /= E_Procedure)
+ or else not Comes_From_Source (Def_Id)
+ then
+ return;
+ end if;
+
+ -- Search for the concurrent declaration since it contains the list of
+ -- all implemented interfaces. In this case, the subprogram is declared
+ -- within the scope of a protected or a task type.
+
+ if Present (Scope (Def_Id))
+ and then Is_Concurrent_Type (Scope (Def_Id))
+ and then not Is_Generic_Actual_Type (Scope (Def_Id))
+ then
+ Typ := Scope (Def_Id);
+ In_Scope := True;
+
+ -- The enclosing scope is not a synchronized type and the subprogram
+ -- has no formals.
+
+ elsif No (First_Formal (Def_Id)) then
+ return;
+
+ -- The subprogram has formals and hence it may be a primitive of a
+ -- concurrent type.
+
+ else
+ Typ := Etype (First_Formal (Def_Id));
+
+ if Is_Access_Type (Typ) then
+ Typ := Directly_Designated_Type (Typ);
+ end if;
+
+ if Is_Concurrent_Type (Typ)
+ and then not Is_Generic_Actual_Type (Typ)
+ then
+ In_Scope := False;
+
+ -- This case occurs when the concurrent type is declared within a
+ -- generic unit. As a result the corresponding record has been built
+ -- and used as the type of the first formal, we just have to retrieve
+ -- the corresponding concurrent type.
+
+ elsif Is_Concurrent_Record_Type (Typ)
+ and then not Is_Class_Wide_Type (Typ)
+ and then Present (Corresponding_Concurrent_Type (Typ))
+ then
+ Typ := Corresponding_Concurrent_Type (Typ);
+ In_Scope := False;
+
+ else
+ return;
+ end if;
+ end if;
+
+ -- There is no overriding to check if this is an inherited operation in
+ -- a type derivation for a generic actual.
+
+ Collect_Interfaces (Typ, Ifaces_List);
+
+ if Is_Empty_Elmt_List (Ifaces_List) then
+ return;
+ end if;
+
+ -- Determine whether entry or subprogram Def_Id overrides a primitive
+ -- operation that belongs to one of the interfaces in Ifaces_List.
+
+ declare
+ Candidate : Entity_Id := Empty;
+ Hom : Entity_Id := Empty;
+ Subp : Entity_Id := Empty;
+
+ begin
+ -- Traverse the homonym chain, looking for a potentially overridden
+ -- subprogram that belongs to an implemented interface.
+
+ Hom := Current_Entity_In_Scope (Def_Id);
+ while Present (Hom) loop
+ Subp := Hom;
+
+ if Subp = Def_Id
+ or else not Is_Overloadable (Subp)
+ or else not Is_Primitive (Subp)
+ or else not Is_Dispatching_Operation (Subp)
+ or else not Present (Find_Dispatching_Type (Subp))
+ or else not Is_Interface (Find_Dispatching_Type (Subp))
+ then
+ null;
+
+ -- Entries and procedures can override abstract or null interface
+ -- procedures.
+
+ elsif Ekind_In (Def_Id, E_Entry, E_Procedure)
+ and then Ekind (Subp) = E_Procedure
+ and then Matches_Prefixed_View_Profile
+ (Parameter_Specifications (Parent (Def_Id)),
+ Parameter_Specifications (Parent (Subp)))
+ then
+ Candidate := Subp;
+
+ -- For an overridden subprogram Subp, check whether the mode
+ -- of its first parameter is correct depending on the kind of
+ -- synchronized type.
+
+ declare
+ Formal : constant Node_Id := First_Formal (Candidate);
+
+ begin
+ -- In order for an entry or a protected procedure to
+ -- override, the first parameter of the overridden routine
+ -- must be of mode "out", "in out", or access-to-variable.
+
+ if Ekind_In (Candidate, E_Entry, E_Procedure)
+ and then Is_Protected_Type (Typ)
+ and then Ekind (Formal) /= E_In_Out_Parameter
+ and then Ekind (Formal) /= E_Out_Parameter
+ and then Nkind (Parameter_Type (Parent (Formal))) /=
+ N_Access_Definition
+ then
+ null;
+
+ -- All other cases are OK since a task entry or routine does
+ -- not have a restriction on the mode of the first parameter
+ -- of the overridden interface routine.
+
+ else
+ Overridden_Subp := Candidate;
+ return;
+ end if;
+ end;
+
+ -- Functions can override abstract interface functions
+
+ elsif Ekind (Def_Id) = E_Function
+ and then Ekind (Subp) = E_Function
+ and then Matches_Prefixed_View_Profile
+ (Parameter_Specifications (Parent (Def_Id)),
+ Parameter_Specifications (Parent (Subp)))
+ and then Etype (Def_Id) = Etype (Subp)
+ then
+ Candidate := Subp;
+
+ -- If an inherited subprogram is implemented by a protected
+ -- function, then the first parameter of the inherited
+ -- subprogram shall be of mode in, but not an access-to-
+ -- variable parameter (RM 9.4(11/9)).
+
+ if Present (First_Formal (Subp))
+ and then Ekind (First_Formal (Subp)) = E_In_Parameter
+ and then
+ (not Is_Access_Type (Etype (First_Formal (Subp)))
+ or else
+ Is_Access_Constant (Etype (First_Formal (Subp))))
+ then
+ Overridden_Subp := Subp;
+ return;
+ end if;
+ end if;
+
+ Hom := Homonym (Hom);
+ end loop;
+
+ -- After examining all candidates for overriding, we are left with
+ -- the best match, which is a mode-incompatible interface routine.
+
+ if In_Scope and then Present (Candidate) then
+ Error_Msg_PT (Def_Id, Candidate);
+ end if;
+
+ Overridden_Subp := Candidate;
+ return;
+ end;
+ end Check_Synchronized_Overriding;
+
---------------------------
-- Check_Type_Conformant --
---------------------------
@@ -6405,45 +7145,48 @@ package body Sem_Ch6 is
Ctype : Conformance_Type;
Get_Inst : Boolean := False) return Boolean
is
- Type_1 : Entity_Id := T1;
- Type_2 : Entity_Id := T2;
- Are_Anonymous_Access_To_Subprogram_Types : Boolean := False;
-
- function Base_Types_Match (T1, T2 : Entity_Id) return Boolean;
- -- If neither T1 nor T2 are generic actual types, or if they are in
- -- different scopes (e.g. parent and child instances), then verify that
- -- the base types are equal. Otherwise T1 and T2 must be on the same
- -- subtype chain. The whole purpose of this procedure is to prevent
- -- spurious ambiguities in an instantiation that may arise if two
- -- distinct generic types are instantiated with the same actual.
-
- function Find_Designated_Type (T : Entity_Id) return Entity_Id;
+ function Base_Types_Match
+ (Typ_1 : Entity_Id;
+ Typ_2 : Entity_Id) return Boolean;
+ -- If neither Typ_1 nor Typ_2 are generic actual types, or if they are
+ -- in different scopes (e.g. parent and child instances), then verify
+ -- that the base types are equal. Otherwise Typ_1 and Typ_2 must be on
+ -- the same subtype chain. The whole purpose of this procedure is to
+ -- prevent spurious ambiguities in an instantiation that may arise if
+ -- two distinct generic types are instantiated with the same actual.
+
+ function Find_Designated_Type (Typ : Entity_Id) return Entity_Id;
-- An access parameter can designate an incomplete type. If the
-- incomplete type is the limited view of a type from a limited_
- -- with_clause, check whether the non-limited view is available. If
- -- it is a (non-limited) incomplete type, get the full view.
-
- function Matches_Limited_With_View (T1, T2 : Entity_Id) return Boolean;
- -- Returns True if and only if either T1 denotes a limited view of T2
- -- or T2 denotes a limited view of T1. This can arise when the limited
- -- with view of a type is used in a subprogram declaration and the
- -- subprogram body is in the scope of a regular with clause for the
- -- same unit. In such a case, the two type entities can be considered
+ -- with_clause, check whether the non-limited view is available.
+ -- If it is a (non-limited) incomplete type, get the full view.
+
+ function Matches_Limited_With_View
+ (Typ_1 : Entity_Id;
+ Typ_2 : Entity_Id) return Boolean;
+ -- Returns True if and only if either Typ_1 denotes a limited view of
+ -- Typ_2 or Typ_2 denotes a limited view of Typ_1. This can arise when
+ -- the limited with view of a type is used in a subprogram declaration
+ -- and the subprogram body is in the scope of a regular with clause for
+ -- the same unit. In such a case, the two type entities are considered
-- identical for purposes of conformance checking.
----------------------
-- Base_Types_Match --
----------------------
- function Base_Types_Match (T1, T2 : Entity_Id) return Boolean is
- BT1 : constant Entity_Id := Base_Type (T1);
- BT2 : constant Entity_Id := Base_Type (T2);
+ function Base_Types_Match
+ (Typ_1 : Entity_Id;
+ Typ_2 : Entity_Id) return Boolean
+ is
+ Base_1 : constant Entity_Id := Base_Type (Typ_1);
+ Base_2 : constant Entity_Id := Base_Type (Typ_2);
begin
- if T1 = T2 then
+ if Typ_1 = Typ_2 then
return True;
- elsif BT1 = BT2 then
+ elsif Base_1 = Base_2 then
-- The following is too permissive. A more precise test should
-- check that the generic actual is an ancestor subtype of the
@@ -6452,18 +7195,23 @@ package body Sem_Ch6 is
-- See code in Find_Corresponding_Spec that applies an additional
-- filter to handle accidental amiguities in instances.
- return not Is_Generic_Actual_Type (T1)
- or else not Is_Generic_Actual_Type (T2)
- or else Scope (T1) /= Scope (T2);
+ return
+ not Is_Generic_Actual_Type (Typ_1)
+ or else not Is_Generic_Actual_Type (Typ_2)
+ or else Scope (Typ_1) /= Scope (Typ_2);
- -- If T2 is a generic actual type it is declared as the subtype of
+ -- If Typ_2 is a generic actual type it is declared as the subtype of
-- the actual. If that actual is itself a subtype we need to use its
-- own base type to check for compatibility.
- elsif Ekind (BT2) = Ekind (T2) and then BT1 = Base_Type (BT2) then
+ elsif Ekind (Base_2) = Ekind (Typ_2)
+ and then Base_1 = Base_Type (Base_2)
+ then
return True;
- elsif Ekind (BT1) = Ekind (T1) and then BT2 = Base_Type (BT1) then
+ elsif Ekind (Base_1) = Ekind (Typ_1)
+ and then Base_2 = Base_Type (Base_1)
+ then
return True;
else
@@ -6475,11 +7223,11 @@ package body Sem_Ch6 is
-- Find_Designated_Type --
--------------------------
- function Find_Designated_Type (T : Entity_Id) return Entity_Id is
+ function Find_Designated_Type (Typ : Entity_Id) return Entity_Id is
Desig : Entity_Id;
begin
- Desig := Directly_Designated_Type (T);
+ Desig := Directly_Designated_Type (Typ);
if Ekind (Desig) = E_Incomplete_Type then
@@ -6503,39 +7251,115 @@ package body Sem_Ch6 is
-- Matches_Limited_With_View --
-------------------------------
- function Matches_Limited_With_View (T1, T2 : Entity_Id) return Boolean is
+ function Matches_Limited_With_View
+ (Typ_1 : Entity_Id;
+ Typ_2 : Entity_Id) return Boolean
+ is
+ function Is_Matching_Limited_View
+ (Typ : Entity_Id;
+ View : Entity_Id) return Boolean;
+ -- Determine whether non-limited view View denotes type Typ in some
+ -- conformant fashion.
+
+ ------------------------------
+ -- Is_Matching_Limited_View --
+ ------------------------------
+
+ function Is_Matching_Limited_View
+ (Typ : Entity_Id;
+ View : Entity_Id) return Boolean
+ is
+ Root_Typ : Entity_Id;
+ Root_View : Entity_Id;
+
+ begin
+ -- The non-limited view directly denotes the type
+
+ if Typ = View then
+ return True;
+
+ -- The type is a subtype of the non-limited view
+
+ elsif Is_Subtype_Of (Typ, View) then
+ return True;
+
+ -- Both the non-limited view and the type denote class-wide types
+
+ elsif Is_Class_Wide_Type (Typ)
+ and then Is_Class_Wide_Type (View)
+ then
+ Root_Typ := Root_Type (Typ);
+ Root_View := Root_Type (View);
+
+ if Root_Typ = Root_View then
+ return True;
+
+ -- An incomplete tagged type and its full view may receive two
+ -- distinct class-wide types when the related package has not
+ -- been analyzed yet.
+
+ -- package Pack is
+ -- type T is tagged; -- CW_1
+ -- type T is tagged null record; -- CW_2
+ -- end Pack;
+
+ -- This is because the package lacks any semantic information
+ -- that may eventually link both views of T. As a consequence,
+ -- a client of the limited view of Pack will see CW_2 while a
+ -- client of the non-limited view of Pack will see CW_1.
+
+ elsif Is_Incomplete_Type (Root_Typ)
+ and then Present (Full_View (Root_Typ))
+ and then Full_View (Root_Typ) = Root_View
+ then
+ return True;
+
+ elsif Is_Incomplete_Type (Root_View)
+ and then Present (Full_View (Root_View))
+ and then Full_View (Root_View) = Root_Typ
+ then
+ return True;
+ end if;
+ end if;
+
+ return False;
+ end Is_Matching_Limited_View;
+
+ -- Start of processing for Matches_Limited_With_View
+
begin
-- In some cases a type imported through a limited_with clause, and
- -- its nonlimited view are both visible, for example in an anonymous
+ -- its non-limited view are both visible, for example in an anonymous
-- access-to-class-wide type in a formal, or when building the body
-- for a subprogram renaming after the subprogram has been frozen.
- -- In these cases Both entities designate the same type. In addition,
+ -- In these cases both entities designate the same type. In addition,
-- if one of them is an actual in an instance, it may be a subtype of
-- the non-limited view of the other.
- if From_Limited_With (T1)
- and then (T2 = Available_View (T1)
- or else Is_Subtype_Of (T2, Available_View (T1)))
+ if From_Limited_With (Typ_1)
+ and then From_Limited_With (Typ_2)
+ and then Available_View (Typ_1) = Available_View (Typ_2)
then
return True;
- elsif From_Limited_With (T2)
- and then (T1 = Available_View (T2)
- or else Is_Subtype_Of (T1, Available_View (T2)))
- then
- return True;
+ elsif From_Limited_With (Typ_1) then
+ return Is_Matching_Limited_View (Typ_2, Available_View (Typ_1));
- elsif From_Limited_With (T1)
- and then From_Limited_With (T2)
- and then Available_View (T1) = Available_View (T2)
- then
- return True;
+ elsif From_Limited_With (Typ_2) then
+ return Is_Matching_Limited_View (Typ_1, Available_View (Typ_2));
else
return False;
end if;
end Matches_Limited_With_View;
+ -- Local variables
+
+ Are_Anonymous_Access_To_Subprogram_Types : Boolean := False;
+
+ Type_1 : Entity_Id := T1;
+ Type_2 : Entity_Id := T2;
+
-- Start of processing for Conforming_Types
begin
@@ -6580,6 +7404,15 @@ package body Sem_Ch6 is
return Ctype <= Mode_Conformant
or else Subtypes_Statically_Match (Type_1, Full_View (Type_2));
+ -- Another confusion between views in a nested instance with an
+ -- actual private type whose full view is not in scope.
+
+ elsif Ekind (Type_2) = E_Private_Subtype
+ and then In_Instance
+ and then Etype (Type_2) = Type_1
+ then
+ return True;
+
-- In Ada 2012, incomplete types (including limited views) can appear
-- as actuals in instantiations.
@@ -6719,11 +7552,9 @@ package body Sem_Ch6 is
--------------------------
procedure Create_Extra_Formals (E : Entity_Id) is
- Formal : Entity_Id;
First_Extra : Entity_Id := Empty;
- Last_Extra : Entity_Id;
- Formal_Type : Entity_Id;
- P_Formal : Entity_Id := Empty;
+ Formal : Entity_Id;
+ Last_Extra : Entity_Id := Empty;
function Add_Extra_Formal
(Assoc_Entity : Entity_Id;
@@ -6789,6 +7620,11 @@ package body Sem_Ch6 is
return EF;
end Add_Extra_Formal;
+ -- Local variables
+
+ Formal_Type : Entity_Id;
+ P_Formal : Entity_Id := Empty;
+
-- Start of processing for Create_Extra_Formals
begin
@@ -6814,7 +7650,6 @@ package body Sem_Ch6 is
P_Formal := First_Formal (Alias (E));
end if;
- Last_Extra := Empty;
Formal := First_Formal (E);
while Present (Formal) loop
Last_Extra := Formal;
@@ -6960,6 +7795,7 @@ package body Sem_Ch6 is
Result_Subt : constant Entity_Id := Etype (E);
Full_Subt : constant Entity_Id := Available_View (Result_Subt);
Formal_Typ : Entity_Id;
+ Subp_Decl : Node_Id;
Discard : Entity_Id;
pragma Warnings (Off, Discard);
@@ -7042,6 +7878,26 @@ package body Sem_Ch6 is
Layout_Type (Formal_Typ);
+ -- Force the definition of the Itype in case of internal function
+ -- calls within the same or nested scope.
+
+ if Is_Subprogram_Or_Generic_Subprogram (E) then
+ Subp_Decl := Parent (E);
+
+ -- The insertion point for an Itype reference should be after
+ -- the unit declaration node of the subprogram. An exception
+ -- to this are inherited operations from a parent type in which
+ -- case the derived type acts as their parent.
+
+ if Nkind_In (Subp_Decl, N_Function_Specification,
+ N_Procedure_Specification)
+ then
+ Subp_Decl := Parent (Subp_Decl);
+ end if;
+
+ Build_Itype_Reference (Formal_Typ, Subp_Decl);
+ end if;
+
Discard :=
Add_Extra_Formal
(E, Formal_Typ, E, BIP_Formal_Suffix (BIP_Object_Access));
@@ -7054,9 +7910,133 @@ package body Sem_Ch6 is
-----------------------------
procedure Enter_Overloaded_Entity (S : Entity_Id) is
+ function Matches_Predefined_Op return Boolean;
+ -- This returns an approximation of whether S matches a predefined
+ -- operator, based on the operator symbol, and the parameter and result
+ -- types. The rules are scattered throughout chapter 4 of the Ada RM.
+
+ ---------------------------
+ -- Matches_Predefined_Op --
+ ---------------------------
+
+ function Matches_Predefined_Op return Boolean is
+ Formal_1 : constant Entity_Id := First_Formal (S);
+ Formal_2 : constant Entity_Id := Next_Formal (Formal_1);
+ Op : constant Name_Id := Chars (S);
+ Result_Type : constant Entity_Id := Base_Type (Etype (S));
+ Type_1 : constant Entity_Id := Base_Type (Etype (Formal_1));
+
+ begin
+ -- Binary operator
+
+ if Present (Formal_2) then
+ declare
+ Type_2 : constant Entity_Id := Base_Type (Etype (Formal_2));
+
+ begin
+ -- All but "&" and "**" have same-types parameters
+
+ case Op is
+ when Name_Op_Concat
+ | Name_Op_Expon
+ =>
+ null;
+
+ when others =>
+ if Type_1 /= Type_2 then
+ return False;
+ end if;
+ end case;
+
+ -- Check parameter and result types
+
+ case Op is
+ when Name_Op_And
+ | Name_Op_Or
+ | Name_Op_Xor
+ =>
+ return
+ Is_Boolean_Type (Result_Type)
+ and then Result_Type = Type_1;
+
+ when Name_Op_Mod
+ | Name_Op_Rem
+ =>
+ return
+ Is_Integer_Type (Result_Type)
+ and then Result_Type = Type_1;
+
+ when Name_Op_Add
+ | Name_Op_Divide
+ | Name_Op_Multiply
+ | Name_Op_Subtract
+ =>
+ return
+ Is_Numeric_Type (Result_Type)
+ and then Result_Type = Type_1;
+
+ when Name_Op_Eq
+ | Name_Op_Ne
+ =>
+ return
+ Is_Boolean_Type (Result_Type)
+ and then not Is_Limited_Type (Type_1);
+
+ when Name_Op_Ge
+ | Name_Op_Gt
+ | Name_Op_Le
+ | Name_Op_Lt
+ =>
+ return
+ Is_Boolean_Type (Result_Type)
+ and then (Is_Array_Type (Type_1)
+ or else Is_Scalar_Type (Type_1));
+
+ when Name_Op_Concat =>
+ return Is_Array_Type (Result_Type);
+
+ when Name_Op_Expon =>
+ return
+ (Is_Integer_Type (Result_Type)
+ or else Is_Floating_Point_Type (Result_Type))
+ and then Result_Type = Type_1
+ and then Type_2 = Standard_Integer;
+
+ when others =>
+ raise Program_Error;
+ end case;
+ end;
+
+ -- Unary operator
+
+ else
+ case Op is
+ when Name_Op_Abs
+ | Name_Op_Add
+ | Name_Op_Subtract
+ =>
+ return
+ Is_Numeric_Type (Result_Type)
+ and then Result_Type = Type_1;
+
+ when Name_Op_Not =>
+ return
+ Is_Boolean_Type (Result_Type)
+ and then Result_Type = Type_1;
+
+ when others =>
+ raise Program_Error;
+ end case;
+ end if;
+ end Matches_Predefined_Op;
+
+ -- Local variables
+
E : Entity_Id := Current_Entity_In_Scope (S);
C_E : Entity_Id := Current_Entity (S);
+ -- Start of processing for Enter_Overloaded_Entity
+
begin
if Present (E) then
Set_Has_Homonym (E);
@@ -7127,22 +8107,26 @@ package body Sem_Ch6 is
-- or S is overriding an implicit inherited subprogram.
if Scope (E) /= Scope (S)
- and then (not Is_Overloadable (E)
- or else Subtype_Conformant (E, S))
- and then (Is_Immediately_Visible (E)
- or else
- Is_Potentially_Use_Visible (S))
+ and then (not Is_Overloadable (E)
+ or else Subtype_Conformant (E, S))
+ and then (Is_Immediately_Visible (E)
+ or else Is_Potentially_Use_Visible (S))
then
- if Scope (E) /= Standard_Standard then
+ if Scope (E) = Standard_Standard then
+ if Nkind (S) = N_Defining_Operator_Symbol
+ and then Scope (Base_Type (Etype (First_Formal (S)))) /=
+ Scope (S)
+ and then Matches_Predefined_Op
+ then
+ Error_Msg_N
+ ("declaration of & hides predefined operator?h?", S);
+ end if;
+
+ -- E not immediately within Standard
+
+ else
Error_Msg_Sloc := Sloc (E);
Error_Msg_N ("declaration of & hides one #?h?", S);
-
- elsif Nkind (S) = N_Defining_Operator_Symbol
- and then
- Scope (Base_Type (Etype (First_Formal (S)))) /= Scope (S)
- then
- Error_Msg_N
- ("declaration of & hides predefined operator?h?", S);
end if;
end if;
end loop;
@@ -7416,10 +8400,6 @@ package body Sem_Ch6 is
Set_Convention (Designator, Convention (E));
- if Is_Ghost_Entity (E) then
- Set_Is_Ghost_Entity (Designator);
- end if;
-
-- Skip past subprogram bodies and subprogram renamings that
-- may appear to have a matching spec, but that aren't fully
-- conformant with it. That can occur in cases where an
@@ -7682,7 +8662,7 @@ package body Sem_Ch6 is
-- Start of processing for Fully_Conformant_Expressions
begin
- -- Non-conformant if paren count does not match. Note: if some idiot
+ -- Nonconformant if paren count does not match. Note: if some idiot
-- complains that we don't do this right for more than 3 levels of
-- parentheses, they will be treated with the respect they deserve.
@@ -7695,9 +8675,21 @@ package body Sem_Ch6 is
elsif Is_Entity_Name (E1) and then Is_Entity_Name (E2) then
if Present (Entity (E1)) then
return Entity (E1) = Entity (E2)
+
+ -- One may be a discriminant that has been replaced by
+ -- the corresponding discriminal.
+
or else (Chars (Entity (E1)) = Chars (Entity (E2))
and then Ekind (Entity (E1)) = E_Discriminant
- and then Ekind (Entity (E2)) = E_In_Parameter);
+ and then Ekind (Entity (E2)) = E_In_Parameter)
+
+ -- AI12-050: The loop variables of quantified expressions
+ -- match if they have the same identifier, even though they
+ -- are different entities.
+
+ or else (Chars (Entity (E1)) = Chars (Entity (E2))
+ and then Ekind (Entity (E1)) = E_Loop_Parameter
+ and then Ekind (Entity (E2)) = E_Loop_Parameter);
elsif Nkind (E1) = N_Expanded_Name
and then Nkind (E2) = N_Expanded_Name
@@ -7742,7 +8734,6 @@ package body Sem_Ch6 is
else
case Nkind (E1) is
-
when N_Aggregate =>
return
FCL (Expressions (E1), Expressions (E2))
@@ -7812,7 +8803,9 @@ package body Sem_Ch6 is
and then FCE (Left_Opnd (E1), Left_Opnd (E2))
and then FCE (Right_Opnd (E1), Right_Opnd (E2));
- when N_Short_Circuit | N_Membership_Test =>
+ when N_Membership_Test
+ | N_Short_Circuit
+ =>
return
FCE (Left_Opnd (E1), Left_Opnd (E2))
and then
@@ -8039,7 +9032,6 @@ package body Sem_Ch6 is
when others =>
return True;
-
end case;
end if;
end Fully_Conformant_Expressions;
@@ -8382,6 +9374,7 @@ package body Sem_Ch6 is
-- tested.
Formal := First_Formal (Prev_E);
+ F_Typ := Empty;
while Present (Formal) loop
F_Typ := Base_Type (Etype (Formal));
@@ -8395,6 +9388,8 @@ package body Sem_Ch6 is
Next_Formal (Formal);
end loop;
+ -- If the function dispatches on result check the result type
+
if No (G_Typ) and then Ekind (Prev_E) = E_Function then
G_Typ := Get_Generic_Parent_Type (Base_Type (Etype (Prev_E)));
end if;
@@ -8473,7 +9468,7 @@ package body Sem_Ch6 is
-- private part of the instance. Emit a warning now, which will
-- make the subsequent error message easier to understand.
- if not Is_Abstract_Type (F_Typ)
+ if Present (F_Typ) and then not Is_Abstract_Type (F_Typ)
and then Is_Abstract_Subprogram (Prev_E)
and then In_Private_Part (Current_Scope)
then
@@ -8688,14 +9683,14 @@ package body Sem_Ch6 is
-- type, and set Is_Primitive to True (otherwise set to False). Set the
-- corresponding flag on the entity itself for later use.
- procedure Check_Synchronized_Overriding
- (Def_Id : Entity_Id;
- Overridden_Subp : out Entity_Id);
- -- First determine if Def_Id is an entry or a subprogram either defined
- -- in the scope of a task or protected type, or is a primitive of such
- -- a type. Check whether Def_Id overrides a subprogram of an interface
- -- implemented by the synchronized type, return the overridden entity
- -- or Empty.
+ function Has_Matching_Entry_Or_Subprogram (E : Entity_Id) return Boolean;
+ -- True if a) E is a subprogram whose first formal is a concurrent type
+ -- defined in the scope of E that has some entry or subprogram whose
+ -- profile matches E, or b) E is an internally built dispatching
+ -- subprogram of a protected type and there is a matching subprogram
+ -- defined in the enclosing scope of the protected type, or c) E is
+ -- an entry of a synchronized type and a matching procedure has been
+ -- previously defined in the enclosing scope of the synchronized type.
function Is_Private_Declaration (E : Entity_Id) return Boolean;
-- Check that E is declared in the private part of the current package,
@@ -8713,6 +9708,9 @@ package body Sem_Ch6 is
-- function is conservative given that the converse is only true within
-- instances that contain accidental overloadings.
+ procedure Report_Conflict (S : Entity_Id; E : Entity_Id);
+ -- Report conflict between entities S and E
+
------------------------------------
-- Check_For_Primitive_Subprogram --
------------------------------------
@@ -8962,6 +9960,12 @@ package body Sem_Ch6 is
Set_Has_Primitive_Operations (B_Typ);
Set_Is_Primitive (S);
Check_Private_Overriding (B_Typ);
+
+ -- The Ghost policy in effect at the point of declaration
+ -- or a tagged type and a primitive operation must match
+ -- (SPARK RM 6.9(16)).
+
+ Check_Ghost_Primitive (S, B_Typ);
end if;
end if;
@@ -8989,6 +9993,12 @@ package body Sem_Ch6 is
Set_Is_Primitive (S);
Set_Has_Primitive_Operations (B_Typ);
Check_Private_Overriding (B_Typ);
+
+ -- The Ghost policy in effect at the point of declaration
+ -- of a tagged type and a primitive operation must match
+ -- (SPARK RM 6.9(16)).
+
+ Check_Ghost_Primitive (S, B_Typ);
end if;
Next_Formal (Formal);
@@ -9016,352 +10026,277 @@ package body Sem_Ch6 is
Set_Is_Primitive (S);
Set_Has_Primitive_Operations (B_Typ);
Check_Private_Overriding (B_Typ);
+
+ -- The Ghost policy in effect at the point of declaration of a
+ -- tagged type and a primitive operation must match
+ -- (SPARK RM 6.9(16)).
+
+ Check_Ghost_Primitive (S, B_Typ);
end if;
end if;
end Check_For_Primitive_Subprogram;
- -----------------------------------
- -- Check_Synchronized_Overriding --
- -----------------------------------
+ --------------------------------------
+ -- Has_Matching_Entry_Or_Subprogram --
+ --------------------------------------
- procedure Check_Synchronized_Overriding
- (Def_Id : Entity_Id;
- Overridden_Subp : out Entity_Id)
+ function Has_Matching_Entry_Or_Subprogram
+ (E : Entity_Id) return Boolean
is
- Ifaces_List : Elist_Id;
- In_Scope : Boolean;
- Typ : Entity_Id;
-
- function Matches_Prefixed_View_Profile
- (Prim_Params : List_Id;
- Iface_Params : List_Id) return Boolean;
- -- Determine whether a subprogram's parameter profile Prim_Params
- -- matches that of a potentially overridden interface subprogram
- -- Iface_Params. Also determine if the type of first parameter of
- -- Iface_Params is an implemented interface.
-
- -----------------------------------
- -- Matches_Prefixed_View_Profile --
- -----------------------------------
-
- function Matches_Prefixed_View_Profile
- (Prim_Params : List_Id;
- Iface_Params : List_Id) return Boolean
+ function Check_Conforming_Parameters
+ (E1_Param : Node_Id;
+ E2_Param : Node_Id) return Boolean;
+ -- Starting from the given parameters, check that all the parameters
+ -- of two entries or subprograms are subtype conformant. Used to skip
+ -- the check on the controlling argument.
+
+ function Matching_Entry_Or_Subprogram
+ (Conc_Typ : Entity_Id;
+ Subp : Entity_Id) return Entity_Id;
+ -- Return the first entry or subprogram of the given concurrent type
+ -- whose name matches the name of Subp and has a profile conformant
+ -- with Subp; return Empty if not found.
+
+ function Matching_Dispatching_Subprogram
+ (Conc_Typ : Entity_Id;
+ Ent : Entity_Id) return Entity_Id;
+ -- Return the first dispatching primitive of Conc_Type defined in the
+ -- enclosing scope of Conc_Type (i.e. before the full definition of
+ -- this concurrent type) whose name matches the entry Ent and has a
+ -- profile conformant with the profile of the corresponding (not yet
+ -- built) dispatching primitive of Ent; return Empty if not found.
+
+ function Matching_Original_Protected_Subprogram
+ (Prot_Typ : Entity_Id;
+ Subp : Entity_Id) return Entity_Id;
+ -- Return the first subprogram defined in the enclosing scope of
+ -- Prot_Typ (before the full definition of this protected type)
+ -- whose name matches the original name of Subp and has a profile
+ -- conformant with the profile of Subp; return Empty if not found.
+
+ ---------------------------------
+ -- Check_Confirming_Parameters --
+ ---------------------------------
+
+ function Check_Conforming_Parameters
+ (E1_Param : Node_Id;
+ E2_Param : Node_Id) return Boolean
is
- Iface_Id : Entity_Id;
- Iface_Param : Node_Id;
- Iface_Typ : Entity_Id;
- Prim_Id : Entity_Id;
- Prim_Param : Node_Id;
- Prim_Typ : Entity_Id;
-
- function Is_Implemented
- (Ifaces_List : Elist_Id;
- Iface : Entity_Id) return Boolean;
- -- Determine if Iface is implemented by the current task or
- -- protected type.
-
- --------------------
- -- Is_Implemented --
- --------------------
-
- function Is_Implemented
- (Ifaces_List : Elist_Id;
- Iface : Entity_Id) return Boolean
- is
- Iface_Elmt : Elmt_Id;
-
- begin
- Iface_Elmt := First_Elmt (Ifaces_List);
- while Present (Iface_Elmt) loop
- if Node (Iface_Elmt) = Iface then
- return True;
- end if;
-
- Next_Elmt (Iface_Elmt);
- end loop;
-
- return False;
- end Is_Implemented;
-
- -- Start of processing for Matches_Prefixed_View_Profile
+ Param_E1 : Node_Id := E1_Param;
+ Param_E2 : Node_Id := E2_Param;
begin
- Iface_Param := First (Iface_Params);
- Iface_Typ := Etype (Defining_Identifier (Iface_Param));
-
- if Is_Access_Type (Iface_Typ) then
- Iface_Typ := Designated_Type (Iface_Typ);
- end if;
-
- Prim_Param := First (Prim_Params);
-
- -- The first parameter of the potentially overridden subprogram
- -- must be an interface implemented by Prim.
-
- if not Is_Interface (Iface_Typ)
- or else not Is_Implemented (Ifaces_List, Iface_Typ)
- then
- return False;
- end if;
-
- -- The checks on the object parameters are done, move onto the
- -- rest of the parameters.
-
- if not In_Scope then
- Prim_Param := Next (Prim_Param);
- end if;
-
- Iface_Param := Next (Iface_Param);
- while Present (Iface_Param) and then Present (Prim_Param) loop
- Iface_Id := Defining_Identifier (Iface_Param);
- Iface_Typ := Find_Parameter_Type (Iface_Param);
-
- Prim_Id := Defining_Identifier (Prim_Param);
- Prim_Typ := Find_Parameter_Type (Prim_Param);
-
- if Ekind (Iface_Typ) = E_Anonymous_Access_Type
- and then Ekind (Prim_Typ) = E_Anonymous_Access_Type
- and then Is_Concurrent_Type (Designated_Type (Prim_Typ))
- then
- Iface_Typ := Designated_Type (Iface_Typ);
- Prim_Typ := Designated_Type (Prim_Typ);
- end if;
-
- -- Case of multiple interface types inside a parameter profile
-
- -- (Obj_Param : in out Iface; ...; Param : Iface)
-
- -- If the interface type is implemented, then the matching type
- -- in the primitive should be the implementing record type.
-
- if Ekind (Iface_Typ) = E_Record_Type
- and then Is_Interface (Iface_Typ)
- and then Is_Implemented (Ifaces_List, Iface_Typ)
- then
- if Prim_Typ /= Typ then
- return False;
- end if;
-
- -- The two parameters must be both mode and subtype conformant
-
- elsif Ekind (Iface_Id) /= Ekind (Prim_Id)
+ while Present (Param_E1) and then Present (Param_E2) loop
+ if Ekind (Defining_Identifier (Param_E1)) /=
+ Ekind (Defining_Identifier (Param_E2))
or else not
- Conforming_Types (Iface_Typ, Prim_Typ, Subtype_Conformant)
+ Conforming_Types
+ (Find_Parameter_Type (Param_E1),
+ Find_Parameter_Type (Param_E2),
+ Subtype_Conformant)
then
return False;
end if;
- Next (Iface_Param);
- Next (Prim_Param);
+ Next (Param_E1);
+ Next (Param_E2);
end loop;
- -- One of the two lists contains more parameters than the other
-
- if Present (Iface_Param) or else Present (Prim_Param) then
- return False;
- end if;
-
- return True;
- end Matches_Prefixed_View_Profile;
-
- -- Start of processing for Check_Synchronized_Overriding
-
- begin
- Overridden_Subp := Empty;
+ -- The candidate is not valid if one of the two lists contains
+ -- more parameters than the other
- -- Def_Id must be an entry or a subprogram. We should skip predefined
- -- primitives internally generated by the frontend; however at this
- -- stage predefined primitives are still not fully decorated. As a
- -- minor optimization we skip here internally generated subprograms.
+ return No (Param_E1) and then No (Param_E2);
+ end Check_Conforming_Parameters;
- if (Ekind (Def_Id) /= E_Entry
- and then Ekind (Def_Id) /= E_Function
- and then Ekind (Def_Id) /= E_Procedure)
- or else not Comes_From_Source (Def_Id)
- then
- return;
- end if;
+ ----------------------------------
+ -- Matching_Entry_Or_Subprogram --
+ ----------------------------------
- -- Search for the concurrent declaration since it contains the list
- -- of all implemented interfaces. In this case, the subprogram is
- -- declared within the scope of a protected or a task type.
-
- if Present (Scope (Def_Id))
- and then Is_Concurrent_Type (Scope (Def_Id))
- and then not Is_Generic_Actual_Type (Scope (Def_Id))
- then
- Typ := Scope (Def_Id);
- In_Scope := True;
-
- -- The enclosing scope is not a synchronized type and the subprogram
- -- has no formals.
-
- elsif No (First_Formal (Def_Id)) then
- return;
+ function Matching_Entry_Or_Subprogram
+ (Conc_Typ : Entity_Id;
+ Subp : Entity_Id) return Entity_Id
+ is
+ E : Entity_Id;
- -- The subprogram has formals and hence it may be a primitive of a
- -- concurrent type.
+ begin
+ E := First_Entity (Conc_Typ);
+ while Present (E) loop
+ if Chars (Subp) = Chars (E)
+ and then (Ekind (E) = E_Entry or else Is_Subprogram (E))
+ and then
+ Check_Conforming_Parameters
+ (First (Parameter_Specifications (Parent (E))),
+ Next (First (Parameter_Specifications (Parent (Subp)))))
+ then
+ return E;
+ end if;
- else
- Typ := Etype (First_Formal (Def_Id));
+ Next_Entity (E);
+ end loop;
- if Is_Access_Type (Typ) then
- Typ := Directly_Designated_Type (Typ);
- end if;
+ return Empty;
+ end Matching_Entry_Or_Subprogram;
- if Is_Concurrent_Type (Typ)
- and then not Is_Generic_Actual_Type (Typ)
- then
- In_Scope := False;
+ -------------------------------------
+ -- Matching_Dispatching_Subprogram --
+ -------------------------------------
- -- This case occurs when the concurrent type is declared within
- -- a generic unit. As a result the corresponding record has been
- -- built and used as the type of the first formal, we just have
- -- to retrieve the corresponding concurrent type.
+ function Matching_Dispatching_Subprogram
+ (Conc_Typ : Entity_Id;
+ Ent : Entity_Id) return Entity_Id
+ is
+ E : Entity_Id;
- elsif Is_Concurrent_Record_Type (Typ)
- and then not Is_Class_Wide_Type (Typ)
- and then Present (Corresponding_Concurrent_Type (Typ))
- then
- Typ := Corresponding_Concurrent_Type (Typ);
- In_Scope := False;
+ begin
+ -- Search for entities in the enclosing scope of this synchonized
+ -- type.
- else
- return;
- end if;
- end if;
+ pragma Assert (Is_Concurrent_Type (Conc_Typ));
+ Push_Scope (Scope (Conc_Typ));
+ E := Current_Entity_In_Scope (Ent);
+ Pop_Scope;
- -- There is no overriding to check if is an inherited operation in a
- -- type derivation on for a generic actual.
+ while Present (E) loop
+ if Scope (E) = Scope (Conc_Typ)
+ and then Comes_From_Source (E)
+ and then Ekind (E) = E_Procedure
+ and then Present (First_Entity (E))
+ and then Is_Controlling_Formal (First_Entity (E))
+ and then Etype (First_Entity (E)) = Conc_Typ
+ and then
+ Check_Conforming_Parameters
+ (First (Parameter_Specifications (Parent (Ent))),
+ Next (First (Parameter_Specifications (Parent (E)))))
+ then
+ return E;
+ end if;
- Collect_Interfaces (Typ, Ifaces_List);
+ E := Homonym (E);
+ end loop;
- if Is_Empty_Elmt_List (Ifaces_List) then
- return;
- end if;
+ return Empty;
+ end Matching_Dispatching_Subprogram;
- -- Determine whether entry or subprogram Def_Id overrides a primitive
- -- operation that belongs to one of the interfaces in Ifaces_List.
+ --------------------------------------------
+ -- Matching_Original_Protected_Subprogram --
+ --------------------------------------------
- declare
- Candidate : Entity_Id := Empty;
- Hom : Entity_Id := Empty;
- Subp : Entity_Id := Empty;
+ function Matching_Original_Protected_Subprogram
+ (Prot_Typ : Entity_Id;
+ Subp : Entity_Id) return Entity_Id
+ is
+ ICF : constant Boolean :=
+ Is_Controlling_Formal (First_Entity (Subp));
+ E : Entity_Id;
begin
- -- Traverse the homonym chain, looking for a potentially
- -- overridden subprogram that belongs to an implemented
- -- interface.
-
- Hom := Current_Entity_In_Scope (Def_Id);
- while Present (Hom) loop
- Subp := Hom;
-
- if Subp = Def_Id
- or else not Is_Overloadable (Subp)
- or else not Is_Primitive (Subp)
- or else not Is_Dispatching_Operation (Subp)
- or else not Present (Find_Dispatching_Type (Subp))
- or else not Is_Interface (Find_Dispatching_Type (Subp))
- then
- null;
-
- -- Entries and procedures can override abstract or null
- -- interface procedures.
+ -- Temporarily decorate the first parameter of Subp as controlling
+ -- formal, required to invoke Subtype_Conformant.
- elsif (Ekind (Def_Id) = E_Procedure
- or else Ekind (Def_Id) = E_Entry)
- and then Ekind (Subp) = E_Procedure
- and then Matches_Prefixed_View_Profile
- (Parameter_Specifications (Parent (Def_Id)),
- Parameter_Specifications (Parent (Subp)))
- then
- Candidate := Subp;
+ Set_Is_Controlling_Formal (First_Entity (Subp));
- -- For an overridden subprogram Subp, check whether the mode
- -- of its first parameter is correct depending on the kind
- -- of synchronized type.
+ E :=
+ Current_Entity_In_Scope (Original_Protected_Subprogram (Subp));
- declare
- Formal : constant Node_Id := First_Formal (Candidate);
-
- begin
- -- In order for an entry or a protected procedure to
- -- override, the first parameter of the overridden
- -- routine must be of mode "out", "in out" or
- -- access-to-variable.
-
- if Ekind_In (Candidate, E_Entry, E_Procedure)
- and then Is_Protected_Type (Typ)
- and then Ekind (Formal) /= E_In_Out_Parameter
- and then Ekind (Formal) /= E_Out_Parameter
- and then Nkind (Parameter_Type (Parent (Formal))) /=
- N_Access_Definition
- then
- null;
+ while Present (E) loop
+ if Scope (E) = Scope (Prot_Typ)
+ and then Comes_From_Source (E)
+ and then Ekind (Subp) = Ekind (E)
+ and then Present (First_Entity (E))
+ and then Is_Controlling_Formal (First_Entity (E))
+ and then Etype (First_Entity (E)) = Prot_Typ
+ and then Subtype_Conformant (Subp, E,
+ Skip_Controlling_Formals => True)
+ then
+ Set_Is_Controlling_Formal (First_Entity (Subp), ICF);
+ return E;
+ end if;
- -- All other cases are OK since a task entry or routine
- -- does not have a restriction on the mode of the first
- -- parameter of the overridden interface routine.
+ E := Homonym (E);
+ end loop;
- else
- Overridden_Subp := Candidate;
- return;
- end if;
- end;
+ Set_Is_Controlling_Formal (First_Entity (Subp), ICF);
- -- Functions can override abstract interface functions
+ return Empty;
+ end Matching_Original_Protected_Subprogram;
- elsif Ekind (Def_Id) = E_Function
- and then Ekind (Subp) = E_Function
- and then Matches_Prefixed_View_Profile
- (Parameter_Specifications (Parent (Def_Id)),
- Parameter_Specifications (Parent (Subp)))
- and then Etype (Result_Definition (Parent (Def_Id))) =
- Etype (Result_Definition (Parent (Subp)))
- then
- Candidate := Subp;
+ -- Start of processing for Has_Matching_Entry_Or_Subprogram
- -- If an inherited subprogram is implemented by a protected
- -- function, then the first parameter of the inherited
- -- subprogram shall be of mode in, but not an
- -- access-to-variable parameter (RM 9.4(11/9)
+ begin
+ -- Case 1: E is a subprogram whose first formal is a concurrent type
+ -- defined in the scope of E that has an entry or subprogram whose
+ -- profile matches E.
+
+ if Comes_From_Source (E)
+ and then Is_Subprogram (E)
+ and then Present (First_Entity (E))
+ and then Is_Concurrent_Record_Type (Etype (First_Entity (E)))
+ then
+ if Scope (E) =
+ Scope (Corresponding_Concurrent_Type
+ (Etype (First_Entity (E))))
+ and then
+ Present
+ (Matching_Entry_Or_Subprogram
+ (Corresponding_Concurrent_Type (Etype (First_Entity (E))),
+ Subp => E))
+ then
+ Report_Conflict (E,
+ Matching_Entry_Or_Subprogram
+ (Corresponding_Concurrent_Type (Etype (First_Entity (E))),
+ Subp => E));
+ return True;
+ end if;
- if Present (First_Formal (Subp))
- and then Ekind (First_Formal (Subp)) = E_In_Parameter
- and then
- (not Is_Access_Type (Etype (First_Formal (Subp)))
- or else
- Is_Access_Constant (Etype (First_Formal (Subp))))
- then
- Overridden_Subp := Subp;
- return;
- end if;
- end if;
+ -- Case 2: E is an internally built dispatching subprogram of a
+ -- protected type and there is a subprogram defined in the enclosing
+ -- scope of the protected type that has the original name of E and
+ -- its profile is conformant with the profile of E. We check the
+ -- name of the original protected subprogram associated with E since
+ -- the expander builds dispatching primitives of protected functions
+ -- and procedures with other names (see Exp_Ch9.Build_Selected_Name).
- Hom := Homonym (Hom);
- end loop;
+ elsif not Comes_From_Source (E)
+ and then Is_Subprogram (E)
+ and then Present (First_Entity (E))
+ and then Is_Concurrent_Record_Type (Etype (First_Entity (E)))
+ and then Present (Original_Protected_Subprogram (E))
+ and then
+ Present
+ (Matching_Original_Protected_Subprogram
+ (Corresponding_Concurrent_Type (Etype (First_Entity (E))),
+ Subp => E))
+ then
+ Report_Conflict (E,
+ Matching_Original_Protected_Subprogram
+ (Corresponding_Concurrent_Type (Etype (First_Entity (E))),
+ Subp => E));
+ return True;
- -- After examining all candidates for overriding, we are left with
- -- the best match which is a mode incompatible interface routine.
+ -- Case 3: E is an entry of a synchronized type and a matching
+ -- procedure has been previously defined in the enclosing scope
+ -- of the synchronized type.
- if In_Scope and then Present (Candidate) then
- Error_Msg_PT (Def_Id, Candidate);
- end if;
+ elsif Comes_From_Source (E)
+ and then Ekind (E) = E_Entry
+ and then
+ Present (Matching_Dispatching_Subprogram (Current_Scope, E))
+ then
+ Report_Conflict (E,
+ Matching_Dispatching_Subprogram (Current_Scope, E));
+ return True;
+ end if;
- Overridden_Subp := Candidate;
- return;
- end;
- end Check_Synchronized_Overriding;
+ return False;
+ end Has_Matching_Entry_Or_Subprogram;
----------------------------
-- Is_Private_Declaration --
----------------------------
function Is_Private_Declaration (E : Entity_Id) return Boolean is
- Priv_Decls : List_Id;
Decl : constant Node_Id := Unit_Declaration_Node (E);
+ Priv_Decls : List_Id;
begin
if Is_Package_Or_Generic_Package (Current_Scope)
@@ -9395,6 +10330,7 @@ package body Sem_Ch6 is
is
AO : constant Entity_Id := Alias (Old_E);
AN : constant Entity_Id := Alias (New_E);
+
begin
return Scope (AO) /= Scope (AN)
or else No (DTC_Entity (AO))
@@ -9402,6 +10338,24 @@ package body Sem_Ch6 is
or else DT_Position (AO) = DT_Position (AN);
end Is_Overriding_Alias;
+ ---------------------
+ -- Report_Conflict --
+ ---------------------
+
+ procedure Report_Conflict (S : Entity_Id; E : Entity_Id) is
+ begin
+ Error_Msg_Sloc := Sloc (E);
+
+ -- Generate message, with useful additional warning if in generic
+
+ if Is_Generic_Unit (E) then
+ Error_Msg_N ("previous generic unit cannot be overloaded", S);
+ Error_Msg_N ("\& conflicts with declaration#", S);
+ else
+ Error_Msg_N ("& conflicts with declaration#", S);
+ end if;
+ end Report_Conflict;
+
-- Start of processing for New_Overloaded_Entity
begin
@@ -9458,6 +10412,15 @@ package body Sem_Ch6 is
return;
end if;
+ -- For synchronized types check conflicts of this entity with previously
+ -- defined entities.
+
+ if Ada_Version >= Ada_2005
+ and then Has_Matching_Entry_Or_Subprogram (S)
+ then
+ return;
+ end if;
+
-- If there is no homonym then this is definitely not overriding
if No (E) then
@@ -9534,17 +10497,7 @@ package body Sem_Ch6 is
return;
else
- Error_Msg_Sloc := Sloc (E);
-
- -- Generate message, with useful additional warning if in generic
-
- if Is_Generic_Unit (E) then
- Error_Msg_N ("previous generic unit cannot be overloaded", S);
- Error_Msg_N ("\& conflicts with declaration#", S);
- else
- Error_Msg_N ("& conflicts with declaration#", S);
- end if;
-
+ Report_Conflict (S, E);
return;
end if;
@@ -10136,9 +11089,7 @@ package body Sem_Ch6 is
-- it is still the case that untagged incomplete types cannot
-- be Taft-amendment types and must be completed in private
-- part, so the subprogram must appear in the list of private
- -- dependents of the type. If the type is class-wide, it is
- -- not a primitive, but the freezing of the subprogram must
- -- also be delayed to force the creation of a freeze node.
+ -- dependents of the type.
if Is_Tagged_Type (Formal_Type)
or else (Ada_Version >= Ada_2012
@@ -10147,19 +11098,14 @@ package body Sem_Ch6 is
then
if Ekind (Scope (Current_Scope)) = E_Package
and then not Is_Generic_Type (Formal_Type)
+ and then not Is_Class_Wide_Type (Formal_Type)
then
if not Nkind_In
- (Parent (T), N_Access_Function_Definition,
- N_Access_Procedure_Definition)
+ (Parent (T), N_Access_Function_Definition,
+ N_Access_Procedure_Definition)
then
- -- A limited view has no private dependents
-
- if not Is_Class_Wide_Type (Formal_Type)
- and then not From_Limited_With (Formal_Type)
- then
- Append_Elmt (Current_Scope,
- Private_Dependents (Base_Type (Formal_Type)));
- end if;
+ Append_Elmt (Current_Scope,
+ Private_Dependents (Base_Type (Formal_Type)));
-- Freezing is delayed to ensure that Register_Prim
-- will get called for this operation, which is needed
@@ -10392,7 +11338,7 @@ package body Sem_Ch6 is
-- A procedure cannot have an effectively volatile formal
-- parameter of mode IN because it behaves as a constant
- -- (SPARK RM 7.1.3(6)).
+ -- (SPARK RM 7.1.3(6)). -- ??? maybe 7.1.3(4)
elsif Ekind (Scope (Formal)) = E_Procedure
and then Ekind (Formal) = E_In_Parameter
@@ -10413,19 +11359,6 @@ package body Sem_Ch6 is
if Nkind (Related_Nod) = N_Function_Specification then
Analyze_Return_Type (Related_Nod);
-
- -- If return type is class-wide, subprogram freezing may be
- -- delayed as well, unless the declaration is a compilation unit
- -- in which case the freeze node would appear too late.
-
- if Is_Class_Wide_Type (Etype (Current_Scope))
- and then not Is_Thunk (Current_Scope)
- and then not Is_Compilation_Unit (Current_Scope)
- and then Nkind (Unit_Declaration_Node (Current_Scope)) =
- N_Subprogram_Declaration
- then
- Set_Has_Delayed_Freeze (Current_Scope);
- end if;
end if;
-- Now set the kind (mode) of each formal
@@ -10475,24 +11408,28 @@ package body Sem_Ch6 is
-- Force call by reference if aliased
- if Is_Aliased (Formal) then
- Set_Mechanism (Formal, By_Reference);
+ declare
+ Conv : constant Convention_Id := Convention (Etype (Formal));
+ begin
+ if Is_Aliased (Formal) then
+ Set_Mechanism (Formal, By_Reference);
- -- Warn if user asked this to be passed by copy
+ -- Warn if user asked this to be passed by copy
- if Convention (Formal_Type) = Convention_Ada_Pass_By_Copy then
- Error_Msg_N
- ("cannot pass aliased parameter & by copy??", Formal);
- end if;
+ if Conv = Convention_Ada_Pass_By_Copy then
+ Error_Msg_N
+ ("cannot pass aliased parameter & by copy??", Formal);
+ end if;
- -- Force mechanism if type has Convention Ada_Pass_By_Ref/Copy
+ -- Force mechanism if type has Convention Ada_Pass_By_Ref/Copy
- elsif Convention (Formal_Type) = Convention_Ada_Pass_By_Copy then
- Set_Mechanism (Formal, By_Copy);
+ elsif Conv = Convention_Ada_Pass_By_Copy then
+ Set_Mechanism (Formal, By_Copy);
- elsif Convention (Formal_Type) = Convention_Ada_Pass_By_Reference then
- Set_Mechanism (Formal, By_Reference);
- end if;
+ elsif Conv = Convention_Ada_Pass_By_Reference then
+ Set_Mechanism (Formal, By_Reference);
+ end if;
+ end;
<<Next_Parameter>>
Next (Param_Spec);
@@ -10554,6 +11491,16 @@ package body Sem_Ch6 is
return;
end if;
+ -- The subtype declarations may freeze the formals. The body generated
+ -- for an expression function is not a freeze point, so do not emit
+ -- these declarations (small loss of efficiency in rare cases).
+
+ if Nkind (N) = N_Subprogram_Body
+ and then Was_Expression_Function (N)
+ then
+ return;
+ end if;
+
Formal := First_Formal (Subp);
while Present (Formal) loop
T := Etype (Formal);
@@ -10572,9 +11519,12 @@ package body Sem_Ch6 is
-- At this stage we have an unconstrained type that may need an
-- actual subtype. For sure the actual subtype is needed if we have
- -- an unconstrained array type.
+ -- an unconstrained array type. However, in an instance, the type
+ -- may appear as a subtype of the full view, while the actual is
+ -- in fact private (in which case no actual subtype is needed) so
+ -- check the kind of the base type.
- elsif Is_Array_Type (T) then
+ elsif Is_Array_Type (Base_Type (T)) then
AS_Needed := True;
-- The only other case needing an actual subtype is an unconstrained
@@ -10586,7 +11536,7 @@ package body Sem_Ch6 is
-- Discriminants" in Einfo.
-- We also exclude the case of Discrim_SO_Functions (functions used
- -- in front end layout mode for size/offset values), since in such
+ -- in front-end layout mode for size/offset values), since in such
-- functions only discriminants are referenced, and not only are such
-- subtypes not needed, but they cannot always be generated, because
-- of order of elaboration issues.
@@ -10645,6 +11595,7 @@ package body Sem_Ch6 is
-- therefore needs no constraint checks.
Analyze (Decl, Suppress => All_Checks);
+ Set_Is_Actual_Subtype (Defining_Identifier (Decl));
-- We need to freeze manually the generated type when it is
-- inserted anywhere else than in a declarative part.
@@ -10654,9 +11605,10 @@ package body Sem_Ch6 is
Freeze_Entity (Defining_Identifier (Decl), N));
-- Ditto if the type has a dynamic predicate, because the
- -- generated function will mention the actual subtype.
+ -- generated function will mention the actual subtype. The
+ -- predicate may come from an explicit aspect of be inherited.
- elsif Has_Dynamic_Predicate_Aspect (T) then
+ elsif Has_Predicates (T) then
Insert_List_Before_And_Analyze (Decl,
Freeze_Entity (Defining_Identifier (Decl), N));
end if;
diff --git a/gcc/ada/sem_ch6.ads b/gcc/ada/sem_ch6.ads
index ff24ed83ac..c5d9b3ee25 100644
--- a/gcc/ada/sem_ch6.ads
+++ b/gcc/ada/sem_ch6.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -122,6 +122,15 @@ package Sem_Ch6 is
-- formal access-to-subprogram type, indicating that mapping of types
-- is needed.
+ procedure Check_Synchronized_Overriding
+ (Def_Id : Entity_Id;
+ Overridden_Subp : out Entity_Id);
+ -- First determine if Def_Id is an entry or a subprogram either defined in
+ -- the scope of a task or protected type, or that is a primitive of such
+ -- a type. Check whether Def_Id overrides a subprogram of an interface
+ -- implemented by the synchronized type, returning the overridden entity
+ -- or Empty.
+
procedure Check_Type_Conformant
(New_Id : Entity_Id;
Old_Id : Entity_Id;
diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb
index e182771aef..c400fa80ff 100644
--- a/gcc/ada/sem_ch7.adb
+++ b/gcc/ada/sem_ch7.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -38,6 +38,7 @@ with Errout; use Errout;
with Exp_Disp; use Exp_Disp;
with Exp_Dist; use Exp_Dist;
with Exp_Dbug; use Exp_Dbug;
+with Freeze; use Freeze;
with Ghost; use Ghost;
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
@@ -47,6 +48,7 @@ with Nlists; use Nlists;
with Opt; use Opt;
with Output; use Output;
with Restrict; use Restrict;
+with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
@@ -140,11 +142,13 @@ package body Sem_Ch7 is
-- tightened further???
function Requires_Completion_In_Body
- (Id : Entity_Id;
- Pack_Id : Entity_Id) return Boolean;
+ (Id : Entity_Id;
+ Pack_Id : Entity_Id;
+ Do_Abstract_States : Boolean := False) return Boolean;
-- Subsidiary to routines Unit_Requires_Body and Unit_Requires_Body_Info.
-- Determine whether entity Id declared in package spec Pack_Id requires
- -- completion in a package body.
+ -- completion in a package body. Flag Do_Abstract_Stats should be set when
+ -- abstract states are to be considered in the completion test.
procedure Unit_Requires_Body_Info (Pack_Id : Entity_Id);
-- Outputs info messages showing why package Pack_Id requires a body. The
@@ -187,6 +191,10 @@ package body Sem_Ch7 is
-- Analyze_Package_Body_Helper --
---------------------------------
+ -- WARNING: This routine manages Ghost regions. Return statements must be
+ -- replaced by gotos which jump to the end of the routine and restore the
+ -- Ghost mode.
+
procedure Analyze_Package_Body_Helper (N : Node_Id) is
procedure Hide_Public_Entities (Decls : List_Id);
-- Attempt to hide all public entities found in declarative list Decls
@@ -206,9 +214,9 @@ package body Sem_Ch7 is
--------------------------
procedure Hide_Public_Entities (Decls : List_Id) is
- function Contains_Subp_Or_Const_Refs (N : Node_Id) return Boolean;
+ function Contains_Subprograms_Refs (N : Node_Id) return Boolean;
-- Subsidiary to routine Has_Referencer. Determine whether a node
- -- contains a reference to a subprogram or a non-static constant.
+ -- contains a reference to a subprogram.
-- WARNING: this is a very expensive routine as it performs a full
-- tree traversal.
@@ -221,23 +229,21 @@ package body Sem_Ch7 is
-- in the range Last (Decls) .. Referencer are hidden from external
-- visibility.
- ---------------------------------
- -- Contains_Subp_Or_Const_Refs --
- ---------------------------------
+ -------------------------------
+ -- Contains_Subprograms_Refs --
+ -------------------------------
- function Contains_Subp_Or_Const_Refs (N : Node_Id) return Boolean is
+ function Contains_Subprograms_Refs (N : Node_Id) return Boolean is
Reference_Seen : Boolean := False;
- function Is_Subp_Or_Const_Ref
- (N : Node_Id) return Traverse_Result;
- -- Determine whether a node denotes a reference to a subprogram or
- -- a non-static constant.
+ function Is_Subprogram_Ref (N : Node_Id) return Traverse_Result;
+ -- Determine whether a node denotes a reference to a subprogram
- --------------------------
- -- Is_Subp_Or_Const_Ref --
- --------------------------
+ -----------------------
+ -- Is_Subprogram_Ref --
+ -----------------------
- function Is_Subp_Or_Const_Ref
+ function Is_Subprogram_Ref
(N : Node_Id) return Traverse_Result
is
Val : Node_Id;
@@ -263,7 +269,8 @@ package body Sem_Ch7 is
Reference_Seen := True;
return Abandon;
- -- Detect the use of a non-static constant
+ -- Constants can be substituted by their value in gigi, which
+ -- may contain a reference, so be conservative for them.
elsif Is_Entity_Name (N)
and then Present (Entity (N))
@@ -280,18 +287,18 @@ package body Sem_Ch7 is
end if;
return OK;
- end Is_Subp_Or_Const_Ref;
+ end Is_Subprogram_Ref;
- procedure Find_Subp_Or_Const_Ref is
- new Traverse_Proc (Is_Subp_Or_Const_Ref);
+ procedure Find_Subprograms_Ref is
+ new Traverse_Proc (Is_Subprogram_Ref);
- -- Start of processing for Contains_Subp_Or_Const_Refs
+ -- Start of processing for Contains_Subprograms_Refs
begin
- Find_Subp_Or_Const_Ref (N);
+ Find_Subprograms_Ref (N);
return Reference_Seen;
- end Contains_Subp_Or_Const_Refs;
+ end Contains_Subprograms_Refs;
--------------------
-- Has_Referencer --
@@ -305,9 +312,11 @@ package body Sem_Ch7 is
Decl_Id : Entity_Id;
Spec : Node_Id;
- Has_Non_Subp_Const_Referencer : Boolean := False;
- -- Flag set for inlined subprogram bodies that do not contain
- -- references to other subprograms or non-static constants.
+ Has_Non_Subprograms_Referencer : Boolean := False;
+ -- Flag set if a subprogram body was detected as a referencer but
+ -- does not contain references to other subprograms. In this case,
+ -- if we still are top level, we do not return True immediately,
+ -- but keep hiding subprograms from external visibility.
begin
if No (Decls) then
@@ -328,9 +337,7 @@ package body Sem_Ch7 is
-- Package declaration
- elsif Nkind (Decl) = N_Package_Declaration
- and then not Has_Non_Subp_Const_Referencer
- then
+ elsif Nkind (Decl) = N_Package_Declaration then
Spec := Specification (Decl);
-- Inspect the declarations of a non-generic package to try
@@ -367,9 +374,7 @@ package body Sem_Ch7 is
-- Inspect the declarations of a non-generic package body to
-- try and hide more entities from external visibility.
- elsif not Has_Non_Subp_Const_Referencer
- and then Has_Referencer (Declarations (Decl))
- then
+ elsif Has_Referencer (Declarations (Decl)) then
return True;
end if;
@@ -392,12 +397,12 @@ package body Sem_Ch7 is
then
-- Inspect the statements of the subprogram body
-- to determine whether the body references other
- -- subprograms and/or non-static constants.
+ -- subprograms.
if Top_Level
- and then not Contains_Subp_Or_Const_Refs (Decl)
+ and then not Contains_Subprograms_Refs (Decl)
then
- Has_Non_Subp_Const_Referencer := True;
+ Has_Non_Subprograms_Referencer := True;
else
return True;
end if;
@@ -421,9 +426,9 @@ package body Sem_Ch7 is
if Has_Pragma_Inline (Decl_Id) then
if Top_Level
- and then not Contains_Subp_Or_Const_Refs (Decl)
+ and then not Contains_Subprograms_Refs (Decl)
then
- Has_Non_Subp_Const_Referencer := True;
+ Has_Non_Subprograms_Referencer := True;
else
return True;
end if;
@@ -436,6 +441,9 @@ package body Sem_Ch7 is
-- if they are not followed by a construct which can reference
-- and export them. The Is_Public flag is reset on top level
-- entities only as anything nested is local to its context.
+ -- Likewise for subprograms, but we work harder for them as
+ -- their visibility can have a significant impact on inlining
+ -- decisions in the back end.
elsif Nkind_In (Decl, N_Exception_Declaration,
N_Object_Declaration,
@@ -450,7 +458,7 @@ package body Sem_Ch7 is
and then not Is_Exported (Decl_Id)
and then No (Interface_Name (Decl_Id))
and then
- (not Has_Non_Subp_Const_Referencer
+ (not Has_Non_Subprograms_Referencer
or else Nkind (Decl) = N_Subprogram_Declaration)
then
Set_Is_Public (Decl_Id, False);
@@ -460,7 +468,7 @@ package body Sem_Ch7 is
Prev (Decl);
end loop;
- return Has_Non_Subp_Const_Referencer;
+ return Has_Non_Subprograms_Referencer;
end Has_Referencer;
-- Local variables
@@ -531,10 +539,10 @@ package body Sem_Ch7 is
-- Local variables
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
Body_Id : Entity_Id;
HSS : Node_Id;
Last_Spec_Entity : Entity_Id;
+ Mode : Ghost_Mode_Type;
New_N : Node_Id;
Pack_Decl : Node_Id;
Spec_Id : Entity_Id;
@@ -542,35 +550,6 @@ package body Sem_Ch7 is
-- Start of processing for Analyze_Package_Body_Helper
begin
- -- A [generic] package body "freezes" the contract of the nearest
- -- enclosing package body and all other contracts encountered in the
- -- same declarative part up to and excluding the package body:
-
- -- package body Nearest_Enclosing_Package
- -- with Refined_State => (State => Constit)
- -- is
- -- Constit : ...;
-
- -- package body Freezes_Enclosing_Package_Body
- -- with Refined_State => (State_2 => Constit_2)
- -- is
- -- Constit_2 : ...;
-
- -- procedure Proc
- -- with Refined_Depends => (Input => (Constit, Constit_2)) ...
-
- -- This ensures that any annotations referenced by the contract of a
- -- [generic] subprogram body declared within the current package body
- -- are available. This form of "freezing" is decoupled from the usual
- -- Freeze_xxx mechanism because it must also work in the context of
- -- generics where normal freezing is disabled.
-
- -- Only bodies coming from source should cause this type of "freezing"
-
- if Comes_From_Source (N) then
- Analyze_Previous_Contracts (N);
- end if;
-
-- Find corresponding package specification, and establish the current
-- scope. The visible defining entity for the package is the defining
-- occurrence in the spec. On exit from the package body, all body
@@ -626,11 +605,47 @@ package body Sem_Ch7 is
end if;
end if;
+ -- A [generic] package body "freezes" the contract of the nearest
+ -- enclosing package body and all other contracts encountered in the
+ -- same declarative part up to and excluding the package body:
+
+ -- package body Nearest_Enclosing_Package
+ -- with Refined_State => (State => Constit)
+ -- is
+ -- Constit : ...;
+
+ -- package body Freezes_Enclosing_Package_Body
+ -- with Refined_State => (State_2 => Constit_2)
+ -- is
+ -- Constit_2 : ...;
+
+ -- procedure Proc
+ -- with Refined_Depends => (Input => (Constit, Constit_2)) ...
+
+ -- This ensures that any annotations referenced by the contract of a
+ -- [generic] subprogram body declared within the current package body
+ -- are available. This form of "freezing" is decoupled from the usual
+ -- Freeze_xxx mechanism because it must also work in the context of
+ -- generics where normal freezing is disabled.
+
+ -- Only bodies coming from source should cause this type of "freezing".
+ -- Instantiated generic bodies are excluded because their processing is
+ -- performed in a separate compilation pass which lacks enough semantic
+ -- information with respect to contract analysis. It is safe to suppress
+ -- the "freezing" of contracts in this case because this action already
+ -- took place at the end of the enclosing declarative part.
+
+ if Comes_From_Source (N)
+ and then not Is_Generic_Instance (Spec_Id)
+ then
+ Analyze_Previous_Contracts (N);
+ end if;
+
-- A package body is Ghost when the corresponding spec is Ghost. Set
-- the mode now to ensure that any nodes generated during analysis and
-- expansion are properly flagged as ignored Ghost.
- Set_Ghost_Mode (N, Spec_Id);
+ Mark_And_Set_Ghost_Body (N, Spec_Id, Mode);
Set_Is_Compilation_Unit (Body_Id, Is_Compilation_Unit (Spec_Id));
Style.Check_Identifier (Body_Id, Spec_Id);
@@ -725,19 +740,6 @@ package body Sem_Ch7 is
Set_SPARK_Aux_Pragma_Inherited (Body_Id);
end if;
- -- Inherit the "ghostness" of the package spec. Note that this property
- -- is not directly inherited as the body may be subject to a different
- -- Ghost assertion policy.
-
- if Ghost_Mode > None or else Is_Ghost_Entity (Spec_Id) then
- Set_Is_Ghost_Entity (Body_Id);
-
- -- The Ghost policy in effect at the point of declaration and at the
- -- point of completion must match (SPARK RM 6.9(14)).
-
- Check_Ghost_Completion (Spec_Id, Body_Id);
- end if;
-
Set_Categorization_From_Pragmas (N);
Install_Visible_Declarations (Spec_Id);
@@ -777,9 +779,10 @@ package body Sem_Ch7 is
if Present (SPARK_Pragma (Body_Id)) then
if Present (SPARK_Aux_Pragma (Spec_Id)) then
- if Get_SPARK_Mode_From_Pragma (SPARK_Aux_Pragma (Spec_Id)) = Off
- and then
- Get_SPARK_Mode_From_Pragma (SPARK_Pragma (Body_Id)) = On
+ if Get_SPARK_Mode_From_Annotation (SPARK_Aux_Pragma (Spec_Id)) =
+ Off
+ and then
+ Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Body_Id)) = On
then
Error_Msg_Sloc := Sloc (SPARK_Pragma (Body_Id));
Error_Msg_N ("incorrect application of SPARK_Mode#", N);
@@ -928,7 +931,7 @@ package body Sem_Ch7 is
end if;
end if;
- Ghost_Mode := Save_Ghost_Mode;
+ Restore_Ghost_Mode (Mode);
end Analyze_Package_Body_Helper;
---------------------------------
@@ -936,17 +939,14 @@ package body Sem_Ch7 is
---------------------------------
procedure Analyze_Package_Declaration (N : Node_Id) is
- Id : constant Node_Id := Defining_Entity (N);
+ Id : constant Node_Id := Defining_Entity (N);
+
+ Is_Comp_Unit : constant Boolean :=
+ Nkind (Parent (N)) = N_Compilation_Unit;
Body_Required : Boolean;
-- True when this package declaration requires a corresponding body
- Comp_Unit : Boolean;
- -- True when this package declaration is not a nested declaration
-
- PF : Boolean;
- -- True when in the context of a declared pure library unit
-
begin
if Debug_Flag_C then
Write_Str ("==> package spec ");
@@ -971,13 +971,6 @@ package body Sem_Ch7 is
Set_SPARK_Aux_Pragma_Inherited (Id);
end if;
- -- A package declared within a Ghost refion is automatically Ghost
- -- (SPARK RM 6.9(2)).
-
- if Ghost_Mode > None then
- Set_Is_Ghost_Entity (Id);
- end if;
-
-- Analyze aspect specifications immediately, since we need to recognize
-- things like Pure early enough to diagnose violations during analysis.
@@ -985,9 +978,9 @@ package body Sem_Ch7 is
Analyze_Aspect_Specifications (N, Id);
end if;
- -- Ada 2005 (AI-217): Check if the package has been illegally named
- -- in a limited-with clause of its own context. In this case the error
- -- has been previously notified by Analyze_Context.
+ -- Ada 2005 (AI-217): Check if the package has been illegally named in
+ -- a limited-with clause of its own context. In this case the error has
+ -- been previously notified by Analyze_Context.
-- limited with Pkg; -- ERROR
-- package Pkg is ...
@@ -998,30 +991,45 @@ package body Sem_Ch7 is
Push_Scope (Id);
- PF := Is_Pure (Enclosing_Lib_Unit_Entity);
- Set_Is_Pure (Id, PF);
-
+ Set_Is_Pure (Id, Is_Pure (Enclosing_Lib_Unit_Entity));
Set_Categorization_From_Pragmas (N);
Analyze (Specification (N));
Validate_Categorization_Dependency (N, Id);
- Body_Required := Unit_Requires_Body (Id);
+ -- Determine whether the package requires a body. Abstract states are
+ -- intentionally ignored because they do require refinement which can
+ -- only come in a body, but at the same time they do not force the need
+ -- for a body on their own (SPARK RM 7.1.4(4) and 7.2.2(3)).
- -- When this spec does not require an explicit body, we know that there
- -- are no entities requiring completion in the language sense; we call
- -- Check_Completion here only to ensure that any nested package
- -- declaration that requires an implicit body gets one. (In the case
- -- where a body is required, Check_Completion is called at the end of
- -- the body's declarative part.)
+ Body_Required := Unit_Requires_Body (Id);
if not Body_Required then
+
+ -- If the package spec does not require an explicit body, then there
+ -- are not entities requiring completion in the language sense. Call
+ -- Check_Completion now to ensure that nested package declarations
+ -- that require an implicit body get one. (In the case where a body
+ -- is required, Check_Completion is called at the end of the body's
+ -- declarative part.)
+
Check_Completion;
- end if;
- Comp_Unit := Nkind (Parent (N)) = N_Compilation_Unit;
+ -- If the package spec does not require an explicit body, then all
+ -- abstract states declared in nested packages cannot possibly get
+ -- a proper refinement (SPARK RM 7.2.2(3)). This check is performed
+ -- only when the compilation unit is the main unit to allow for
+ -- modular SPARK analysis where packages do not necessarily have
+ -- bodies.
+
+ if Is_Comp_Unit then
+ Check_State_Refinements
+ (Context => N,
+ Is_Main_Unit => Parent (N) = Cunit (Main_Unit));
+ end if;
+ end if;
- if Comp_Unit then
+ if Is_Comp_Unit then
-- Set Body_Required indication on the compilation unit node, and
-- determine whether elaboration warnings may be meaningful on it.
@@ -1041,7 +1049,7 @@ package body Sem_Ch7 is
-- visibility tests that rely on the fact that we have exited the scope
-- of Id.
- if Comp_Unit then
+ if Is_Comp_Unit then
Validate_RT_RAT_Component (N);
end if;
@@ -1364,7 +1372,7 @@ package body Sem_Ch7 is
-- If one of the non-generic parents is itself on the scope
-- stack, do not install its private declarations: they are
-- installed in due time when the private part of that parent
- -- is analyzed. This is delicate ???
+ -- is analyzed.
else
while Present (Inst_Par)
@@ -1372,11 +1380,20 @@ package body Sem_Ch7 is
and then (not In_Open_Scopes (Inst_Par)
or else not In_Private_Part (Inst_Par))
loop
- Install_Private_Declarations (Inst_Par);
- Set_Use (Private_Declarations
- (Specification
- (Unit_Declaration_Node (Inst_Par))));
- Inst_Par := Scope (Inst_Par);
+ if Nkind (Inst_Node) = N_Formal_Package_Declaration
+ or else
+ not Is_Ancestor_Package
+ (Inst_Par, Cunit_Entity (Current_Sem_Unit))
+ then
+ Install_Private_Declarations (Inst_Par);
+ Set_Use
+ (Private_Declarations
+ (Specification
+ (Unit_Declaration_Node (Inst_Par))));
+ Inst_Par := Scope (Inst_Par);
+ else
+ exit;
+ end if;
end loop;
exit;
@@ -1413,40 +1430,11 @@ package body Sem_Ch7 is
Error_Msg_N ("no declaration in visible part for incomplete}", E);
end if;
- if Is_Type (E) then
-
- -- Each private type subject to pragma Default_Initial_Condition
- -- declares a specialized procedure which verifies the assumption
- -- of the pragma. The declaration appears in the visible part of
- -- the package to allow for being called from the outside.
-
- if Has_Default_Init_Cond (E) then
- Build_Default_Init_Cond_Procedure_Declaration (E);
-
- -- A private extension inherits the default initial condition
- -- procedure from its parent type.
-
- elsif Has_Inherited_Default_Init_Cond (E) then
- Inherit_Default_Init_Cond_Procedure (E);
- end if;
-
- -- If invariants are present, build the invariant procedure for a
- -- private type, but not any of its subtypes or interface types.
-
- if Has_Invariants (E) then
- if Ekind (E) = E_Private_Subtype then
- null;
- else
- Build_Invariant_Procedure (E, N);
- end if;
- end if;
- end if;
-
Next_Entity (E);
end loop;
if Is_Remote_Call_Interface (Id)
- and then Nkind (Parent (Parent (N))) = N_Compilation_Unit
+ and then Nkind (Parent (Parent (N))) = N_Compilation_Unit
then
Validate_RCI_Declarations (Id);
end if;
@@ -1463,7 +1451,20 @@ package body Sem_Ch7 is
declare
Orig_Spec : constant Node_Id := Specification (Orig_Decl);
Save_Priv : constant List_Id := Private_Declarations (Orig_Spec);
+
begin
+ -- Insert the freezing nodes after the visible declarations to
+ -- ensure that we analyze its aspects; needed to ensure that
+ -- global entities referenced in the aspects are properly handled.
+
+ if Ada_Version >= Ada_2012
+ and then Is_Non_Empty_List (Vis_Decls)
+ and then Is_Empty_List (Priv_Decls)
+ then
+ Insert_List_After_And_Analyze
+ (Last (Vis_Decls), Freeze_Entity (Id, Last (Vis_Decls)));
+ end if;
+
Set_Private_Declarations (Orig_Spec, Empty_List);
Save_Global_References (Orig_Decl);
Set_Private_Declarations (Orig_Spec, Save_Priv);
@@ -1517,7 +1518,6 @@ package body Sem_Ch7 is
if Is_Compilation_Unit (Id) then
Install_Private_With_Clauses (Id);
else
-
-- The current compilation unit may include private with_clauses,
-- which are visible in the private part of the current nested
-- package, and have to be installed now. This is not done for
@@ -1609,50 +1609,6 @@ package body Sem_Ch7 is
("full view of & does not have preelaborable initialization", E);
end if;
- -- An invariant may appear on a full view of a type
-
- if Is_Type (E)
- and then Has_Private_Declaration (E)
- and then Nkind (Parent (E)) = N_Full_Type_Declaration
- then
- declare
- IP_Built : Boolean := False;
-
- begin
- if Has_Aspects (Parent (E)) then
- declare
- ASN : Node_Id;
-
- begin
- ASN := First (Aspect_Specifications (Parent (E)));
- while Present (ASN) loop
- if Nam_In (Chars (Identifier (ASN)),
- Name_Invariant,
- Name_Type_Invariant)
- then
- Build_Invariant_Procedure (E, N);
- IP_Built := True;
- exit;
- end if;
-
- Next (ASN);
- end loop;
- end;
- end if;
-
- -- Invariants may have been inherited from progenitors
-
- if not IP_Built
- and then Has_Interfaces (E)
- and then Has_Inheritable_Invariants (E)
- and then not Is_Interface (E)
- and then not Is_Class_Wide_Type (E)
- then
- Build_Invariant_Procedure (E, N);
- end if;
- end;
- end if;
-
Next_Entity (E);
end loop;
@@ -1682,6 +1638,17 @@ package body Sem_Ch7 is
Generic_Formal_Declarations (Orig_Decl);
begin
+ -- Insert the freezing nodes after the private declarations to
+ -- ensure that we analyze its aspects; needed to ensure that
+ -- global entities referenced in the aspects are properly handled.
+
+ if Ada_Version >= Ada_2012
+ and then Is_Non_Empty_List (Priv_Decls)
+ then
+ Insert_List_After_And_Analyze
+ (Last (Priv_Decls), Freeze_Entity (Id, Last (Priv_Decls)));
+ end if;
+
Set_Visible_Declarations (Orig_Spec, Empty_List);
Set_Generic_Formal_Declarations (Orig_Decl, Empty_List);
Save_Global_References (Orig_Decl);
@@ -1756,13 +1723,6 @@ package body Sem_Ch7 is
New_Private_Type (N, Id, N);
Set_Depends_On_Private (Id);
- -- A type declared within a Ghost region is automatically Ghost
- -- (SPARK RM 6.9(2)).
-
- if Ghost_Mode > None then
- Set_Is_Ghost_Entity (Id);
- end if;
-
if Has_Aspects (N) then
Analyze_Aspect_Specifications (N, Id);
end if;
@@ -2218,6 +2178,7 @@ package body Sem_Ch7 is
then
Set_Full_View (Id, Underlying_Full_View (Full));
Set_Underlying_Full_View (Id, Full);
+ Set_Is_Underlying_Full_View (Full);
Set_Underlying_Full_View (Full, Empty);
Set_Is_Frozen (Full_View (Id));
@@ -2242,6 +2203,34 @@ package body Sem_Ch7 is
Next_Entity (Id);
end loop;
+ -- An abstract state is partially refined when it has at least one
+ -- Part_Of constituent. Since these constituents are being installed
+ -- into visibility, update the partial refinement status of any state
+ -- defined in the associated package, subject to at least one Part_Of
+ -- constituent.
+
+ if Ekind_In (P, E_Generic_Package, E_Package) then
+ declare
+ States : constant Elist_Id := Abstract_States (P);
+ State_Elmt : Elmt_Id;
+ State_Id : Entity_Id;
+
+ begin
+ if Present (States) then
+ State_Elmt := First_Elmt (States);
+ while Present (State_Elmt) loop
+ State_Id := Node (State_Elmt);
+
+ if Present (Part_Of_Constituents (State_Id)) then
+ Set_Has_Partial_Visible_Refinement (State_Id);
+ end if;
+
+ Next_Elmt (State_Elmt);
+ end loop;
+ end if;
+ end;
+ end if;
+
-- Indicate that the private part is currently visible, so it can be
-- properly reset on exit.
@@ -2420,6 +2409,12 @@ package body Sem_Ch7 is
Set_Is_Limited_Record (Id, Limited_Present (Def));
Set_Has_Delayed_Freeze (Id, True);
+ -- Recognize Ada.Real_Time.Timing_Events.Timing_Events here
+
+ if Is_RTE (Id, RE_Timing_Event) then
+ Set_Has_Timing_Event (Id);
+ end if;
+
-- Create a class-wide type with the same attributes
Make_Class_Wide_Type (Id);
@@ -2434,8 +2429,9 @@ package body Sem_Ch7 is
---------------------------------
function Requires_Completion_In_Body
- (Id : Entity_Id;
- Pack_Id : Entity_Id) return Boolean
+ (Id : Entity_Id;
+ Pack_Id : Entity_Id;
+ Do_Abstract_States : Boolean := False) return Boolean
is
begin
-- Always ignore child units. Child units get added to the entity list
@@ -2449,7 +2445,7 @@ package body Sem_Ch7 is
elsif Ekind (Id) = E_Package
and then Nkind (Original_Node (Unit_Declaration_Node (Id))) =
- N_Formal_Package_Declaration
+ N_Formal_Package_Declaration
then
return False;
@@ -2459,8 +2455,7 @@ package body Sem_Ch7 is
-- implicit completion at some point.
elsif (Is_Overloadable (Id)
- and then Ekind (Id) /= E_Enumeration_Literal
- and then Ekind (Id) /= E_Operator
+ and then not Ekind_In (Id, E_Enumeration_Literal, E_Operator)
and then not Is_Abstract_Subprogram (Id)
and then not Has_Completion (Id)
and then Comes_From_Source (Parent (Id)))
@@ -2469,7 +2464,7 @@ package body Sem_Ch7 is
(Ekind (Id) = E_Package
and then Id /= Pack_Id
and then not Has_Completion (Id)
- and then Unit_Requires_Body (Id))
+ and then Unit_Requires_Body (Id, Do_Abstract_States))
or else
(Ekind (Id) = E_Incomplete_Type
@@ -2484,12 +2479,11 @@ package body Sem_Ch7 is
(Ekind (Id) = E_Generic_Package
and then Id /= Pack_Id
and then not Has_Completion (Id)
- and then Unit_Requires_Body (Id))
+ and then Unit_Requires_Body (Id, Do_Abstract_States))
or else
(Is_Generic_Subprogram (Id)
and then not Has_Completion (Id))
-
then
return True;
@@ -2511,7 +2505,7 @@ package body Sem_Ch7 is
Priv_Elmt : Elmt_Id;
Priv_Sub : Entity_Id;
- procedure Preserve_Full_Attributes (Priv, Full : Entity_Id);
+ procedure Preserve_Full_Attributes (Priv : Entity_Id; Full : Entity_Id);
-- Copy to the private declaration the attributes of the full view that
-- need to be available for the partial view also.
@@ -2522,12 +2516,16 @@ package body Sem_Ch7 is
-- Preserve_Full_Attributes --
------------------------------
- procedure Preserve_Full_Attributes (Priv, Full : Entity_Id) is
- Priv_Is_Base_Type : constant Boolean := Is_Base_Type (Priv);
+ procedure Preserve_Full_Attributes
+ (Priv : Entity_Id;
+ Full : Entity_Id)
+ is
+ Full_Base : constant Entity_Id := Base_Type (Full);
+ Priv_Is_Base_Type : constant Boolean := Is_Base_Type (Priv);
begin
- Set_Size_Info (Priv, (Full));
- Set_RM_Size (Priv, RM_Size (Full));
+ Set_Size_Info (Priv, Full);
+ Set_RM_Size (Priv, RM_Size (Full));
Set_Size_Known_At_Compile_Time
(Priv, Size_Known_At_Compile_Time (Full));
Set_Is_Volatile (Priv, Is_Volatile (Full));
@@ -2549,26 +2547,40 @@ package body Sem_Ch7 is
end if;
if Priv_Is_Base_Type then
- Set_Is_Controlled (Priv, Is_Controlled (Base_Type (Full)));
+ Set_Is_Controlled (Priv, Is_Controlled (Full_Base));
Set_Finalize_Storage_Only
- (Priv, Finalize_Storage_Only
- (Base_Type (Full)));
- Set_Has_Task (Priv, Has_Task (Base_Type (Full)));
- Set_Has_Protected (Priv, Has_Protected (Base_Type (Full)));
+ (Priv, Finalize_Storage_Only (Full_Base));
Set_Has_Controlled_Component
- (Priv, Has_Controlled_Component
- (Base_Type (Full)));
+ (Priv, Has_Controlled_Component (Full_Base));
+
+ Propagate_Concurrent_Flags (Priv, Base_Type (Full));
end if;
Set_Freeze_Node (Priv, Freeze_Node (Full));
- -- Propagate information of type invariants, which may be specified
- -- for the full view.
+ -- Propagate Default_Initial_Condition-related attributes from the
+ -- base type of the full view to the full view and vice versa. This
+ -- may seem strange, but is necessary depending on which type
+ -- triggered the generation of the DIC procedure body. As a result,
+ -- both the full view and its base type carry the same DIC-related
+ -- information.
- if Has_Invariants (Full) and not Has_Invariants (Priv) then
- Set_Has_Invariants (Priv);
- Set_Subprograms_For_Type (Priv, Subprograms_For_Type (Full));
- end if;
+ Propagate_DIC_Attributes (Full, From_Typ => Full_Base);
+ Propagate_DIC_Attributes (Full_Base, From_Typ => Full);
+
+ -- Propagate invariant-related attributes from the base type of the
+ -- full view to the full view and vice versa. This may seem strange,
+ -- but is necessary depending on which type triggered the generation
+ -- of the invariant procedure body. As a result, both the full view
+ -- and its base type carry the same invariant-related information.
+
+ Propagate_Invariant_Attributes (Full, From_Typ => Full_Base);
+ Propagate_Invariant_Attributes (Full_Base, From_Typ => Full);
+
+ -- Propagate invariant-related attributes from the full view to the
+ -- private view.
+
+ Propagate_Invariant_Attributes (Priv, From_Typ => Full);
if Is_Tagged_Type (Priv)
and then Is_Tagged_Type (Full)
@@ -2911,7 +2923,7 @@ package body Sem_Ch7 is
if Is_Overloadable (Subp) and then Is_Primitive (Subp) then
Error_Msg_NE
("type& must be completed in the private part",
- Parent (Subp), Id);
+ Parent (Subp), Id);
-- The result type of an access-to-function type cannot be a
-- Taft-amendment type, unless the version is Ada 2012 or
@@ -2952,11 +2964,15 @@ package body Sem_Ch7 is
------------------------
function Unit_Requires_Body
- (Pack_Id : Entity_Id;
- Ignore_Abstract_State : Boolean := False) return Boolean
+ (Pack_Id : Entity_Id;
+ Do_Abstract_States : Boolean := False) return Boolean
is
E : Entity_Id;
+ Requires_Body : Boolean := False;
+ -- Flag set when the unit has at least one construct that requries
+ -- completion in a body.
+
begin
-- Imported entity never requires body. Right now, only subprograms can
-- be imported, but perhaps in the future we will allow import of
@@ -2991,35 +3007,44 @@ package body Sem_Ch7 is
return True;
end if;
end;
-
- -- A [generic] package that introduces at least one non-null abstract
- -- state requires completion. However, there is a separate rule that
- -- requires that such a package have a reason other than this for a
- -- body being required (if necessary a pragma Elaborate_Body must be
- -- provided). If Ignore_Abstract_State is True, we don't do this check
- -- (so we can use Unit_Requires_Body to check for some other reason).
-
- elsif Ekind_In (Pack_Id, E_Generic_Package, E_Package)
- and then not Ignore_Abstract_State
- and then Present (Abstract_States (Pack_Id))
- and then not Is_Null_State
- (Node (First_Elmt (Abstract_States (Pack_Id))))
- then
- return True;
end if;
- -- Otherwise search entity chain for entity requiring completion
+ -- Traverse the entity chain of the package and look for constructs that
+ -- require a completion in a body.
E := First_Entity (Pack_Id);
while Present (E) loop
- if Requires_Completion_In_Body (E, Pack_Id) then
- return True;
+
+ -- Skip abstract states because their completion depends on several
+ -- criteria (see below).
+
+ if Ekind (E) = E_Abstract_State then
+ null;
+
+ elsif Requires_Completion_In_Body
+ (E, Pack_Id, Do_Abstract_States)
+ then
+ Requires_Body := True;
+ exit;
end if;
Next_Entity (E);
end loop;
- return False;
+ -- A [generic] package that defines at least one non-null abstract state
+ -- requires a completion only when at least one other construct requires
+ -- a completion in a body (SPARK RM 7.1.4(4) and (6)). This check is not
+ -- performed if the caller requests this behavior.
+
+ if Do_Abstract_States
+ and then Ekind_In (Pack_Id, E_Generic_Package, E_Package)
+ and then Has_Non_Null_Abstract_State (Pack_Id)
+ and then Requires_Body
+ then
+ return True;
+ end if;
+
+ return Requires_Body;
end Unit_Requires_Body;
-----------------------------
diff --git a/gcc/ada/sem_ch7.ads b/gcc/ada/sem_ch7.ads
index 59f27b086b..4e645adf7f 100644
--- a/gcc/ada/sem_ch7.ads
+++ b/gcc/ada/sem_ch7.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -46,24 +46,21 @@ package Sem_Ch7 is
-- On entrance to a package body, make declarations in package spec
-- immediately visible.
--
- -- When compiling the body of a package, both routines are called in
+ -- When compiling the body of a package, both routines are called in
-- succession. When compiling the body of a child package, the call
-- to Install_Private_Declaration is immediate for private children,
- -- but is deferred until the compilation of the private part of the
+ -- but is deferred until the compilation of the private part of the
-- child for public child packages.
function Unit_Requires_Body
- (Pack_Id : Entity_Id;
- Ignore_Abstract_State : Boolean := False) return Boolean;
+ (Pack_Id : Entity_Id;
+ Do_Abstract_States : Boolean := False) return Boolean;
-- Determine whether package Pack_Id requires a body. A specification needs
-- a body if it contains declarations that require completion in the body.
-- A non-Ghost [generic] package does not require a body when it declares
- -- Ghost entities exclusively. If flag Ignore_Abstract_State is True, then
- -- the test for a non-null abstract state (which normally requires a body)
- -- is not carried out. The flag is not currently used, but may be useful
- -- in the future if we implement a compatibility mode which warns about
- -- possible incompatibilities if a SPARK 2014 program is compiled with a
- -- SPARK-unaware compiler.
+ -- Ghost entities exclusively. When flag Do_Abstract_States is set to True,
+ -- non-null abstract states are considered in determining the need for a
+ -- body.
procedure May_Need_Implicit_Body (E : Entity_Id);
-- If a package declaration contains tasks or RACWs and does not require
diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
index e8f7b1f00d..d8794920f8 100644
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -575,7 +575,7 @@ package body Sem_Ch8 is
-- The exception renaming declaration may become Ghost if it renames
-- a Ghost entity.
- Mark_Renaming_As_Ghost (N, Entity (Nam));
+ Mark_Ghost_Renaming (N, Entity (Nam));
else
Error_Msg_N ("invalid exception name in renaming", Nam);
end if;
@@ -609,11 +609,12 @@ package body Sem_Ch8 is
Set_Etype (N, Etype (Entity (N)));
end if;
- return;
else
Find_Expanded_Name (N);
end if;
+ -- In either case, propagate dimension of entity to expanded name
+
Analyze_Dimension (N);
end Analyze_Expanded_Name;
@@ -658,10 +659,8 @@ package body Sem_Ch8 is
K : Entity_Kind)
is
New_P : constant Entity_Id := Defining_Entity (N);
- Old_P : Entity_Id;
-
Inst : Boolean := False;
- -- Prevent junk warning
+ Old_P : Entity_Id;
begin
if Name (N) = Error then
@@ -705,17 +704,17 @@ package body Sem_Ch8 is
Set_Renamed_Object (New_P, Old_P);
end if;
+ -- The generic renaming declaration may become Ghost if it renames a
+ -- Ghost entity.
+
+ Mark_Ghost_Renaming (N, Old_P);
+
Set_Is_Pure (New_P, Is_Pure (Old_P));
Set_Is_Preelaborated (New_P, Is_Preelaborated (Old_P));
Set_Etype (New_P, Etype (Old_P));
Set_Has_Completion (New_P);
- -- The generic renaming declaration may become Ghost if it renames a
- -- Ghost entity.
-
- Mark_Renaming_As_Ghost (N, Old_P);
-
if In_Open_Scopes (Old_P) then
Error_Msg_N ("within its scope, generic denotes its instance", N);
end if;
@@ -760,9 +759,6 @@ package body Sem_Ch8 is
-- has already established its actual subtype. This is only relevant
-- if the renamed object is an explicit dereference.
- function In_Generic_Scope (E : Entity_Id) return Boolean;
- -- Determine whether entity E is inside a generic cope
-
------------------------------
-- Check_Constrained_Object --
------------------------------
@@ -824,26 +820,6 @@ package body Sem_Ch8 is
end if;
end Check_Constrained_Object;
- ----------------------
- -- In_Generic_Scope --
- ----------------------
-
- function In_Generic_Scope (E : Entity_Id) return Boolean is
- S : Entity_Id;
-
- begin
- S := Scope (E);
- while Present (S) and then S /= Standard_Standard loop
- if Is_Generic_Unit (S) then
- return True;
- end if;
-
- S := Scope (S);
- end loop;
-
- return False;
- end In_Generic_Scope;
-
-- Start of processing for Analyze_Object_Renaming
begin
@@ -863,7 +839,15 @@ package body Sem_Ch8 is
-- already-analyzed expression.
if Nkind (Nam) = N_Selected_Component and then Analyzed (Nam) then
- T := Etype (Nam);
+
+ -- The object renaming declaration may become Ghost if it renames a
+ -- Ghost entity.
+
+ if Is_Entity_Name (Nam) then
+ Mark_Ghost_Renaming (N, Entity (Nam));
+ end if;
+
+ T := Etype (Nam);
Dec := Build_Actual_Subtype_Of_Component (Etype (Nam), Nam);
if Present (Dec) then
@@ -883,6 +867,13 @@ package body Sem_Ch8 is
T := Entity (Subtype_Mark (N));
Analyze (Nam);
+ -- The object renaming declaration may become Ghost if it renames a
+ -- Ghost entity.
+
+ if Is_Entity_Name (Nam) then
+ Mark_Ghost_Renaming (N, Entity (Nam));
+ end if;
+
-- Reject renamings of conversions unless the type is tagged, or
-- the conversion is implicit (which can occur for cases of anonymous
-- access types in Ada 2012).
@@ -951,12 +942,20 @@ package body Sem_Ch8 is
-- Ada 2005 (AI-230/AI-254): Access renaming
else pragma Assert (Present (Access_Definition (N)));
- T := Access_Definition
- (Related_Nod => N,
- N => Access_Definition (N));
+ T :=
+ Access_Definition
+ (Related_Nod => N,
+ N => Access_Definition (N));
Analyze (Nam);
+ -- The object renaming declaration may become Ghost if it renames a
+ -- Ghost entity.
+
+ if Is_Entity_Name (Nam) then
+ Mark_Ghost_Renaming (N, Entity (Nam));
+ end if;
+
-- Ada 2005 AI05-105: if the declaration has an anonymous access
-- type, the renamed object must also have an anonymous type, and
-- this is a name resolution rule. This was implicit in the last part
@@ -1022,22 +1021,30 @@ package body Sem_Ch8 is
Resolve (Nam, T);
+ -- Do not perform the legality checks below when the resolution of
+ -- the renaming name failed because the associated type is Any_Type.
+
+ if Etype (Nam) = Any_Type then
+ null;
+
-- Ada 2005 (AI-231): In the case where the type is defined by an
-- access_definition, the renamed entity shall be of an access-to-
-- constant type if and only if the access_definition defines an
-- access-to-constant type. ARM 8.5.1(4)
- if Constant_Present (Access_Definition (N))
+ elsif Constant_Present (Access_Definition (N))
and then not Is_Access_Constant (Etype (Nam))
then
- Error_Msg_N ("(Ada 2005): the renamed object is not "
- & "access-to-constant (RM 8.5.1(6))", N);
+ Error_Msg_N
+ ("(Ada 2005): the renamed object is not access-to-constant "
+ & "(RM 8.5.1(6))", N);
elsif not Constant_Present (Access_Definition (N))
and then Is_Access_Constant (Etype (Nam))
then
- Error_Msg_N ("(Ada 2005): the renamed object is not "
- & "access-to-variable (RM 8.5.1(6))", N);
+ Error_Msg_N
+ ("(Ada 2005): the renamed object is not access-to-variable "
+ & "(RM 8.5.1(6))", N);
end if;
if Is_Access_Subprogram_Type (Etype (Nam)) then
@@ -1086,7 +1093,6 @@ package body Sem_Ch8 is
("\suggest using an initialized constant "
& "object instead?R?", Nam);
end if;
-
end case;
end if;
@@ -1311,13 +1317,6 @@ package body Sem_Ch8 is
Set_Is_True_Constant (Id, True);
end if;
- -- The object renaming declaration may become Ghost if it renames a
- -- Ghost entity.
-
- if Is_Entity_Name (Nam) then
- Mark_Renaming_As_Ghost (N, Entity (Nam));
- end if;
-
-- The entity of the renaming declaration needs to reflect whether the
-- renamed object is volatile. Is_Volatile is set if the renamed object
-- is volatile in the RM legality sense.
@@ -1408,7 +1407,7 @@ package body Sem_Ch8 is
else
Error_Msg_Sloc := Sloc (Old_P);
Error_Msg_NE
- ("expect package name in renaming, found& declared#",
+ ("expect package name in renaming, found& declared#",
Name (N), Old_P);
end if;
@@ -1428,24 +1427,23 @@ package body Sem_Ch8 is
Set_Etype (New_P, Standard_Void_Type);
if Present (Renamed_Object (Old_P)) then
- Set_Renamed_Object (New_P, Renamed_Object (Old_P));
+ Set_Renamed_Object (New_P, Renamed_Object (Old_P));
else
Set_Renamed_Object (New_P, Old_P);
end if;
- Set_Has_Completion (New_P);
+ -- The package renaming declaration may become Ghost if it renames a
+ -- Ghost entity.
+
+ Mark_Ghost_Renaming (N, Old_P);
- Set_First_Entity (New_P, First_Entity (Old_P));
- Set_Last_Entity (New_P, Last_Entity (Old_P));
+ Set_Has_Completion (New_P);
+ Set_First_Entity (New_P, First_Entity (Old_P));
+ Set_Last_Entity (New_P, Last_Entity (Old_P));
Set_First_Private_Entity (New_P, First_Private_Entity (Old_P));
Check_Library_Unit_Renaming (N, Old_P);
Generate_Reference (Old_P, Name (N));
- -- The package renaming declaration may become Ghost if it renames a
- -- Ghost entity.
-
- Mark_Renaming_As_Ghost (N, Old_P);
-
-- If the renaming is in the visible part of a package, then we set
-- Renamed_In_Spec for the renamed package, to prevent giving
-- warnings about no entities referenced. Such a warning would be
@@ -1891,8 +1889,10 @@ package body Sem_Ch8 is
--
-- This transformation applies only if there is no explicit visible
-- class-wide operation at the point of the instantiation. Ren_Id is
- -- the entity of the renaming declaration. Wrap_Id is the entity of
- -- the generated class-wide wrapper (or Any_Id).
+ -- the entity of the renaming declaration. When the transformation
+ -- applies, Wrap_Id is the entity of the generated class-wide wrapper
+ -- (or Any_Id). Otherwise, Wrap_Id is the entity of the class-wide
+ -- operation.
procedure Check_Null_Exclusion
(Ren : Entity_Id;
@@ -1943,6 +1943,14 @@ package body Sem_Ch8 is
-- Create a dispatching call to invoke routine Subp_Id with actuals
-- built from the parameter specifications of list Params.
+ function Build_Expr_Fun_Call
+ (Subp_Id : Entity_Id;
+ Params : List_Id) return Node_Id;
+ -- Create a dispatching call to invoke function Subp_Id with actuals
+ -- built from the parameter specifications of list Params. Return
+ -- directly the call, so that it can be used inside an expression
+ -- function. This is a specificity of the GNATprove mode.
+
function Build_Spec (Subp_Id : Entity_Id) return Node_Id;
-- Create a subprogram specification based on the subprogram profile
-- of Subp_Id.
@@ -2007,6 +2015,39 @@ package body Sem_Ch8 is
end if;
end Build_Call;
+ -------------------------
+ -- Build_Expr_Fun_Call --
+ -------------------------
+
+ function Build_Expr_Fun_Call
+ (Subp_Id : Entity_Id;
+ Params : List_Id) return Node_Id
+ is
+ Actuals : constant List_Id := New_List;
+ Call_Ref : constant Node_Id := New_Occurrence_Of (Subp_Id, Loc);
+ Formal : Node_Id;
+
+ begin
+ pragma Assert (Ekind_In (Subp_Id, E_Function, E_Operator));
+
+ -- Build the actual parameters of the call
+
+ Formal := First (Params);
+ while Present (Formal) loop
+ Append_To (Actuals,
+ Make_Identifier (Loc, Chars (Defining_Identifier (Formal))));
+ Next (Formal);
+ end loop;
+
+ -- Generate:
+ -- Subp_Id (Actuals);
+
+ return
+ Make_Function_Call (Loc,
+ Name => Call_Ref,
+ Parameter_Associations => Actuals);
+ end Build_Expr_Fun_Call;
+
----------------
-- Build_Spec --
----------------
@@ -2202,6 +2243,7 @@ package body Sem_Ch8 is
Formal : Node_Id;
Prim_Op : Entity_Id;
Spec_Decl : Node_Id;
+ New_Spec : Node_Id;
-- Start of processing for Build_Class_Wide_Wrapper
@@ -2334,34 +2376,76 @@ package body Sem_Ch8 is
Set_Is_Overloaded (Name (N), False);
Set_Referenced (Prim_Op);
+ -- Do not generate a wrapper when the only candidate is a class-wide
+ -- subprogram. Instead modify the renaming to directly map the actual
+ -- to the generic formal.
+
+ if CW_Prim_OK and then Prim_Op = CW_Prim_Op then
+ Wrap_Id := Prim_Op;
+ Rewrite (Nam, New_Occurrence_Of (Prim_Op, Loc));
+ return;
+ end if;
+
-- Step 3: Create the declaration and the body of the wrapper, insert
-- all the pieces into the tree.
- Spec_Decl :=
- Make_Subprogram_Declaration (Loc,
- Specification => Build_Spec (Ren_Id));
- Insert_Before_And_Analyze (N, Spec_Decl);
+ -- In GNATprove mode, create a function wrapper in the form of an
+ -- expression function, so that an implicit postcondition relating
+ -- the result of calling the wrapper function and the result of the
+ -- dispatching call to the wrapped function is known during proof.
+
+ if GNATprove_Mode
+ and then Ekind_In (Ren_Id, E_Function, E_Operator)
+ then
+ New_Spec := Build_Spec (Ren_Id);
+ Body_Decl :=
+ Make_Expression_Function (Loc,
+ Specification => New_Spec,
+ Expression =>
+ Build_Expr_Fun_Call
+ (Subp_Id => Prim_Op,
+ Params => Parameter_Specifications (New_Spec)));
+
+ Wrap_Id := Defining_Entity (Body_Decl);
+
+ -- Otherwise, create separate spec and body for the subprogram
+
+ else
+ Spec_Decl :=
+ Make_Subprogram_Declaration (Loc,
+ Specification => Build_Spec (Ren_Id));
+ Insert_Before_And_Analyze (N, Spec_Decl);
+
+ Wrap_Id := Defining_Entity (Spec_Decl);
+
+ Body_Decl :=
+ Make_Subprogram_Body (Loc,
+ Specification => Build_Spec (Ren_Id),
+ Declarations => New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Build_Call
+ (Subp_Id => Prim_Op,
+ Params =>
+ Parameter_Specifications
+ (Specification (Spec_Decl))))));
+
+ Set_Corresponding_Body (Spec_Decl, Defining_Entity (Body_Decl));
+ end if;
-- If the operator carries an Eliminated pragma, indicate that the
-- wrapper is also to be eliminated, to prevent spurious error when
-- using gnatelim on programs that include box-initialization of
-- equality operators.
- Wrap_Id := Defining_Entity (Spec_Decl);
Set_Is_Eliminated (Wrap_Id, Is_Eliminated (Prim_Op));
- Body_Decl :=
- Make_Subprogram_Body (Loc,
- Specification => Build_Spec (Ren_Id),
- Declarations => New_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Build_Call
- (Subp_Id => Prim_Op,
- Params =>
- Parameter_Specifications
- (Specification (Spec_Decl))))));
+ -- In GNATprove mode, insert the body in the tree for analysis
+
+ if GNATprove_Mode then
+ Insert_Before_And_Analyze (N, Body_Decl);
+ end if;
-- The generated body does not freeze and must be analyzed when the
-- class-wide wrapper is frozen. The body is only needed if expansion
@@ -2589,8 +2673,8 @@ package body Sem_Ch8 is
and then Expander_Active
then
declare
- Stream_Prim : Entity_Id;
Prefix_Type : constant Entity_Id := Entity (Prefix (Nam));
+ Stream_Prim : Entity_Id;
begin
-- The class-wide forms of the stream attributes are not
@@ -2611,27 +2695,31 @@ package body Sem_Ch8 is
-- operation).
case Attribute_Name (Nam) is
- when Name_Input =>
+ when Name_Input =>
Stream_Prim :=
Find_Optional_Prim_Op (Prefix_Type, TSS_Stream_Input);
+
when Name_Output =>
Stream_Prim :=
Find_Optional_Prim_Op (Prefix_Type, TSS_Stream_Output);
- when Name_Read =>
+
+ when Name_Read =>
Stream_Prim :=
Find_Optional_Prim_Op (Prefix_Type, TSS_Stream_Read);
- when Name_Write =>
+
+ when Name_Write =>
Stream_Prim :=
Find_Optional_Prim_Op (Prefix_Type, TSS_Stream_Write);
- when others =>
+
+ when others =>
Error_Msg_N
- ("attribute must be a primitive"
- & " dispatching operation", Nam);
+ ("attribute must be a primitive dispatching operation",
+ Nam);
return;
end case;
- -- If no operation was found, and the type is limited,
- -- the user should have defined one.
+ -- If no operation was found, and the type is limited, the user
+ -- should have defined one.
if No (Stream_Prim) then
if Is_Limited_Type (Prefix_Type) then
@@ -2670,8 +2758,8 @@ package body Sem_Ch8 is
end if;
end if;
- -- Check whether this declaration corresponds to the instantiation
- -- of a formal subprogram.
+ -- Check whether this declaration corresponds to the instantiation of a
+ -- formal subprogram.
-- If this is an instantiation, the corresponding actual is frozen and
-- error messages can be made more precise. If this is a default
@@ -2692,8 +2780,8 @@ package body Sem_Ch8 is
-- is an external axiomatization on the package.
if CW_Actual
- and then Box_Present (Inst_Node)
- and then not
+ and then Box_Present (Inst_Node)
+ and then not
(GNATprove_Mode
and then
Present (Containing_Package_With_Ext_Axioms (Formal_Spec)))
@@ -2706,11 +2794,17 @@ package body Sem_Ch8 is
and then not Is_Overloaded (Nam)
then
Old_S := Entity (Nam);
+
+ -- The subprogram renaming declaration may become Ghost if it
+ -- renames a Ghost entity.
+
+ Mark_Ghost_Renaming (N, Old_S);
+
New_S := Analyze_Subprogram_Specification (Spec);
-- Operator case
- if Ekind (Entity (Nam)) = E_Operator then
+ if Ekind (Old_S) = E_Operator then
-- Box present
@@ -2744,9 +2838,9 @@ package body Sem_Ch8 is
and then Hidden /= Old_S
then
Error_Msg_Sloc := Sloc (Hidden);
- Error_Msg_N ("default subprogram is resolved " &
- "in the generic declaration " &
- "(RM 12.6(17))??", N);
+ Error_Msg_N
+ ("default subprogram is resolved in the generic "
+ & "declaration (RM 12.6(17))??", N);
Error_Msg_NE ("\and will not use & #??", N, Hidden);
end if;
end;
@@ -2755,6 +2849,14 @@ package body Sem_Ch8 is
else
Analyze (Nam);
+
+ -- The subprogram renaming declaration may become Ghost if it
+ -- renames a Ghost entity.
+
+ if Is_Entity_Name (Nam) then
+ Mark_Ghost_Renaming (N, Entity (Nam));
+ end if;
+
New_S := Analyze_Subprogram_Specification (Spec);
end if;
@@ -2764,6 +2866,13 @@ package body Sem_Ch8 is
Analyze (Nam);
+ -- The subprogram renaming declaration may become Ghost if it renames
+ -- a Ghost entity.
+
+ if Is_Entity_Name (Nam) then
+ Mark_Ghost_Renaming (N, Entity (Nam));
+ end if;
+
-- The renaming defines a new overloaded entity, which is analyzed
-- like a subprogram declaration.
@@ -2860,8 +2969,9 @@ package body Sem_Ch8 is
Error_Msg_NE
("subprogram& overrides inherited operation",
N, Rename_Spec);
- elsif
- Style_Check and then not Must_Override (Specification (N))
+
+ elsif Style_Check
+ and then not Must_Override (Specification (N))
then
Style.Missing_Overriding (N, Rename_Spec);
end if;
@@ -3040,11 +3150,6 @@ package body Sem_Ch8 is
Set_Is_Pure (New_S, Is_Pure (Entity (Nam)));
Set_Is_Preelaborated (New_S, Is_Preelaborated (Entity (Nam)));
- -- The subprogram renaming declaration may become Ghost if it renames
- -- a Ghost entity.
-
- Mark_Renaming_As_Ghost (N, Entity (Nam));
-
-- Ada 2005 (AI-423): Check the consistency of null exclusions
-- between a subprogram and its correct renaming.
@@ -3083,8 +3188,8 @@ package body Sem_Ch8 is
not Is_Abstract_Type (Find_Dispatching_Type (Old_S)))
then
Error_Msg_N
- ("renamed entity cannot be "
- & "subprogram that requires overriding (RM 8.5.4 (5.1))", N);
+ ("renamed entity cannot be subprogram that requires overriding "
+ & "(RM 8.5.4 (5.1))", N);
end if;
end if;
@@ -3139,7 +3244,7 @@ package body Sem_Ch8 is
then
Error_Msg_N
("subprogram in renaming_as_body cannot be intrinsic",
- Name (N));
+ Name (N));
end if;
Set_Has_Completion (Rename_Spec);
@@ -3305,7 +3410,12 @@ package body Sem_Ch8 is
Set_Alias (New_S, Empty);
end if;
- if Is_Actual then
+ -- Do not freeze the renaming nor the renamed entity when the context
+ -- is an enclosing generic. Freezing is an expansion activity, and in
+ -- addition the renamed entity may depend on the generic formals of
+ -- the enclosing generic.
+
+ if Is_Actual and not Inside_A_Generic then
Freeze_Before (N, Old_S);
Freeze_Actual_Profile;
Set_Has_Delayed_Freeze (New_S, False);
@@ -3379,8 +3489,7 @@ package body Sem_Ch8 is
then
Error_Msg_Node_2 := T1;
Error_Msg_NE
- ("default & on & is not directly visible",
- Nam, Nam);
+ ("default & on & is not directly visible", Nam, Nam);
end if;
end;
end if;
@@ -3411,8 +3520,8 @@ package body Sem_Ch8 is
then
Error_Msg_N ("access parameter is controlling,", New_F);
Error_Msg_NE
- ("\corresponding parameter of& "
- & "must be explicitly null excluding", New_F, Old_S);
+ ("\corresponding parameter of& must be explicitly null "
+ & "excluding", New_F, Old_S);
end if;
Next_Formal (Old_F);
@@ -3507,10 +3616,10 @@ package body Sem_Ch8 is
-- within the package itself, ignore it.
procedure Analyze_Use_Package (N : Node_Id) is
- Pack_Name : Node_Id;
+ Ghost_Id : Entity_Id := Empty;
+ Living_Id : Entity_Id := Empty;
Pack : Entity_Id;
-
- -- Start of processing for Analyze_Use_Package
+ Pack_Name : Node_Id;
begin
Check_SPARK_05_Restriction ("use clause is not allowed", N);
@@ -3555,8 +3664,8 @@ package body Sem_Ch8 is
if Entity (Pref) = Standard_Standard then
Error_Msg_N
- ("predefined package Standard cannot appear"
- & " in a context clause", Pref);
+ ("predefined package Standard cannot appear in a context "
+ & "clause", Pref);
end if;
end;
end if;
@@ -3564,8 +3673,8 @@ package body Sem_Ch8 is
Next (Pack_Name);
end loop;
- -- Loop through package names to mark all entities as potentially
- -- use visible.
+ -- Loop through package names to mark all entities as potentially use
+ -- visible.
Pack_Name := First (Names (N));
while Present (Pack_Name) loop
@@ -3601,6 +3710,21 @@ package body Sem_Ch8 is
if Applicable_Use (Pack_Name) then
Use_One_Package (Pack, N);
end if;
+
+ -- Capture the first Ghost package and the first living package
+
+ if Is_Entity_Name (Pack_Name) then
+ Pack := Entity (Pack_Name);
+
+ if Is_Ghost_Entity (Pack) then
+ if No (Ghost_Id) then
+ Ghost_Id := Pack;
+ end if;
+
+ elsif No (Living_Id) then
+ Living_Id := Pack;
+ end if;
+ end if;
end if;
-- Report error because name denotes something other than a package
@@ -3611,6 +3735,25 @@ package body Sem_Ch8 is
Next (Pack_Name);
end loop;
+
+ -- Detect a mixture of Ghost packages and living packages within the
+ -- same use package clause. Ideally one would split a use package clause
+ -- with multiple names into multiple use package clauses with a single
+ -- name, however clients of the front end would have to adapt to this
+ -- change.
+
+ if Present (Ghost_Id) and then Present (Living_Id) then
+ Error_Msg_N
+ ("use clause cannot mention ghost and non-ghost ghost units", N);
+
+ Error_Msg_Sloc := Sloc (Ghost_Id);
+ Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
+
+ Error_Msg_Sloc := Sloc (Living_Id);
+ Error_Msg_NE ("\& # declared as non-ghost", N, Living_Id);
+ end if;
+
+ Mark_Ghost_Clause (N);
end Analyze_Use_Package;
----------------------
@@ -3618,8 +3761,10 @@ package body Sem_Ch8 is
----------------------
procedure Analyze_Use_Type (N : Node_Id) is
- E : Entity_Id;
- Id : Node_Id;
+ E : Entity_Id;
+ Ghost_Id : Entity_Id := Empty;
+ Id : Node_Id;
+ Living_Id : Entity_Id := Empty;
begin
Set_Hidden_By_Use_Clause (N, No_Elist);
@@ -3725,8 +3870,37 @@ package body Sem_Ch8 is
end if;
end if;
+ -- Capture the first Ghost type and the first living type
+
+ if Is_Ghost_Entity (E) then
+ if No (Ghost_Id) then
+ Ghost_Id := E;
+ end if;
+
+ elsif No (Living_Id) then
+ Living_Id := E;
+ end if;
+
Next (Id);
end loop;
+
+ -- Detect a mixture of Ghost types and living types within the same use
+ -- type clause. Ideally one would split a use type clause with multiple
+ -- marks into multiple use type clauses with a single mark, however
+ -- clients of the front end will have to adapt to this change.
+
+ if Present (Ghost_Id) and then Present (Living_Id) then
+ Error_Msg_N
+ ("use clause cannot mention ghost and non-ghost ghost types", N);
+
+ Error_Msg_Sloc := Sloc (Ghost_Id);
+ Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
+
+ Error_Msg_Sloc := Sloc (Living_Id);
+ Error_Msg_NE ("\& # declared as non-ghost", N, Living_Id);
+ end if;
+
+ Mark_Ghost_Clause (N);
end Analyze_Use_Type;
--------------------
@@ -4804,9 +4978,9 @@ package body Sem_Ch8 is
or else
Name_Buffer (3 .. 5) = "aux";
- -- If not an internal file, then entity is definitely known,
- -- even if it is in a private part (the message generated will
- -- note that it is in a private part)
+ -- If not an internal file, then entity is definitely known, even if
+ -- it is in a private part (the message generated will note that it
+ -- is in a private part).
else
return True;
@@ -5606,8 +5780,8 @@ package body Sem_Ch8 is
-- If we don't know now, generate reference later
- when Unknown =>
- Deferred_References.Append ((E, N));
+ when Unknown =>
+ Deferred_References.Append ((E, N));
end case;
end if;
end if;
@@ -5675,12 +5849,13 @@ package body Sem_Ch8 is
Par := Nod;
while Present (Par) loop
if Nkind (Par) = N_Pragma then
- if Nam_In (Pragma_Name (Par), Name_Abstract_State,
- Name_Depends,
- Name_Global,
- Name_Initializes,
- Name_Refined_Depends,
- Name_Refined_Global)
+ if Nam_In (Pragma_Name_Unmapped (Par),
+ Name_Abstract_State,
+ Name_Depends,
+ Name_Global,
+ Name_Initializes,
+ Name_Refined_Depends,
+ Name_Refined_Global)
then
return True;
@@ -6096,8 +6271,8 @@ package body Sem_Ch8 is
null;
else
Error_Msg_N
- ("limited withed package can only be used to access "
- & "incomplete types", N);
+ ("limited withed package can only be used to access incomplete "
+ & "types", N);
end if;
end if;
@@ -6149,8 +6324,10 @@ package body Sem_Ch8 is
case Is_LHS (N) is
when Yes =>
Generate_Reference (Id, N, 'm');
+
when No =>
Generate_Reference (Id, N, 'r');
+
when Unknown =>
Deferred_References.Append ((Id, N));
end case;
@@ -6224,6 +6401,8 @@ package body Sem_Ch8 is
if Is_Overloadable (Id) and then not Is_Overloaded (N) then
Generate_Reference (Id, N);
end if;
+
+ Check_Restriction_No_Use_Of_Entity (N);
end Find_Expanded_Name;
-------------------------
@@ -6439,7 +6618,10 @@ package body Sem_Ch8 is
-- Non-overloaded case
else
- if Is_Actual and then Present (Enclosing_Instance) then
+ if Is_Actual
+ and then Present (Enclosing_Instance)
+ and then Entity_Matches_Spec (Entity (Nam), New_S)
+ then
Old_S := Entity (Nam);
elsif Entity_Matches_Spec (Entity (Nam), New_S) then
@@ -6729,17 +6911,27 @@ package body Sem_Ch8 is
-- The designated type may be a limited view with no components.
-- Check whether the non-limited view is available, because in some
- -- cases this will not be set when installing the context.
+ -- cases this will not be set when installing the context. Rewrite
+ -- the node by introducing an explicit dereference at once, and
+ -- setting the type of the rewritten prefix to the non-limited view
+ -- of the original designated type.
if Is_Access_Type (P_Type) then
declare
- D : constant Entity_Id := Directly_Designated_Type (P_Type);
+ Desig_Typ : constant Entity_Id :=
+ Directly_Designated_Type (P_Type);
+
begin
- if Is_Incomplete_Type (D)
- and then From_Limited_With (D)
- and then Present (Non_Limited_View (D))
+ if Is_Incomplete_Type (Desig_Typ)
+ and then From_Limited_With (Desig_Typ)
+ and then Present (Non_Limited_View (Desig_Typ))
then
- Set_Directly_Designated_Type (P_Type, Non_Limited_View (D));
+ Rewrite (P,
+ Make_Explicit_Dereference (Sloc (P),
+ Prefix => Relocate_Node (P)));
+
+ Set_Etype (P, Get_Full_View (Non_Limited_View (Desig_Typ)));
+ P_Type := Etype (P);
end if;
end;
end if;
@@ -6906,14 +7098,14 @@ package body Sem_Ch8 is
Save_Interps (P, Nam);
-- We use Replace here because this is one of those cases
- -- where the parser has missclassified the node, and we
- -- fix things up and then do the semantic analysis on the
- -- fixed up node. Normally we do this using one of the
- -- Sinfo.CN routines, but this is too tricky for that.
+ -- where the parser has missclassified the node, and we fix
+ -- things up and then do the semantic analysis on the fixed
+ -- up node. Normally we do this using one of the Sinfo.CN
+ -- routines, but this is too tricky for that.
- -- Note that using Rewrite would be wrong, because we
- -- would have a tree where the original node is unanalyzed,
- -- and this violates the required interface for ASIS.
+ -- Note that using Rewrite would be wrong, because we would
+ -- have a tree where the original node is unanalyzed, and
+ -- this violates the required interface for ASIS.
Replace (P,
Make_Function_Call (Sloc (P), Name => Nam));
@@ -6921,7 +7113,18 @@ package body Sem_Ch8 is
-- Now analyze the reformatted node
Analyze_Call (P);
- Analyze_Selected_Component (N);
+
+ -- If the prefix is illegal after this transformation, there
+ -- may be visibility errors on the prefix. The safest is to
+ -- treat the selected component as an error.
+
+ if Error_Posted (P) then
+ Set_Etype (N, Any_Type);
+ return;
+
+ else
+ Analyze_Selected_Component (N);
+ end if;
end if;
end if;
@@ -6930,14 +7133,24 @@ package body Sem_Ch8 is
else
-- Format node as expanded name, to avoid cascaded errors
+ -- If the limited_with transformation was applied earlier, restore
+ -- source for proper error reporting.
+
+ if not Comes_From_Source (P)
+ and then Nkind (P) = N_Explicit_Dereference
+ then
+ Rewrite (P, Prefix (P));
+ P_Type := Etype (P);
+ end if;
+
Change_Selected_Component_To_Expanded_Name (N);
- Set_Entity (N, Any_Id);
- Set_Etype (N, Any_Type);
+ Set_Entity (N, Any_Id);
+ Set_Etype (N, Any_Type);
-- Issue error message, but avoid this if error issued already.
-- Use identifier of prefix if one is available.
- if P_Name = Any_Id then
+ if P_Name = Any_Id then
null;
-- It is not an error if the prefix is the current instance of
@@ -6953,7 +7166,8 @@ package body Sem_Ch8 is
elsif Nkind (P) /= N_Attribute_Reference then
-- This may have been meant as a prefixed call to a primitive
- -- of an untagged type.
+ -- of an untagged type. If it is a function call check type of
+ -- its first formal and add explanation.
declare
F : constant Entity_Id :=
@@ -6962,12 +7176,11 @@ package body Sem_Ch8 is
if Present (F)
and then Is_Overloadable (F)
and then Present (First_Entity (F))
- and then Etype (First_Entity (F)) = Etype (P)
- and then not Is_Tagged_Type (Etype (P))
+ and then not Is_Tagged_Type (Etype (First_Entity (F)))
then
Error_Msg_N
- ("prefixed call is only allowed for objects "
- & "of a tagged type", N);
+ ("prefixed call is only allowed for objects of a "
+ & "tagged type", N);
end if;
end;
@@ -7525,8 +7738,12 @@ package body Sem_Ch8 is
-- contains a declaration for a derived Boolean type, or for an
-- array of Boolean type.
- when Name_Op_And | Name_Op_Not | Name_Op_Or | Name_Op_Xor =>
- while Id /= Priv_Id loop
+ when Name_Op_And
+ | Name_Op_Not
+ | Name_Op_Or
+ | Name_Op_Xor
+ =>
+ while Id /= Priv_Id loop
if Valid_Boolean_Arg (Id) and then Is_Base_Type (Id) then
Add_Implicit_Operator (Id);
return True;
@@ -7537,8 +7754,10 @@ package body Sem_Ch8 is
-- Equality: look for any non-limited type (result is Boolean)
- when Name_Op_Eq | Name_Op_Ne =>
- while Id /= Priv_Id loop
+ when Name_Op_Eq
+ | Name_Op_Ne
+ =>
+ while Id /= Priv_Id loop
if Is_Type (Id)
and then not Is_Limited_Type (Id)
and then Is_Base_Type (Id)
@@ -7552,8 +7771,12 @@ package body Sem_Ch8 is
-- Comparison operators: scalar type, or array of scalar
- when Name_Op_Lt | Name_Op_Le | Name_Op_Gt | Name_Op_Ge =>
- while Id /= Priv_Id loop
+ when Name_Op_Ge
+ | Name_Op_Gt
+ | Name_Op_Le
+ | Name_Op_Lt
+ =>
+ while Id /= Priv_Id loop
if (Is_Scalar_Type (Id)
or else (Is_Array_Type (Id)
and then Is_Scalar_Type (Component_Type (Id))))
@@ -7568,15 +7791,16 @@ package body Sem_Ch8 is
-- Arithmetic operators: any numeric type
- when Name_Op_Abs |
- Name_Op_Add |
- Name_Op_Mod |
- Name_Op_Rem |
- Name_Op_Subtract |
- Name_Op_Multiply |
- Name_Op_Divide |
- Name_Op_Expon =>
- while Id /= Priv_Id loop
+ when Name_Op_Abs
+ | Name_Op_Add
+ | Name_Op_Divide
+ | Name_Op_Expon
+ | Name_Op_Mod
+ | Name_Op_Multiply
+ | Name_Op_Rem
+ | Name_Op_Subtract
+ =>
+ while Id /= Priv_Id loop
if Is_Numeric_Type (Id) and then Is_Base_Type (Id) then
Add_Implicit_Operator (Id);
return True;
@@ -7588,7 +7812,7 @@ package body Sem_Ch8 is
-- Concatenation: any one-dimensional array type
when Name_Op_Concat =>
- while Id /= Priv_Id loop
+ while Id /= Priv_Id loop
if Is_Array_Type (Id)
and then Number_Dimensions (Id) = 1
and then Is_Base_Type (Id)
@@ -7603,13 +7827,13 @@ package body Sem_Ch8 is
-- What is the others condition here? Should we be using a
-- subtype of Name_Id that would restrict to operators ???
- when others => null;
+ when others =>
+ null;
end case;
-- If we fall through, then we do not have an implicit operator
return False;
-
end Has_Implicit_Operator;
-----------------------------------
@@ -7711,9 +7935,9 @@ package body Sem_Ch8 is
New_T := Etype (New_F);
Old_T := Etype (Old_F);
- -- If the new type is a renaming of the old one, as is the
- -- case for actuals in instances, retain its name, to simplify
- -- later disambiguation.
+ -- If the new type is a renaming of the old one, as is the case
+ -- for actuals in instances, retain its name, to simplify later
+ -- disambiguation.
if Nkind (Parent (New_T)) = N_Subtype_Declaration
and then Is_Entity_Name (Subtype_Indication (Parent (New_T)))
@@ -7728,6 +7952,8 @@ package body Sem_Ch8 is
Next_Formal (Old_F);
end loop;
+ pragma Assert (No (Old_F));
+
if Ekind_In (Old_S, E_Function, E_Enumeration_Literal) then
Set_Etype (New_S, Etype (Old_S));
end if;
@@ -8162,10 +8388,22 @@ package body Sem_Ch8 is
SST.Save_Default_SSO := Default_SSO;
SST.Save_Uneval_Old := Uneval_Old;
+ -- Each new scope pushed onto the scope stack inherits the component
+ -- alignment of the previous scope. This emulates the "visibility"
+ -- semantics of pragma Component_Alignment.
+
if Scope_Stack.Last > Scope_Stack.First then
- SST.Component_Alignment_Default := Scope_Stack.Table
- (Scope_Stack.Last - 1).
- Component_Alignment_Default;
+ SST.Component_Alignment_Default :=
+ Scope_Stack.Table
+ (Scope_Stack.Last - 1). Component_Alignment_Default;
+
+ -- Otherwise, this is the first scope being pushed on the scope
+ -- stack. Inherit the component alignment from the configuration
+ -- form of pragma Component_Alignment (if any).
+
+ else
+ SST.Component_Alignment_Default :=
+ Configuration_Component_Alignment;
end if;
SST.Last_Subprogram_Name := null;
@@ -8590,7 +8828,7 @@ package body Sem_Ch8 is
Next (Pack_Name);
end loop;
- elsif Nkind (Decl) = N_Use_Type_Clause then
+ elsif Nkind (Decl) = N_Use_Type_Clause then
Chain_Use_Clause (Decl);
Id := First (Subtype_Marks (Decl));
@@ -9132,7 +9370,7 @@ package body Sem_Ch8 is
Ent1 := Entity_Of_Unit (Unit1);
Ent2 := Entity_Of_Unit (Unit2);
- if Scope (Ent2) = Standard_Standard then
+ if Scope (Ent2) = Standard_Standard then
Error_Msg_Sloc := Sloc (Current_Use_Clause (T));
Err_No := Clause1;
diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb
index bbb801824b..efca9fcd8f 100644
--- a/gcc/ada/sem_ch9.adb
+++ b/gcc/ada/sem_ch9.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -32,8 +32,10 @@ with Einfo; use Einfo;
with Errout; use Errout;
with Exp_Ch9; use Exp_Ch9;
with Elists; use Elists;
+with Fname; use Fname;
with Freeze; use Freeze;
with Layout; use Layout;
+with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
with Namet; use Namet;
with Nlists; use Nlists;
@@ -290,14 +292,14 @@ package body Sem_Ch9 is
pragma Assert (Nkind (Attr) = N_Attribute_Reference);
case Attribute_Name (Attr) is
- when Name_Min |
- Name_Max |
- Name_Pred |
- Name_Succ |
- Name_Value |
- Name_Wide_Value |
- Name_Wide_Wide_Value =>
-
+ when Name_Max
+ | Name_Min
+ | Name_Pred
+ | Name_Succ
+ | Name_Value
+ | Name_Wide_Value
+ | Name_Wide_Wide_Value
+ =>
-- A language-defined attribute denotes a static
-- function if the prefix denotes a static scalar
-- subtype, and if the parameter and result types
@@ -324,7 +326,8 @@ package body Sem_Ch9 is
return False;
end if;
- when others => return False;
+ when others =>
+ return False;
end case;
end Is_Static_Function;
@@ -496,9 +499,10 @@ package body Sem_Ch9 is
elsif Kind = N_Pragma then
declare
- Prag_Name : constant Name_Id := Pragma_Name (N);
+ Prag_Name : constant Name_Id :=
+ Pragma_Name (N);
Prag_Id : constant Pragma_Id :=
- Get_Pragma_Id (Prag_Name);
+ Get_Pragma_Id (Prag_Name);
begin
if Prag_Id = Pragma_Export
@@ -889,13 +893,18 @@ package body Sem_Ch9 is
loop
P := Parent (P);
case Nkind (P) is
- when N_Task_Body | N_Compilation_Unit =>
+ when N_Compilation_Unit
+ | N_Task_Body
+ =>
exit;
+
when N_Asynchronous_Select =>
- Error_Msg_N ("accept statements are not allowed within" &
- " an asynchronous select inner" &
- " to the enclosing task body", N);
+ Error_Msg_N
+ ("accept statements are not allowed within an "
+ & "asynchronous select inner to the enclosing task body",
+ N);
exit;
+
when others =>
null;
end case;
@@ -1145,6 +1154,7 @@ package body Sem_Ch9 is
procedure Analyze_Delay_Relative (N : Node_Id) is
E : constant Node_Id := Expression (N);
+
begin
Tasking_Used := True;
Check_SPARK_05_Restriction ("delay statement is not allowed", N);
@@ -1153,6 +1163,19 @@ package body Sem_Ch9 is
Check_Potentially_Blocking_Operation (N);
Analyze_And_Resolve (E, Standard_Duration);
Check_Restriction (No_Fixed_Point, E);
+
+ -- In SPARK mode the relative delay statement introduces an implicit
+ -- dependency on the Ada.Real_Time.Clock_Time abstract state, so we must
+ -- force the loading of the Ada.Real_Time package.
+
+ if GNATprove_Mode then
+ declare
+ Unused : Entity_Id;
+
+ begin
+ Unused := RTE (RO_RT_Time);
+ end;
+ end if;
end Analyze_Delay_Relative;
-------------------------
@@ -1168,7 +1191,7 @@ package body Sem_Ch9 is
Check_SPARK_05_Restriction ("delay statement is not allowed", N);
Check_Restriction (No_Delay, N);
Check_Potentially_Blocking_Operation (N);
- Analyze (E);
+ Analyze_And_Resolve (E);
Typ := First_Subtype (Etype (E));
if not Is_RTE (Typ, RO_CA_Time) and then
@@ -1666,7 +1689,7 @@ package body Sem_Ch9 is
-- The Defining_Identifier of the entry index specification is local to the
-- entry body, but it must be available in the entry barrier which is
-- evaluated outside of the entry body. The index is eventually renamed as
- -- a run-time object, so is visibility is strictly a front-end concern. In
+ -- a run-time object, so its visibility is strictly a front-end concern. In
-- order to make it available to the barrier, we create an additional
-- scope, as for a loop, whose only declaration is the index name. This
-- loop is not attached to the tree and does not appear as an entity local
@@ -1873,7 +1896,9 @@ package body Sem_Ch9 is
-- composite types with inner components, we traverse recursively
-- the private components of the protected type, and indicate that
-- all itypes within are frozen. This ensures that no freeze nodes
- -- will be generated for them.
+ -- will be generated for them. In the case of itypes that are access
+ -- types we need to complete their representation by calling layout,
+ -- which would otherwise be invoked when freezing a type.
--
-- On the other hand, components of the corresponding record are
-- frozen (or receive itype references) as for other records.
@@ -1901,6 +1926,10 @@ package body Sem_Ch9 is
Set_Has_Delayed_Freeze (Comp, False);
Set_Is_Frozen (Comp);
+ if Is_Access_Type (Comp) then
+ Layout_Type (Comp);
+ end if;
+
if Is_Record_Type (Comp)
or else Is_Protected_Type (Comp)
then
@@ -1937,16 +1966,8 @@ package body Sem_Ch9 is
while Present (E) loop
if Ekind_In (E, E_Function, E_Procedure) then
Set_Convention (E, Convention_Protected);
-
- elsif Is_Task_Type (Etype (E))
- or else Has_Task (Etype (E))
- then
- Set_Has_Task (Current_Scope);
-
- elsif Is_Protected_Type (Etype (E))
- or else Has_Protected (Etype (E))
- then
- Set_Has_Protected (Current_Scope);
+ else
+ Propagate_Concurrent_Flags (Current_Scope, Etype (E));
end if;
Next_Entity (E);
@@ -1992,13 +2013,29 @@ package body Sem_Ch9 is
end if;
Set_Ekind (T, E_Protected_Type);
- Set_Is_First_Subtype (T, True);
- Set_Has_Protected (T, True);
+ Set_Is_First_Subtype (T);
Init_Size_Align (T);
Set_Etype (T, T);
- Set_Has_Delayed_Freeze (T, True);
+ Set_Has_Delayed_Freeze (T);
Set_Stored_Constraint (T, No_Elist);
+ -- Mark this type as a protected type for the sake of restrictions,
+ -- unless the protected type is declared in a private part of a package
+ -- of the runtime. With this exception, the Suspension_Object from
+ -- Ada.Synchronous_Task_Control can be implemented using a protected
+ -- object without triggering violations of No_Local_Protected_Objects
+ -- when the user locally declares such an object. This may look like a
+ -- trick, but the user doesn't have to know how Suspension_Object is
+ -- implemented.
+
+ if In_Private_Part (Current_Scope)
+ and then Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit))
+ then
+ Set_Has_Protected (T, False);
+ else
+ Set_Has_Protected (T);
+ end if;
+
-- Set the SPARK_Mode from the current context (may be overwritten later
-- with an explicit pragma).
@@ -2027,11 +2064,21 @@ package body Sem_Ch9 is
Set_Is_Constrained (T, not Has_Discriminants (T));
- -- If aspects are present, analyze them now. They can make references
- -- to the discriminants of the type, but not to any components.
+ -- If aspects are present, analyze them now. They can make references to
+ -- the discriminants of the type, but not to any components.
if Has_Aspects (N) then
- Analyze_Aspect_Specifications (N, Def_Id);
+
+ -- The protected type is the full view of a private type. Analyze the
+ -- aspects with the entity of the private type to ensure that after
+ -- both views are exchanged, the aspect are actually associated with
+ -- the full view.
+
+ if T /= Def_Id and then Is_Private_Type (Def_Id) then
+ Analyze_Aspect_Specifications (N, T);
+ else
+ Analyze_Aspect_Specifications (N, Def_Id);
+ end if;
end if;
Analyze (Protected_Definition (N));
@@ -2064,6 +2111,7 @@ package body Sem_Ch9 is
if (Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False
or else Number_Entries (T) > 1)
+ and then not Restricted_Profile
and then
(Has_Entries (T)
or else Has_Interrupt_Handler (T)
@@ -2184,6 +2232,16 @@ package body Sem_Ch9 is
Set_Must_Have_Preelab_Init (T);
end if;
+ -- Propagate Default_Initial_Condition-related attributes from the
+ -- private type to the protected type.
+
+ Propagate_DIC_Attributes (T, From_Typ => Def_Id);
+
+ -- Propagate invariant-related attributes from the private type to
+ -- the protected type.
+
+ Propagate_Invariant_Attributes (T, From_Typ => Def_Id);
+
-- Create corresponding record now, because some private dependents
-- may be subtypes of the partial view.
@@ -2199,6 +2257,19 @@ package body Sem_Ch9 is
Process_Full_View (N, T, Def_Id);
end if;
end if;
+
+ -- In GNATprove mode, force the loading of a Interrupt_Priority, which
+ -- is required for the ceiling priority protocol checks trigerred by
+ -- calls originating from protected subprograms and entries.
+
+ if GNATprove_Mode then
+ declare
+ Unused : Entity_Id;
+
+ begin
+ Unused := RTE (RE_Interrupt_Priority);
+ end;
+ end if;
end Analyze_Protected_Type_Declaration;
---------------------
@@ -2685,7 +2756,6 @@ package body Sem_Ch9 is
Enter_Name (Obj_Id);
Set_Ekind (Obj_Id, E_Variable);
Set_Etype (Obj_Id, Typ);
- Set_Part_Of_Constituents (Obj_Id, New_Elmt_List);
Set_SPARK_Pragma (Obj_Id, SPARK_Mode_Pragma);
Set_SPARK_Pragma_Inherited (Obj_Id);
@@ -2772,7 +2842,6 @@ package body Sem_Ch9 is
Enter_Name (Obj_Id);
Set_Ekind (Obj_Id, E_Variable);
Set_Etype (Obj_Id, Typ);
- Set_Part_Of_Constituents (Obj_Id, New_Elmt_List);
Set_SPARK_Pragma (Obj_Id, SPARK_Mode_Pragma);
Set_SPARK_Pragma_Inherited (Obj_Id);
@@ -3063,7 +3132,17 @@ package body Sem_Ch9 is
Set_Is_Constrained (T, not Has_Discriminants (T));
if Has_Aspects (N) then
- Analyze_Aspect_Specifications (N, Def_Id);
+
+ -- The task type is the full view of a private type. Analyze the
+ -- aspects with the entity of the private type to ensure that after
+ -- both views are exchanged, the aspect are actually associated with
+ -- the full view.
+
+ if T /= Def_Id and then Is_Private_Type (Def_Id) then
+ Analyze_Aspect_Specifications (N, T);
+ else
+ Analyze_Aspect_Specifications (N, Def_Id);
+ end if;
end if;
if Present (Task_Definition (N)) then
@@ -3077,6 +3156,7 @@ package body Sem_Ch9 is
if Restriction_Check_Required (No_Task_Hierarchy)
and then not Is_Library_Level_Entity (T)
and then Comes_From_Source (T)
+ and then not CodePeer_Mode
then
Error_Msg_Sloc := Restrictions_Loc (No_Task_Hierarchy);
@@ -3093,9 +3173,8 @@ package body Sem_Ch9 is
-- Case of a completion of a private declaration
- if T /= Def_Id
- and then Is_Private_Type (Def_Id)
- then
+ if T /= Def_Id and then Is_Private_Type (Def_Id) then
+
-- Deal with preelaborable initialization. Note that this processing
-- is done by Process_Full_View, but as can be seen below, in this
-- case the call to Process_Full_View is skipped if any serious
@@ -3105,6 +3184,16 @@ package body Sem_Ch9 is
Set_Must_Have_Preelab_Init (T);
end if;
+ -- Propagate Default_Initial_Condition-related attributes from the
+ -- private type to the task type.
+
+ Propagate_DIC_Attributes (T, From_Typ => Def_Id);
+
+ -- Propagate invariant-related attributes from the private type to
+ -- task type.
+
+ Propagate_Invariant_Attributes (T, From_Typ => Def_Id);
+
-- Create corresponding record now, because some private dependents
-- may be subtypes of the partial view.
@@ -3120,6 +3209,19 @@ package body Sem_Ch9 is
Process_Full_View (N, T, Def_Id);
end if;
end if;
+
+ -- In GNATprove mode, force the loading of a Interrupt_Priority, which
+ -- is required for the ceiling priority protocol checks trigerred by
+ -- calls originating from tasks.
+
+ if GNATprove_Mode then
+ declare
+ Unused : Entity_Id;
+
+ begin
+ Unused := RTE (RE_Interrupt_Priority);
+ end;
+ end if;
end Analyze_Task_Type_Declaration;
-----------------------------------
diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb
index 5067698736..2c57bcb522 100644
--- a/gcc/ada/sem_dim.adb
+++ b/gcc/ada/sem_dim.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1120,10 +1120,24 @@ package body Sem_Dim is
procedure Analyze_Dimension (N : Node_Id) is
begin
-- Aspect is an Ada 2012 feature. Note that there is no need to check
- -- dimensions for nodes that don't come from source.
+ -- dimensions for nodes that don't come from source, except for subtype
+ -- declarations where the dimensions are inherited from the base type,
+ -- for explicit dereferences generated when expanding iterators, and
+ -- for object declarations generated for inlining.
- if Ada_Version < Ada_2012 or else not Comes_From_Source (N) then
+ if Ada_Version < Ada_2012 then
return;
+
+ elsif not Comes_From_Source (N) then
+ if Nkind_In (N, N_Explicit_Dereference,
+ N_Identifier,
+ N_Object_Declaration,
+ N_Subtype_Declaration)
+ then
+ null;
+ else
+ return;
+ end if;
end if;
case Nkind (N) is
@@ -1139,19 +1153,27 @@ package body Sem_Dim is
when N_Extended_Return_Statement =>
Analyze_Dimension_Extended_Return_Statement (N);
- when N_Attribute_Reference |
- N_Expanded_Name |
- N_Explicit_Dereference |
- N_Function_Call |
- N_Identifier |
- N_Indexed_Component |
- N_Qualified_Expression |
- N_Selected_Component |
- N_Slice |
- N_Type_Conversion |
- N_Unchecked_Type_Conversion =>
+ when N_Attribute_Reference
+ | N_Expanded_Name
+ | N_Explicit_Dereference
+ | N_Function_Call
+ | N_Indexed_Component
+ | N_Qualified_Expression
+ | N_Selected_Component
+ | N_Slice
+ | N_Type_Conversion
+ | N_Unchecked_Type_Conversion
+ =>
Analyze_Dimension_Has_Etype (N);
+ -- In the presence of a repaired syntax error, an identifier
+ -- may be introduced without a usable type.
+
+ when N_Identifier =>
+ if Present (Etype (N)) then
+ Analyze_Dimension_Has_Etype (N);
+ end if;
+
when N_Number_Declaration =>
Analyze_Dimension_Number_Declaration (N);
@@ -1172,8 +1194,8 @@ package body Sem_Dim is
when N_Unary_Op =>
Analyze_Dimension_Unary_Op (N);
- when others => null;
-
+ when others =>
+ null;
end case;
end Analyze_Dimension;
@@ -1235,10 +1257,12 @@ package body Sem_Dim is
-- since it may not be decorated at this point. We also don't want to
-- issue the same error message multiple times on the same expression
-- (may happen when an aggregate is converted into a positional
- -- aggregate).
+ -- aggregate). We also must verify that this is a scalar component,
+ -- and not a subaggregate of a multidimensional aggregate.
if Comes_From_Source (Original_Node (Expr))
and then Present (Etype (Expr))
+ and then Is_Numeric_Type (Etype (Expr))
and then Dimensions_Of (Expr) /= Dims_Of_Comp_Typ
and then Sloc (Comp) /= Sloc (Prev (Comp))
then
@@ -2000,14 +2024,17 @@ package body Sem_Dim is
end if;
end if;
- -- Removal of dimensions in expression
+ -- Remove dimensions from inner expressions, to prevent dimensions
+ -- table from growing uselessly.
case Nkind (N) is
- when N_Attribute_Reference |
- N_Indexed_Component =>
+ when N_Attribute_Reference
+ | N_Indexed_Component
+ =>
declare
- Expr : Node_Id;
Exprs : constant List_Id := Expressions (N);
+ Expr : Node_Id;
+
begin
if Present (Exprs) then
Expr := First (Exprs);
@@ -2018,15 +2045,17 @@ package body Sem_Dim is
end if;
end;
- when N_Qualified_Expression |
- N_Type_Conversion |
- N_Unchecked_Type_Conversion =>
+ when N_Qualified_Expression
+ | N_Type_Conversion
+ | N_Unchecked_Type_Conversion
+ =>
Remove_Dimensions (Expression (N));
when N_Selected_Component =>
Remove_Dimensions (Selector_Name (N));
- when others => null;
+ when others =>
+ null;
end case;
end Analyze_Dimension_Has_Etype;
@@ -2115,7 +2144,8 @@ package body Sem_Dim is
end if;
end if;
- -- Removal of dimensions in expression
+ -- Remove dimensions in expression after checking consistency
+ -- with given type.
Remove_Dimensions (Expr);
end if;
@@ -2223,10 +2253,10 @@ package body Sem_Dim is
if Exists (Dims_Of_Etyp) then
- -- If subtype already has a dimension (from Aspect_Dimension),
- -- it cannot inherit a dimension from its subtype.
+ -- If subtype already has a dimension (from Aspect_Dimension), it
+ -- cannot inherit different dimensions from its subtype.
- if Exists (Dims_Of_Id) then
+ if Exists (Dims_Of_Id) and then Dims_Of_Etyp /= Dims_Of_Id then
Error_Msg_NE
("subtype& already " & Dimensions_Msg_Of (Id, True), N, Id);
else
@@ -2255,21 +2285,45 @@ package body Sem_Dim is
procedure Analyze_Dimension_Unary_Op (N : Node_Id) is
begin
case Nkind (N) is
- when N_Op_Plus | N_Op_Minus | N_Op_Abs =>
- -- Propagate the dimension if the operand is not dimensionless
+ -- Propagate the dimension if the operand is not dimensionless
+ when N_Op_Abs
+ | N_Op_Minus
+ | N_Op_Plus
+ =>
declare
R : constant Node_Id := Right_Opnd (N);
begin
Move_Dimensions (R, N);
end;
- when others => null;
-
+ when others =>
+ null;
end case;
end Analyze_Dimension_Unary_Op;
+ ---------------------------------
+ -- Check_Expression_Dimensions --
+ ---------------------------------
+
+ procedure Check_Expression_Dimensions
+ (Expr : Node_Id;
+ Typ : Entity_Id)
+ is
+ begin
+ if Is_Floating_Point_Type (Etype (Expr)) then
+ Analyze_Dimension (Expr);
+
+ if Dimensions_Of (Expr) /= Dimensions_Of (Typ) then
+ Error_Msg_N ("dimensions mismatch in array aggregate", Expr);
+ Error_Msg_N
+ ("\expected dimension " & Dimensions_Msg_Of (Typ)
+ & ", found " & Dimensions_Msg_Of (Expr), Expr);
+ end if;
+ end if;
+ end Check_Expression_Dimensions;
+
---------------------
-- Copy_Dimensions --
---------------------
@@ -3463,22 +3517,14 @@ package body Sem_Dim is
function Belong_To_Numeric_Literal (C : Character) return Boolean is
begin
case C is
- when '0' .. '9' |
- '_' |
- '.' |
- 'e' |
- '#' |
- 'A' |
- 'B' |
- 'C' |
- 'D' |
- 'E' |
- 'F' =>
+ when '0' .. '9'
+ | '_' | '.' | 'e' | '#' | 'A' | 'B' | 'C' | 'D' | 'E' | 'F'
+ =>
return True;
-- Make sure '+' or '-' is part of an exponent.
- when '+' | '-' =>
+ when '+' | '-' =>
declare
Prev_C : constant Character := Sbuffer (Src_Ptr - 1);
begin
@@ -3487,7 +3533,7 @@ package body Sem_Dim is
-- All other character doesn't belong to a numeric literal
- when others =>
+ when others =>
return False;
end case;
end Belong_To_Numeric_Literal;
diff --git a/gcc/ada/sem_dim.ads b/gcc/ada/sem_dim.ads
index d1521e9082..44f4e86fce 100644
--- a/gcc/ada/sem_dim.ads
+++ b/gcc/ada/sem_dim.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -164,6 +164,16 @@ package Sem_Dim is
-- For sub spec N, issue a warning for each dimensioned formal with a
-- literal default value in the list of formals Formals.
+ procedure Check_Expression_Dimensions
+ (Expr : Node_Id;
+ Typ : Entity_Id);
+ -- Compute dimensions of a floating-point expression and compare them with
+ -- the dimensions of a the given type. Used to verify dimensions of the
+ -- components of a multidimensional array type, for which components are
+ -- typically themselves arrays. The resolution of such arrays delays the
+ -- resolution of the ultimate components to a separate phase, which forces
+ -- this separate dimension verification.
+
procedure Copy_Dimensions (From, To : Node_Id);
-- Copy dimension vector of node From to node To. Note that To must be a
-- node that is allowed to contain a dimension (see OK_For_Dimension in
diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb
index d2396a3746..ef1a20b151 100644
--- a/gcc/ada/sem_disp.adb
+++ b/gcc/ada/sem_disp.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -234,7 +234,13 @@ package body Sem_Disp is
Formal);
end if;
- elsif not Subtypes_Statically_Match (Typ, Etype (Formal)) then
+ -- Within a predicate function, the formal may be a subtype
+ -- of a tagged type, given that the predicate is expressed
+ -- in terms of the subtype.
+
+ elsif not Subtypes_Statically_Match (Typ, Etype (Formal))
+ and then not Is_Predicate_Function (Subp)
+ then
Error_Msg_N
("parameter subtype does not match controlling type",
Formal);
@@ -409,7 +415,7 @@ package body Sem_Disp is
-- fact direct. This routine detects the above case and modifies the
-- call accordingly.
- procedure Check_Dispatching_Context;
+ procedure Check_Dispatching_Context (Call : Node_Id);
-- If the call is tag-indeterminate and the entity being called is
-- abstract, verify that the context is a call that will eventually
-- provide a tag for dispatching, or has provided one already.
@@ -508,10 +514,8 @@ package body Sem_Disp is
-- Check_Dispatching_Context --
-------------------------------
- procedure Check_Dispatching_Context is
- Subp : constant Entity_Id := Entity (Name (N));
- Typ : constant Entity_Id := Etype (Subp);
- Par : Node_Id;
+ procedure Check_Dispatching_Context (Call : Node_Id) is
+ Subp : constant Entity_Id := Entity (Name (Call));
procedure Abstract_Context_Error;
-- Error for abstract call dispatching on result is not dispatching
@@ -531,16 +535,21 @@ package body Sem_Disp is
else
Error_Msg_N
- ("call to abstract procedure must be dispatching",
- N);
+ ("call to abstract procedure must be dispatching", N);
end if;
end Abstract_Context_Error;
+ -- Local variables
+
+ Scop : constant Entity_Id := Current_Scope_No_Loops;
+ Typ : constant Entity_Id := Etype (Subp);
+ Par : Node_Id;
+
-- Start of processing for Check_Dispatching_Context
begin
if Is_Abstract_Subprogram (Subp)
- and then No (Controlling_Argument (N))
+ and then No (Controlling_Argument (Call))
then
if Present (Alias (Subp))
and then not Is_Abstract_Subprogram (Alias (Subp))
@@ -565,17 +574,20 @@ package body Sem_Disp is
-- but will be legal in overridings of the operation.
elsif In_Spec_Expression
- and then Is_Subprogram (Current_Scope)
and then
- ((Nkind (Parent (Current_Scope)) = N_Procedure_Specification
- and then Null_Present (Parent (Current_Scope)))
- or else Is_Abstract_Subprogram (Current_Scope))
+ (Is_Subprogram (Scop)
+ or else Chars (Scop) = Name_Postcondition)
+ and then
+ (Is_Abstract_Subprogram (Scop)
+ or else
+ (Nkind (Parent (Scop)) = N_Procedure_Specification
+ and then Null_Present (Parent (Scop))))
then
null;
elsif Ekind (Current_Scope) = E_Function
- and then Nkind (Unit_Declaration_Node (Current_Scope)) =
- N_Generic_Subprogram_Declaration
+ and then Nkind (Unit_Declaration_Node (Scop)) =
+ N_Generic_Subprogram_Declaration
then
null;
@@ -588,82 +600,110 @@ package body Sem_Disp is
if not Is_Tagged_Type (Typ)
and then not
- (Ekind (Typ) = E_Anonymous_Access_Type
- and then Is_Tagged_Type (Designated_Type (Typ)))
+ (Ekind (Typ) = E_Anonymous_Access_Type
+ and then Is_Tagged_Type (Designated_Type (Typ)))
then
Abstract_Context_Error;
return;
end if;
- Par := Parent (N);
+ Par := Parent (Call);
if Nkind (Par) = N_Parameter_Association then
Par := Parent (Par);
end if;
- while Present (Par) loop
- if Nkind_In (Par, N_Function_Call,
- N_Procedure_Call_Statement)
- and then Is_Entity_Name (Name (Par))
- then
- declare
- Enc_Subp : constant Entity_Id := Entity (Name (Par));
- A : Node_Id;
- F : Entity_Id;
-
- begin
- -- Find formal for which call is the actual, and is
- -- a controlling argument.
-
- F := First_Formal (Enc_Subp);
- A := First_Actual (Par);
-
- while Present (F) loop
- if Is_Controlling_Formal (F)
- and then (N = A or else Parent (N) = A)
- then
- return;
- end if;
+ if Nkind (Par) = N_Qualified_Expression
+ or else Nkind (Par) = N_Unchecked_Type_Conversion
+ then
+ Par := Parent (Par);
+ end if;
- Next_Formal (F);
- Next_Actual (A);
- end loop;
+ if Nkind_In (Par, N_Function_Call, N_Procedure_Call_Statement)
+ and then Is_Entity_Name (Name (Par))
+ then
+ declare
+ Enc_Subp : constant Entity_Id := Entity (Name (Par));
+ A : Node_Id;
+ F : Entity_Id;
+ Control : Entity_Id;
+ Ret_Type : Entity_Id;
- Error_Msg_N
- ("call to abstract function must be dispatching", N);
- return;
- end;
+ begin
+ -- Find controlling formal that can provide tag for the
+ -- tag-indeterminate actual. The corresponding actual
+ -- must be the corresponding class-wide type.
- -- For equalitiy operators, one of the operands must be
- -- statically or dynamically tagged.
+ F := First_Formal (Enc_Subp);
+ A := First_Actual (Par);
- elsif Nkind_In (Par, N_Op_Eq, N_Op_Ne) then
- if N = Right_Opnd (Par)
- and then Is_Tag_Indeterminate (Left_Opnd (Par))
- then
- Abstract_Context_Error;
+ -- Find controlling type of call. Dereference if function
+ -- returns an access type.
- elsif N = Left_Opnd (Par)
- and then Is_Tag_Indeterminate (Right_Opnd (Par))
- then
- Abstract_Context_Error;
+ Ret_Type := Etype (Call);
+ if Is_Access_Type (Etype (Call)) then
+ Ret_Type := Designated_Type (Ret_Type);
end if;
- return;
+ while Present (F) loop
+ Control := Etype (A);
- elsif Nkind (Par) = N_Assignment_Statement then
- return;
+ if Is_Access_Type (Control) then
+ Control := Designated_Type (Control);
+ end if;
+
+ if Is_Controlling_Formal (F)
+ and then not (Call = A or else Parent (Call) = A)
+ and then Control = Class_Wide_Type (Ret_Type)
+ then
+ return;
+ end if;
+
+ Next_Formal (F);
+ Next_Actual (A);
+ end loop;
+
+ if Nkind (Par) = N_Function_Call
+ and then Is_Tag_Indeterminate (Par)
+ then
+ -- The parent may be an actual of an enclosing call
+
+ Check_Dispatching_Context (Par);
+ return;
+
+ else
+ Error_Msg_N
+ ("call to abstract function must be dispatching",
+ Call);
+ return;
+ end if;
+ end;
- elsif Nkind (Par) = N_Qualified_Expression
- or else Nkind (Par) = N_Unchecked_Type_Conversion
+ -- For equality operators, one of the operands must be
+ -- statically or dynamically tagged.
+
+ elsif Nkind_In (Par, N_Op_Eq, N_Op_Ne) then
+ if N = Right_Opnd (Par)
+ and then Is_Tag_Indeterminate (Left_Opnd (Par))
then
- Par := Parent (Par);
+ Abstract_Context_Error;
- else
+ elsif N = Left_Opnd (Par)
+ and then Is_Tag_Indeterminate (Right_Opnd (Par))
+ then
Abstract_Context_Error;
- return;
end if;
- end loop;
+
+ return;
+
+ -- The left-hand side of an assignment provides the tag
+
+ elsif Nkind (Par) = N_Assignment_Statement then
+ return;
+
+ else
+ Abstract_Context_Error;
+ end if;
end if;
end if;
end Check_Dispatching_Context;
@@ -813,11 +853,12 @@ package body Sem_Disp is
Next_Formal (Formal);
end loop;
- Check_Dispatching_Context;
+ Check_Dispatching_Context (N);
+
+ elsif Nkind (N) /= N_Function_Call then
- else
-- The call is not dispatching, so check that there aren't any
- -- tag-indeterminate abstract calls left.
+ -- tag-indeterminate abstract calls left among its actuals.
Actual := First_Actual (N);
while Present (Actual) loop
@@ -836,7 +877,7 @@ package body Sem_Disp is
then
Func := Empty;
- -- Ditto if it is an explicit dereference.
+ -- Ditto if it is an explicit dereference
elsif Nkind (Original_Node (Actual)) = N_Explicit_Dereference
then
@@ -848,28 +889,41 @@ package body Sem_Disp is
else
Func :=
Entity (Name (Original_Node
- (Expression (Original_Node (Actual)))));
+ (Expression (Original_Node (Actual)))));
end if;
if Present (Func) and then Is_Abstract_Subprogram (Func) then
Error_Msg_N
- ("call to abstract function must be dispatching", N);
+ ("call to abstract function must be dispatching",
+ Actual);
end if;
end if;
Next_Actual (Actual);
end loop;
- Check_Dispatching_Context;
+ Check_Dispatching_Context (N);
+ return;
+
+ elsif Nkind (Parent (N)) in N_Subexpr then
+ Check_Dispatching_Context (N);
+
+ elsif Nkind (Parent (N)) = N_Assignment_Statement
+ and then Is_Class_Wide_Type (Etype (Name (Parent (N))))
+ then
+ return;
+
+ elsif Is_Abstract_Subprogram (Subp_Entity) then
+ Check_Dispatching_Context (N);
+ return;
end if;
else
-
-- If dispatching on result, the enclosing call, if any, will
-- determine the controlling argument. Otherwise this is the
-- primitive operation of the root type.
- Check_Dispatching_Context;
+ Check_Dispatching_Context (N);
end if;
end Check_Dispatching_Call;
@@ -878,13 +932,29 @@ package body Sem_Disp is
---------------------------------
procedure Check_Dispatching_Operation (Subp, Old_Subp : Entity_Id) is
- Tagged_Type : Entity_Id;
- Has_Dispatching_Parent : Boolean := False;
Body_Is_Last_Primitive : Boolean := False;
+ Has_Dispatching_Parent : Boolean := False;
Ovr_Subp : Entity_Id := Empty;
+ Tagged_Type : Entity_Id;
begin
- if not Ekind_In (Subp, E_Procedure, E_Function) then
+ if not Ekind_In (Subp, E_Function, E_Procedure) then
+ return;
+
+ -- The Default_Initial_Condition procedure is not a primitive subprogram
+ -- even if it relates to a tagged type. This routine is not meant to be
+ -- inherited or overridden.
+
+ elsif Is_DIC_Procedure (Subp) then
+ return;
+
+ -- The "partial" and "full" type invariant procedures are not primitive
+ -- subprograms even if they relate to a tagged type. These routines are
+ -- not meant to be inherited or overridden.
+
+ elsif Is_Invariant_Procedure (Subp)
+ or else Is_Partial_Invariant_Procedure (Subp)
+ then
return;
end if;
@@ -923,8 +993,8 @@ package body Sem_Disp is
-- if the associated tagged type is already frozen.
Has_Dispatching_Parent :=
- Present (Alias (Subp))
- and then Is_Dispatching_Operation (Alias (Subp));
+ Present (Alias (Subp))
+ and then Is_Dispatching_Operation (Alias (Subp));
if No (Tagged_Type) then
@@ -2084,7 +2154,7 @@ package body Sem_Disp is
-- table, but it would be awfully heavy, and there is no way that we
-- could reasonably exceed this value.
- N : Int := 0;
+ N : Nat := 0;
-- Number of entries in Result
Parent_Op : Entity_Id;
diff --git a/gcc/ada/sem_dist.adb b/gcc/ada/sem_dist.adb
index 5bb273bab2..fe94150816 100644
--- a/gcc/ada/sem_dist.adb
+++ b/gcc/ada/sem_dist.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -272,15 +272,19 @@ package body Sem_Dist is
---------------------------------
function Is_RACW_Stub_Type_Operation (Op : Entity_Id) return Boolean is
- Dispatching_Type : Entity_Id;
+ Typ : Entity_Id;
begin
case Ekind (Op) is
- when E_Function | E_Procedure =>
- Dispatching_Type := Find_Dispatching_Type (Op);
- return Present (Dispatching_Type)
- and then Is_RACW_Stub_Type (Dispatching_Type)
- and then not Is_Internal (Op);
+ when E_Function
+ | E_Procedure
+ =>
+ Typ := Find_Dispatching_Type (Op);
+
+ return
+ Present (Typ)
+ and then Is_RACW_Stub_Type (Typ)
+ and then not Is_Internal (Op);
when others =>
return False;
diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb
index 92118abdc8..89b21a0ef6 100644
--- a/gcc/ada/sem_elab.adb
+++ b/gcc/ada/sem_elab.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -91,16 +91,16 @@ package body Sem_Elab is
Table_Increment => 100,
Table_Name => "Elab_Visited");
- -- This table stores calls to Check_Internal_Call that are delayed
- -- until all generics are instantiated, and in particular that all
- -- generic bodies have been inserted. We need to delay, because we
- -- need to be able to look through the inserted bodies.
+ -- This table stores calls to Check_Internal_Call that are delayed until
+ -- all generics are instantiated and in particular until after all generic
+ -- bodies have been inserted. We need to delay, because we need to be able
+ -- to look through the inserted bodies.
type Delay_Element is record
N : Node_Id;
- -- The parameter N from the call to Check_Internal_Call. Note that
- -- this node may get rewritten over the delay period by expansion
- -- in the call case (but not in the instantiation case).
+ -- The parameter N from the call to Check_Internal_Call. Note that this
+ -- node may get rewritten over the delay period by expansion in the call
+ -- case (but not in the instantiation case).
E : Entity_Id;
-- The parameter E from the call to Check_Internal_Call
@@ -109,8 +109,11 @@ package body Sem_Elab is
-- The parameter Orig_Ent from the call to Check_Internal_Call
Curscop : Entity_Id;
- -- The current scope of the call. This is restored when we complete
- -- the delayed call, so that we do this in the right scope.
+ -- The current scope of the call. This is restored when we complete the
+ -- delayed call, so that we do this in the right scope.
+
+ From_SPARK_Code : Boolean;
+ -- Save indication of whether this call is under SPARK_Mode => On
From_Elab_Code : Boolean;
-- Save indication of whether this call is from elaboration code
@@ -128,7 +131,7 @@ package body Sem_Elab is
Table_Name => "Delay_Check");
C_Scope : Entity_Id;
- -- Top level scope of current scope. Compute this only once at the outer
+ -- Top-level scope of current scope. Compute this only once at the outer
-- level, i.e. for a call to Check_Elab_Call from outside this unit.
Outer_Level_Sloc : Source_Ptr;
@@ -304,7 +307,7 @@ package body Sem_Elab is
(Call : Node_Id;
Subp : Entity_Id;
Scop : Entity_Id);
- -- The current unit U may depend semantically on some unit P which is not
+ -- The current unit U may depend semantically on some unit P that is not
-- in the current context. If there is an elaboration call that reaches P,
-- we need to indicate that P requires an Elaborate_All, but this is not
-- effective in U's ali file, if there is no with_clause for P. In this
@@ -446,6 +449,15 @@ package body Sem_Elab is
return;
end if;
+ -- If an instance of a generic package contains a controlled object (so
+ -- we're calling Initialize at elaboration time), and the instance is in
+ -- a package body P that says "with P;", then we need to return without
+ -- adding "pragma Elaborate_All (P);" to P.
+
+ if U = Main_Unit_Entity then
+ return;
+ end if;
+
Itm := First (CI);
while Present (Itm) loop
if Nkind (Itm) = N_With_Clause then
@@ -495,10 +507,8 @@ package body Sem_Elab is
end if;
-- Here if we do not find with clause on spec or body. We just ignore
- -- this case, it means that the elaboration involves some other unit
+ -- this case; it means that the elaboration involves some other unit
-- than the unit being compiled, and will be caught elsewhere.
-
- null;
end Activate_Elaborate_All_Desirable;
------------------
@@ -516,11 +526,10 @@ package body Sem_Elab is
Access_Case : constant Boolean := Nkind (N) = N_Attribute_Reference;
-- Indicates if we have Access attribute case
- Variable_Case : constant Boolean :=
- Nkind (N) in N_Has_Entity
- and then Present (Entity (N))
- and then Ekind (Entity (N)) = E_Variable;
- -- Indicates if we have variable reference case
+ function Call_To_Instance_From_Outside (Id : Entity_Id) return Boolean;
+ -- True if we're calling an instance of a generic subprogram, or a
+ -- subprogram in an instance of a generic package, and the call is
+ -- outside that instance.
procedure Elab_Warning
(Msg_D : String;
@@ -529,7 +538,36 @@ package body Sem_Elab is
-- Generate a call to Error_Msg_NE with parameters Msg_D or Msg_S (for
-- dynamic or static elaboration model), N and Ent. Msg_D is a real
-- warning (output if Msg_D is non-null and Elab_Warnings is set),
- -- Msg_S is an info message (output if Elab_Info_Messages is set.
+ -- Msg_S is an info message (output if Elab_Info_Messages is set).
+
+ function Find_W_Scope return Entity_Id;
+ -- Find top-level scope for called entity (not following renamings
+ -- or derivations). This is where the Elaborate_All will go if it is
+ -- needed. We start with the called entity, except in the case of an
+ -- initialization procedure outside the current package, where the init
+ -- proc is in the root package, and we start from the entity of the name
+ -- in the call.
+
+ -----------------------------------
+ -- Call_To_Instance_From_Outside --
+ -----------------------------------
+
+ function Call_To_Instance_From_Outside (Id : Entity_Id) return Boolean is
+ Scop : Entity_Id := Id;
+
+ begin
+ loop
+ if Scop = Standard_Standard then
+ return False;
+ end if;
+
+ if Is_Generic_Instance (Scop) then
+ return not In_Open_Scopes (Scop);
+ end if;
+
+ Scop := Scope (Scop);
+ end loop;
+ end Call_To_Instance_From_Outside;
------------------
-- Elab_Warning --
@@ -565,7 +603,39 @@ package body Sem_Elab is
end if;
end Elab_Warning;
- -- Local variables
+ ------------------
+ -- Find_W_Scope --
+ ------------------
+
+ function Find_W_Scope return Entity_Id is
+ Refed_Ent : constant Entity_Id := Get_Referenced_Ent (N);
+ W_Scope : Entity_Id;
+
+ begin
+ if Is_Init_Proc (Refed_Ent)
+ and then not In_Same_Extended_Unit (N, Refed_Ent)
+ then
+ W_Scope := Scope (Refed_Ent);
+ else
+ W_Scope := E;
+ end if;
+
+ -- Now loop through scopes to get to the enclosing compilation unit
+
+ while not Is_Compilation_Unit (W_Scope) loop
+ W_Scope := Scope (W_Scope);
+ end loop;
+
+ return W_Scope;
+ end Find_W_Scope;
+
+ -- Locals
+
+ Variable_Case : constant Boolean :=
+ Nkind (N) in N_Has_Entity
+ and then Present (Entity (N))
+ and then Ekind (Entity (N)) = E_Variable;
+ -- Indicates if we have variable reference case
Loc : constant Source_Ptr := Sloc (N);
@@ -592,7 +662,7 @@ package body Sem_Elab is
-- we ignore this flag.
E_Scope : Entity_Id;
- -- Top level scope of entity for called subprogram. This value includes
+ -- Top-level scope of entity for called subprogram. This value includes
-- following renamings and derivations, so this scope can be in a
-- non-visible unit. This is the scope that is to be investigated to
-- see whether an elaboration check is required.
@@ -605,8 +675,8 @@ package body Sem_Elab is
Issue_In_SPARK : Boolean;
-- Flag set when a source entity is called during elaboration in SPARK
- W_Scope : Entity_Id;
- -- Top level scope of directly called entity for subprogram. This
+ W_Scope : constant Entity_Id := Find_W_Scope;
+ -- Top-level scope of directly called entity for subprogram. This
-- differs from E_Scope in the case where renamings or derivations
-- are involved, since it does not follow these links. W_Scope is
-- generally in a visible unit, and it is this scope that may require
@@ -641,6 +711,13 @@ package body Sem_Elab is
return;
end if;
+ -- Intrinsics such as instances of Unchecked_Deallocation do not have
+ -- any body, so elaboration checking is not needed, and would be wrong.
+
+ if Is_Intrinsic_Subprogram (E) then
+ return;
+ end if;
+
-- Proceed with check
Ent := E;
@@ -710,17 +787,11 @@ package body Sem_Elab is
and then (Is_Child_Unit (E_Scope)
or else Scope (E_Scope) = Standard_Standard);
- -- If we did not find a compilation unit, other than standard,
- -- then nothing to check (happens in some instantiation cases)
-
- if E_Scope = Standard_Standard then
- return;
+ pragma Assert (E_Scope /= Standard_Standard);
- -- Otherwise move up a scope looking for compilation unit
+ -- Move up a scope looking for compilation unit
- else
- E_Scope := Scope (E_Scope);
- end if;
+ E_Scope := Scope (E_Scope);
end loop;
-- No checks needed for pure or preelaborated compilation units
@@ -748,29 +819,6 @@ package body Sem_Elab is
return;
end if;
- -- Find top level scope for called entity (not following renamings
- -- or derivations). This is where the Elaborate_All will go if it is
- -- needed. We start with the called entity, except in the case of an
- -- initialization procedure outside the current package, where the init
- -- proc is in the root package, and we start from the entity of the name
- -- in the call.
-
- declare
- Ent : constant Entity_Id := Get_Referenced_Ent (N);
- begin
- if Is_Init_Proc (Ent) and then not In_Same_Extended_Unit (N, Ent) then
- W_Scope := Scope (Ent);
- else
- W_Scope := E;
- end if;
- end;
-
- -- Now loop through scopes to get to the enclosing compilation unit
-
- while not Is_Compilation_Unit (W_Scope) loop
- W_Scope := Scope (W_Scope);
- end loop;
-
-- Case of entity is in same unit as call or instantiation. In the
-- instantiation case, W_Scope may be different from E_Scope; we want
-- the unit in which the instantiation occurs, since we're analyzing
@@ -799,11 +847,11 @@ package body Sem_Elab is
return;
end if;
- -- Nothing to do for a generic instance, because in this case the
- -- checking was at the point of instantiation of the generic However,
- -- this shortcut is only applicable in static mode.
+ -- Nothing to do for a generic instance, because a call to an instance
+ -- cannot fail the elaboration check, because the body of the instance
+ -- is always elaborated immediately after the spec.
- if Is_Generic_Instance (Ent) and not Dynamic_Elaboration_Checks then
+ if Call_To_Instance_From_Outside (Ent) then
return;
end if;
@@ -881,7 +929,7 @@ package body Sem_Elab is
-- If the call is in an instance, and the called entity is not
-- defined in the same instance, then the elaboration issue focuses
- -- around the unit containing the template, it is this unit which
+ -- around the unit containing the template, it is this unit that
-- requires an Elaborate_All.
-- However, if we are doing dynamic elaboration, we need to chase the
@@ -929,7 +977,7 @@ package body Sem_Elab is
-- For the case where N is not an instance, and is not a call within
-- instance to other than a generic formal, we recompute E_Scope
-- for the error message, since we do NOT want to go to the unit
- -- which has the ultimate declaration in the case of renaming and
+ -- that has the ultimate declaration in the case of renaming and
-- derivation and we also want to go to the generic unit in the
-- case of an instance, and no further.
@@ -958,10 +1006,10 @@ package body Sem_Elab is
Ent := Alias (Ent);
E_Scope := Ent;
- -- If no alias, there is a previous error
+ -- If no alias, there could be a previous error, but not if we've
+ -- already reached the outermost level (Standard).
if No (Ent) then
- Check_Error_Detected;
return;
end if;
end loop;
@@ -971,7 +1019,7 @@ package body Sem_Elab is
return;
end if;
- Is_DIC_Proc := Is_Nontrivial_Default_Init_Cond_Procedure (Ent);
+ Is_DIC_Proc := Is_Nontrivial_DIC_Procedure (Ent);
-- Elaboration issues in SPARK are reported only for source constructs
-- and for nontrivial Default_Initial_Condition procedures. The latter
@@ -980,7 +1028,9 @@ package body Sem_Elab is
-- expression, which in turn may have side effects.
Issue_In_SPARK :=
- SPARK_Mode = On and (Comes_From_Source (Ent) or Is_DIC_Proc);
+ SPARK_Mode = On
+ and then Dynamic_Elaboration_Checks
+ and then (Comes_From_Source (Ent) or Is_DIC_Proc);
-- Now check if an Elaborate_All (or dynamic check) is needed
@@ -1059,7 +1109,8 @@ package body Sem_Elab is
-- is an error, so give an error message.
if Issue_In_SPARK then
- Error_Msg_NE ("\Elaborate_All pragma required for&", N, W_Scope);
+ Error_Msg_NE -- CODEFIX
+ ("\Elaborate_All pragma required for&", N, W_Scope);
-- Otherwise we generate an implicit pragma. For a subprogram
-- instantiation, Elaborate is good enough, since no transitive
@@ -1143,7 +1194,7 @@ package body Sem_Elab is
null;
-- Do not generate an Elaborate_All for finalization routines
- -- which perform partial clean up as part of initialization.
+ -- that perform partial clean up as part of initialization.
elsif In_Init_Proc and then Is_Finalization_Procedure (Ent) then
null;
@@ -1233,8 +1284,8 @@ package body Sem_Elab is
-- then the body of the generic will be in the earlier instance.
declare
- D1 : constant Int := Instantiation_Depth (Sloc (Ent));
- D2 : constant Int := Instantiation_Depth (Sloc (N));
+ D1 : constant Nat := Instantiation_Depth (Sloc (Ent));
+ D2 : constant Nat := Instantiation_Depth (Sloc (N));
begin
if D1 > D2 then
@@ -1348,7 +1399,7 @@ package body Sem_Elab is
return;
end if;
- -- Here we have a reference at elaboration time which must be checked
+ -- Here we have a reference at elaboration time that must be checked
if Debug_Flag_LL then
Write_Str (" Check_Elab_Ref: ");
@@ -1548,7 +1599,7 @@ package body Sem_Elab is
-- Static model, call is not in elaboration code, we
-- never need to worry, because in the static model the
- -- top level caller always takes care of things.
+ -- top-level caller always takes care of things.
else
return;
@@ -1893,13 +1944,17 @@ package body Sem_Elab is
----------------------
procedure Check_Elab_Calls is
+ Save_SPARK_Mode : SPARK_Mode_Type;
+
begin
- -- If expansion is disabled, do not generate any checks. Also skip
+ -- If expansion is disabled, do not generate any checks, unless we
+ -- are in GNATprove mode, so that errors are issued in GNATprove for
+ -- violations of static elaboration rules in SPARK code. Also skip
-- checks if any subunits are missing because in either case we lack the
-- full information that we need, and no object file will be created in
-- any case.
- if not Expander_Active
+ if (not Expander_Active and not GNATprove_Mode)
or else Is_Generic_Unit (Cunit_Entity (Main_Unit))
or else Subunits_Missing
then
@@ -1916,12 +1971,21 @@ package body Sem_Elab is
Push_Scope (Delay_Check.Table (J).Curscop);
From_Elab_Code := Delay_Check.Table (J).From_Elab_Code;
+ -- Set appropriate value of SPARK_Mode
+
+ Save_SPARK_Mode := SPARK_Mode;
+
+ if Delay_Check.Table (J).From_SPARK_Code then
+ SPARK_Mode := On;
+ end if;
+
Check_Internal_Call_Continue (
N => Delay_Check.Table (J).N,
E => Delay_Check.Table (J).E,
Outer_Scope => Delay_Check.Table (J).Outer_Scope,
Orig_Ent => Delay_Check.Table (J).Orig_Ent);
+ SPARK_Mode := Save_SPARK_Mode;
Pop_Scope;
end loop;
@@ -2032,24 +2096,94 @@ package body Sem_Elab is
Outer_Scope : Entity_Id;
Orig_Ent : Entity_Id)
is
+ function Within_Initial_Condition (Call : Node_Id) return Boolean;
+ -- Determine whether call Call occurs within pragma Initial_Condition or
+ -- pragma Check with check_kind set to Initial_Condition.
+
+ ------------------------------
+ -- Within_Initial_Condition --
+ ------------------------------
+
+ function Within_Initial_Condition (Call : Node_Id) return Boolean is
+ Args : List_Id;
+ Nam : Name_Id;
+ Par : Node_Id;
+
+ begin
+ -- Traverse the parent chain looking for an enclosing pragma
+
+ Par := Call;
+ while Present (Par) loop
+ if Nkind (Par) = N_Pragma then
+ Nam := Pragma_Name (Par);
+
+ -- Pragma Initial_Condition appears in its alternative from as
+ -- Check (Initial_Condition, ...).
+
+ if Nam = Name_Check then
+ Args := Pragma_Argument_Associations (Par);
+
+ -- Pragma Check should have at least two arguments
+
+ pragma Assert (Present (Args));
+
+ return
+ Chars (Expression (First (Args))) = Name_Initial_Condition;
+
+ -- Direct match
+
+ elsif Nam = Name_Initial_Condition then
+ return True;
+
+ -- Since pragmas are never nested within other pragmas, stop
+ -- the traversal.
+
+ else
+ return False;
+ end if;
+
+ -- Prevent the search from going too far
+
+ elsif Is_Body_Or_Package_Declaration (Par) then
+ exit;
+ end if;
+
+ Par := Parent (Par);
+
+ -- If assertions are not enabled, the check pragma is rewritten
+ -- as an if_statement in sem_prag, to generate various warnings
+ -- on boolean expressions. Retrieve the original pragma.
+
+ if Nkind (Original_Node (Par)) = N_Pragma then
+ Par := Original_Node (Par);
+ end if;
+ end loop;
+
+ return False;
+ end Within_Initial_Condition;
+
+ -- Local variables
+
Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation;
+ -- Start of processing for Check_Internal_Call
+
begin
-- For P'Access, we want to warn if the -gnatw.f switch is set, and the
-- node comes from source.
- if Nkind (N) = N_Attribute_Reference and then
- (not Warn_On_Elab_Access or else not Comes_From_Source (N))
+ if Nkind (N) = N_Attribute_Reference
+ and then ((not Warn_On_Elab_Access and then not Debug_Flag_Dot_O)
+ or else not Comes_From_Source (N))
then
return;
-- If not function or procedure call, instantiation, or 'Access, then
-- ignore call (this happens in some error cases and rewriting cases).
- elsif not Nkind_In
- (N, N_Function_Call,
- N_Procedure_Call_Statement,
- N_Attribute_Reference)
+ elsif not Nkind_In (N, N_Attribute_Reference,
+ N_Function_Call,
+ N_Procedure_Call_Statement)
and then not Inst_Case
then
return;
@@ -2091,18 +2225,27 @@ package body Sem_Elab is
elsif Inside_A_Generic then
return;
+
+ -- Nothing to do when the call appears within pragma Initial_Condition.
+ -- The pragma is part of the elaboration statements of a package body
+ -- and may only call external subprograms or subprograms whose body is
+ -- already available.
+
+ elsif Within_Initial_Condition (N) then
+ return;
end if;
-- Delay this call if we are still delaying calls
if Delaying_Elab_Checks then
Delay_Check.Append (
- (N => N,
- E => E,
- Orig_Ent => Orig_Ent,
- Curscop => Current_Scope,
- Outer_Scope => Outer_Scope,
- From_Elab_Code => From_Elab_Code));
+ (N => N,
+ E => E,
+ Orig_Ent => Orig_Ent,
+ Curscop => Current_Scope,
+ Outer_Scope => Outer_Scope,
+ From_Elab_Code => From_Elab_Code,
+ From_SPARK_Code => SPARK_Mode = On));
return;
-- Otherwise, call phase 2 continuation right now
@@ -2570,7 +2713,7 @@ package body Sem_Elab is
procedure Collect_Tasks (Decls : List_Id);
-- Collect the types of the tasks that are to be activated in the given
-- list of declarations, in order to perform elaboration checks on the
- -- corresponding task procedures which are called implicitly here.
+ -- corresponding task procedures that are called implicitly here.
function Outer_Unit (E : Entity_Id) return Entity_Id;
-- find enclosing compilation unit of Entity, ignoring subunits, or
@@ -3287,11 +3430,11 @@ package body Sem_Elab is
-- Determine whether to emit an error message based on the combination
-- of flags Check_Elab_Flag and Flag.
- function Is_Printable_Error_Name (Nm : Name_Id) return Boolean;
- -- An internal function, used to determine if a name, Nm, is either
- -- a non-internal name, or is an internal name that is printable
- -- by the error message circuits (i.e. it has a single upper
- -- case letter at the end).
+ function Is_Printable_Error_Name return Boolean;
+ -- An internal function, used to determine if a name, stored in the
+ -- Name_Buffer, is either a non-internal name, or is an internal name
+ -- that is printable by the error message circuits (i.e. it has a single
+ -- upper case letter at the end).
----------
-- Emit --
@@ -3310,9 +3453,9 @@ package body Sem_Elab is
-- Is_Printable_Error_Name --
-----------------------------
- function Is_Printable_Error_Name (Nm : Name_Id) return Boolean is
+ function Is_Printable_Error_Name return Boolean is
begin
- if not Is_Internal_Name (Nm) then
+ if not Is_Internal_Name then
return True;
elsif Name_Len = 1 then
@@ -3335,6 +3478,7 @@ package body Sem_Elab is
Error_Msg_Sloc := Elab_Call.Table (J).Cloc;
Ent := Elab_Call.Table (J).Ent;
+ Get_Name_String (Chars (Ent));
-- Dynamic elaboration model, warnings controlled by -gnatwl
@@ -3344,7 +3488,7 @@ package body Sem_Elab is
Error_Msg_NE ("\\?l?& instantiated #", N, Ent);
elsif Is_Init_Proc (Ent) then
Error_Msg_N ("\\?l?initialization procedure called #", N);
- elsif Is_Printable_Error_Name (Chars (Ent)) then
+ elsif Is_Printable_Error_Name then
Error_Msg_NE ("\\?l?& called #", N, Ent);
else
Error_Msg_N ("\\?l?called #", N);
@@ -3359,7 +3503,7 @@ package body Sem_Elab is
Error_Msg_NE ("\\?$?& instantiated #", N, Ent);
elsif Is_Init_Proc (Ent) then
Error_Msg_N ("\\?$?initialization procedure called #", N);
- elsif Is_Printable_Error_Name (Chars (Ent)) then
+ elsif Is_Printable_Error_Name then
Error_Msg_NE ("\\?$?& called #", N, Ent);
else
Error_Msg_N ("\\?$?called #", N);
diff --git a/gcc/ada/sem_elim.adb b/gcc/ada/sem_elim.adb
index c8a07a97f0..f61a41ce38 100644
--- a/gcc/ada/sem_elim.adb
+++ b/gcc/ada/sem_elim.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -574,7 +574,7 @@ package body Sem_Elim is
--------------------
function Line_Num_Match return Boolean is
- N : Int := 0;
+ N : Nat := 0;
begin
if Idx = 0 then
@@ -599,9 +599,8 @@ package body Sem_Elim is
Idx := Idx + 1;
end loop;
- if Idx <= Last and then
- Sloc_Trace (Idx) = '['
- then
+ if Idx <= Last then
+ pragma Assert (Sloc_Trace (Idx) = '[');
Idx := Idx + 1;
Idx := Skip_Spaces;
else
diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
index 3f7e97b1ef..5a8c27b743 100644
--- a/gcc/ada/sem_eval.adb
+++ b/gcc/ada/sem_eval.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
+with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
@@ -173,6 +174,14 @@ package body Sem_Eval is
-- discrete, real, or string type and must be a compile time known value
-- (it is an error to make the call if these conditions are not met).
+ function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id;
+ -- Check whether an arithmetic operation with universal operands which is a
+ -- rewritten function call with an explicit scope indication is ambiguous:
+ -- P."+" (1, 2) will be ambiguous if there is more than one visible numeric
+ -- type declared in P and the context does not impose a type on the result
+ -- (e.g. in the expression of a type conversion). If ambiguous, emit an
+ -- error and return Empty, else return the result type of the operator.
+
function From_Bits (B : Bits; T : Entity_Id) return Uint;
-- Converts a bit string of length B'Length to a Uint value to be used for
-- a target of type T, which is a modular type. This procedure includes the
@@ -180,14 +189,11 @@ package body Sem_Eval is
-- (for a binary modulus, the bit string is the right length any way so all
-- is well).
- function Is_Static_Choice (Choice : Node_Id) return Boolean;
- -- Given a choice (from a case expression or membership test), returns
- -- True if the choice is static. No test is made for raising of constraint
- -- error, so this function is used only for legality tests.
-
- function Is_Static_Choice_List (Choices : List_Id) return Boolean;
- -- Given a choice list (from a case expression or membership test), return
- -- True if all choices are static in the sense of Is_Static_Choice.
+ function Get_String_Val (N : Node_Id) return Node_Id;
+ -- Given a tree node for a folded string or character value, returns the
+ -- corresponding string literal or character literal (one of the two must
+ -- be available, or the operand would not have been marked as foldable in
+ -- the earlier analysis of the operation).
function Is_OK_Static_Choice (Choice : Node_Id) return Boolean;
-- Given a choice (from a case expression or membership test), returns
@@ -197,6 +203,15 @@ package body Sem_Eval is
-- Given a choice list (from a case expression or membership test), return
-- True if all choices are static in the sense of Is_OK_Static_Choice.
+ function Is_Static_Choice (Choice : Node_Id) return Boolean;
+ -- Given a choice (from a case expression or membership test), returns
+ -- True if the choice is static. No test is made for raising of constraint
+ -- error, so this function is used only for legality tests.
+
+ function Is_Static_Choice_List (Choices : List_Id) return Boolean;
+ -- Given a choice list (from a case expression or membership test), return
+ -- True if all choices are static in the sense of Is_Static_Choice.
+
function Is_Static_Range (N : Node_Id) return Boolean;
-- Determine if range is static, as defined in RM 4.9(26). The only allowed
-- argument is an N_Range node (but note that the semantic analysis of
@@ -206,12 +221,6 @@ package body Sem_Eval is
-- raise Constraint_Error or not. Used for checking whether expressions are
-- static in the 4.9 sense (without worrying about exceptions).
- function Get_String_Val (N : Node_Id) return Node_Id;
- -- Given a tree node for a folded string or character value, returns the
- -- corresponding string literal or character literal (one of the two must
- -- be available, or the operand would not have been marked as foldable in
- -- the earlier analysis of the operation).
-
function OK_Bits (N : Node_Id; Bits : Uint) return Boolean;
-- Bits represents the number of bits in an integer value to be computed
-- (but the value has not been computed yet). If this value in Bits is
@@ -255,14 +264,6 @@ package body Sem_Eval is
-- used for producing the result of the static evaluation of the
-- logical operators
- function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id;
- -- Check whether an arithmetic operation with universal operands which is a
- -- rewritten function call with an explicit scope indication is ambiguous:
- -- P."+" (1, 2) will be ambiguous if there is more than one visible numeric
- -- type declared in P and the context does not impose a type on the result
- -- (e.g. in the expression of a type conversion). If ambiguous, emit an
- -- error and return Empty, else return the result type of the operator.
-
procedure Test_Expression_Is_Foldable
(N : Node_Id;
Op1 : Node_Id;
@@ -347,7 +348,11 @@ package body Sem_Eval is
-- Here we have a static predicate (note that it could have arisen from
-- an explicitly specified Dynamic_Predicate whose expression met the
- -- rules for being predicate-static).
+ -- rules for being predicate-static). If the expression is known at
+ -- compile time and obeys the predicate, then it is static and must be
+ -- labeled as such, which matters e.g. for case statements. The original
+ -- expression may be a type conversion of a variable with a known value,
+ -- which might otherwise not be marked static.
-- Case of real static predicate
@@ -356,6 +361,7 @@ package body Sem_Eval is
(Val => Make_Real_Literal (Sloc (Expr), Expr_Value_R (Expr)),
Typ => Typ)
then
+ Set_Is_Static_Expression (Expr);
return;
end if;
@@ -365,6 +371,7 @@ package body Sem_Eval is
if Real_Or_String_Static_Predicate_Matches
(Val => Expr_Value_S (Expr), Typ => Typ)
then
+ Set_Is_Static_Expression (Expr);
return;
end if;
@@ -376,6 +383,7 @@ package body Sem_Eval is
-- If static predicate matches, nothing to do
if Choices_Match (Expr, Static_Discrete_Predicate (Typ)) = Match then
+ Set_Is_Static_Expression (Expr);
return;
end if;
end if;
@@ -445,11 +453,24 @@ package body Sem_Eval is
-- that an infinity will result.
if not Is_Static_Expression (N) then
- if Is_Floating_Point_Type (T)
- and then Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True)
- then
- Error_Msg_N
- ("??float value out of range, infinity will be generated", N);
+ if Is_Floating_Point_Type (T) then
+ if Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
+ Error_Msg_N
+ ("??float value out of range, infinity will be generated", N);
+
+ -- The literal may be the result of constant-folding of a non-
+ -- static subexpression of a larger expression (e.g. a conversion
+ -- of a non-static variable whose value happens to be known). At
+ -- this point we must reduce the value of the subexpression to a
+ -- machine number (RM 4.9 (38/2)).
+
+ elsif Nkind (N) = N_Real_Literal
+ and then Nkind (Parent (N)) in N_Subexpr
+ then
+ Rewrite (N, New_Copy (N));
+ Set_Realval
+ (N, Machine (Base_Type (T), Realval (N), Round_Even, N));
+ end if;
end if;
return;
@@ -467,6 +488,14 @@ package body Sem_Eval is
-- non-static contexts, then ACVC test C490001 fails on Sparc/Solaris
-- and SGI/Irix.
+ -- This conversion is always done by GNATprove on real literals in
+ -- non-static expressions, by calling Check_Non_Static_Context from
+ -- gnat2why, as GNATprove cannot do the conversion later contrary
+ -- to gigi. The frontend computes the information about which
+ -- expressions are static, which is used by gnat2why to call
+ -- Check_Non_Static_Context on exactly those real literals that are
+ -- not sub-expressions of static expressions.
+
if Nkind (N) = N_Real_Literal
and then not Is_Machine_Number (N)
and then not Is_Generic_Type (Etype (N))
@@ -596,9 +625,21 @@ package body Sem_Eval is
Set_Raises_Constraint_Error (Choice);
return Non_Static;
+ -- When the choice denotes a subtype with a static predictate, check the
+ -- expression against the predicate values.
+
+ elsif (Nkind (Choice) = N_Subtype_Indication
+ or else (Is_Entity_Name (Choice)
+ and then Is_Type (Entity (Choice))))
+ and then Has_Predicates (Etype (Choice))
+ and then Has_Static_Predicate (Etype (Choice))
+ then
+ return
+ Choices_Match (Expr, Static_Discrete_Predicate (Etype (Choice)));
+
-- Discrete type case
- elsif Is_Discrete_Type (Etype (Expr)) then
+ elsif Is_Discrete_Type (Etyp) then
Val := Expr_Value (Expr);
if Nkind (Choice) = N_Range then
@@ -612,8 +653,7 @@ package body Sem_Eval is
end if;
elsif Nkind (Choice) = N_Subtype_Indication
- or else
- (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
+ or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
then
if Val >= Expr_Value (Type_Low_Bound (Etype (Choice)))
and then
@@ -635,9 +675,9 @@ package body Sem_Eval is
end if;
end if;
- -- Real type case
+ -- Real type case
- elsif Is_Real_Type (Etype (Expr)) then
+ elsif Is_Real_Type (Etyp) then
ValR := Expr_Value_R (Expr);
if Nkind (Choice) = N_Range then
@@ -651,8 +691,7 @@ package body Sem_Eval is
end if;
elsif Nkind (Choice) = N_Subtype_Indication
- or else
- (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
+ or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
then
if ValR >= Expr_Value_R (Type_Low_Bound (Etype (Choice)))
and then
@@ -671,15 +710,14 @@ package body Sem_Eval is
end if;
end if;
- -- String type cases
+ -- String type cases
else
- pragma Assert (Is_String_Type (Etype (Expr)));
+ pragma Assert (Is_String_Type (Etyp));
ValS := Expr_Value_S (Expr);
if Nkind (Choice) = N_Subtype_Indication
- or else
- (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
+ or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
then
if not Is_Constrained (Etype (Choice)) then
return Match;
@@ -755,12 +793,8 @@ package body Sem_Eval is
Assume_Valid : Boolean;
Rec : Boolean := False) return Compare_Result
is
- Ltyp : Entity_Id := Underlying_Type (Etype (L));
- Rtyp : Entity_Id := Underlying_Type (Etype (R));
- -- These get reset to the base type for the case of entities where
- -- Is_Known_Valid is not set. This takes care of handling possible
- -- invalid representations using the value of the base type, in
- -- accordance with RM 13.9.1(10).
+ Ltyp : Entity_Id := Etype (L);
+ Rtyp : Entity_Id := Etype (R);
Discard : aliased Uint;
@@ -1083,19 +1117,35 @@ package body Sem_Eval is
if L = R then
return EQ;
+ end if;
-- If expressions have no types, then do not attempt to determine if
-- they are the same, since something funny is going on. One case in
-- which this happens is during generic template analysis, when bounds
-- are not fully analyzed.
- elsif No (Ltyp) or else No (Rtyp) then
+ if No (Ltyp) or else No (Rtyp) then
+ return Unknown;
+ end if;
+
+ -- These get reset to the base type for the case of entities where
+ -- Is_Known_Valid is not set. This takes care of handling possible
+ -- invalid representations using the value of the base type, in
+ -- accordance with RM 13.9.1(10).
+
+ Ltyp := Underlying_Type (Ltyp);
+ Rtyp := Underlying_Type (Rtyp);
+
+ -- Same rationale as above, but for Underlying_Type instead of Etype
+
+ if No (Ltyp) or else No (Rtyp) then
return Unknown;
+ end if;
-- We do not attempt comparisons for packed arrays represented as
-- modular types, where the semantics of comparison is quite different.
- elsif Is_Packed_Array_Impl_Type (Ltyp)
+ if Is_Packed_Array_Impl_Type (Ltyp)
and then Is_Modular_Integer_Type (Ltyp)
then
return Unknown;
@@ -1292,12 +1342,22 @@ package body Sem_Eval is
if Is_Same_Value (Lnode, Rnode) then
if Loffs = Roffs then
return EQ;
- elsif Loffs < Roffs then
- Diff.all := Roffs - Loffs;
- return LT;
- else
- Diff.all := Loffs - Roffs;
- return GT;
+ end if;
+
+ -- When the offsets are not equal, we can go farther only if
+ -- the types are not modular (e.g. X < X + 1 is False if X is
+ -- the largest number).
+
+ if not Is_Modular_Integer_Type (Ltyp)
+ and then not Is_Modular_Integer_Type (Rtyp)
+ then
+ if Loffs < Roffs then
+ Diff.all := Roffs - Loffs;
+ return LT;
+ else
+ Diff.all := Loffs - Roffs;
+ return GT;
+ end if;
end if;
end if;
end;
@@ -1876,9 +1936,14 @@ package body Sem_Eval is
-- division, rem and mod if the right operand is zero.
if Right_Int = 0 then
+
+ -- When SPARK_Mode is On, force a warning instead of
+ -- an error in that case, as this likely corresponds
+ -- to deactivated code.
+
Apply_Compile_Time_Constraint_Error
(N, "division by zero", CE_Divide_By_Zero,
- Warn => not Stat);
+ Warn => not Stat or SPARK_Mode = On);
Set_Raises_Constraint_Error (N);
return;
@@ -1894,10 +1959,16 @@ package body Sem_Eval is
-- division, rem and mod if the right operand is zero.
if Right_Int = 0 then
+
+ -- When SPARK_Mode is On, force a warning instead of
+ -- an error in that case, as this likely corresponds
+ -- to deactivated code.
+
Apply_Compile_Time_Constraint_Error
(N, "mod with zero divisor", CE_Divide_By_Zero,
- Warn => not Stat);
+ Warn => not Stat or SPARK_Mode = On);
return;
+
else
Result := Left_Int mod Right_Int;
end if;
@@ -1908,9 +1979,14 @@ package body Sem_Eval is
-- division, rem and mod if the right operand is zero.
if Right_Int = 0 then
+
+ -- When SPARK_Mode is On, force a warning instead of
+ -- an error in that case, as this likely corresponds
+ -- to deactivated code.
+
Apply_Compile_Time_Constraint_Error
(N, "rem with zero divisor", CE_Divide_By_Zero,
- Warn => not Stat);
+ Warn => not Stat or SPARK_Mode = On);
return;
else
@@ -2606,9 +2682,12 @@ package body Sem_Eval is
-- If the literal appears in a non-expression context, then it is
-- certainly appearing in a non-static context, so check it. This is
-- actually a redundant check, since Check_Non_Static_Context would
- -- check it, but it seems worth while avoiding the call.
+ -- check it, but it seems worthwhile to optimize out the call.
- if Nkind (Parent (N)) not in N_Subexpr
+ -- An exception is made for a literal in an if or case expression
+
+ if (Nkind_In (Parent (N), N_If_Expression, N_Case_Expression_Alternative)
+ or else Nkind (Parent (N)) not in N_Subexpr)
and then not In_Any_Integer_Context
then
Check_Non_Static_Context (N);
@@ -2714,45 +2793,34 @@ package body Sem_Eval is
-- static subtype (RM 4.9(12)).
procedure Eval_Membership_Op (N : Node_Id) is
- Left : constant Node_Id := Left_Opnd (N);
- Right : constant Node_Id := Right_Opnd (N);
Alts : constant List_Id := Alternatives (N);
+ Choice : constant Node_Id := Right_Opnd (N);
+ Expr : constant Node_Id := Left_Opnd (N);
Result : Match_Result;
begin
-- Ignore if error in either operand, except to make sure that Any_Type
-- is properly propagated to avoid junk cascaded errors.
- if Etype (Left) = Any_Type
- or else (Present (Right) and then Etype (Right) = Any_Type)
+ if Etype (Expr) = Any_Type
+ or else (Present (Choice) and then Etype (Choice) = Any_Type)
then
Set_Etype (N, Any_Type);
return;
end if;
- -- Ignore if types involved have predicates
- -- Is this right for static predicates ???
- -- And what about the alternatives ???
-
- if Present (Predicate_Function (Etype (Left)))
- or else (Present (Right)
- and then Present (Predicate_Function (Etype (Right))))
- then
- return;
- end if;
-
-- If left operand non-static, then nothing to do
- if not Is_Static_Expression (Left) then
+ if not Is_Static_Expression (Expr) then
return;
end if;
-- If choice is non-static, left operand is in non-static context
- if (Present (Right) and then not Is_Static_Choice (Right))
+ if (Present (Choice) and then not Is_Static_Choice (Choice))
or else (Present (Alts) and then not Is_Static_Choice_List (Alts))
then
- Check_Non_Static_Context (Left);
+ Check_Non_Static_Context (Expr);
return;
end if;
@@ -2762,16 +2830,16 @@ package body Sem_Eval is
-- If left operand raises constraint error, propagate and we are done
- if Raises_Constraint_Error (Left) then
+ if Raises_Constraint_Error (Expr) then
Set_Raises_Constraint_Error (N, True);
-- See if we match
else
- if Present (Right) then
- Result := Choice_Matches (Left, Right);
+ if Present (Choice) then
+ Result := Choice_Matches (Expr, Choice);
else
- Result := Choices_Match (Left, Alts);
+ Result := Choices_Match (Expr, Alts);
end if;
-- If result is Non_Static, it means that we raise Constraint_Error,
@@ -3190,6 +3258,11 @@ package body Sem_Eval is
begin
Ent := Empty;
+ -- Ignored values:
+
+ Kind := '?';
+ Cons := No_Uint;
+
if Nkind (Expr) = N_Op_Add
and then Compile_Time_Known_Value (Right_Opnd (Expr))
then
@@ -3277,8 +3350,8 @@ package body Sem_Eval is
(Original_Node (Type_High_Bound (T)), Ent2, Kind2, Cons2);
if Present (Ent1)
- and then Kind1 = Kind2
and then Ent1 = Ent2
+ and then Kind1 = Kind2
then
Len := Cons2 - Cons1 + 1;
else
@@ -3370,9 +3443,7 @@ package body Sem_Eval is
when N_Op_Le => Result := (Left_Real <= Right_Real);
when N_Op_Gt => Result := (Left_Real > Right_Real);
when N_Op_Ge => Result := (Left_Real >= Right_Real);
-
- when others =>
- raise Program_Error;
+ when others => raise Program_Error;
end case;
Fold_Uint (N, Test (Result), True);
@@ -4697,8 +4768,7 @@ package body Sem_Eval is
return Is_OK_Static_Range (Choice);
elsif Nkind (Choice) = N_Subtype_Indication
- or else
- (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
+ or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
then
return Is_OK_Static_Subtype (Etype (Choice));
@@ -4787,6 +4857,9 @@ package body Sem_Eval is
then
return False;
+ elsif Has_Dynamic_Predicate_Aspect (Typ) then
+ return False;
+
-- String types
elsif Is_String_Type (Typ) then
@@ -4853,8 +4926,7 @@ package body Sem_Eval is
return Is_Static_Range (Choice);
elsif Nkind (Choice) = N_Subtype_Indication
- or else
- (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
+ or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
then
return Is_Static_Subtype (Etype (Choice));
@@ -4883,7 +4955,7 @@ package body Sem_Eval is
return True;
end Is_Static_Choice_List;
----------------------
+ ---------------------
-- Is_Static_Range --
---------------------
@@ -4929,6 +5001,15 @@ package body Sem_Eval is
then
return False;
+ -- If there is a dynamic predicate for the type (declared or inherited)
+ -- the expression is not static.
+
+ elsif Has_Dynamic_Predicate_Aspect (Typ)
+ or else (Is_Derived_Type (Typ)
+ and then Has_Aspect (Typ, Aspect_Dynamic_Predicate))
+ then
+ return False;
+
-- String types
elsif Is_String_Type (Typ) then
@@ -5399,6 +5480,40 @@ package body Sem_Eval is
return Skip;
end;
+ -- The predicate function may contain string-comparison operations
+ -- that have been converted into calls to run-time array-comparison
+ -- routines. To evaluate the predicate statically, we recover the
+ -- original comparison operation and replace the occurrence of the
+ -- formal by the static string value. The actuals of the generated
+ -- call are of the form X'Address.
+
+ elsif Nkind (N) in N_Op_Compare
+ and then Nkind (Left_Opnd (N)) = N_Function_Call
+ then
+ declare
+ C : constant Node_Id := Left_Opnd (N);
+ F : constant Node_Id := First (Parameter_Associations (C));
+ L : constant Node_Id := Prefix (F);
+ R : constant Node_Id := Prefix (Next (F));
+
+ begin
+ -- If an operand is an entity name, it is the formal of the
+ -- predicate function, so replace it with the string value.
+ -- It may be either operand in the call. The other operand
+ -- is a static string from the original predicate.
+
+ if Is_Entity_Name (L) then
+ Rewrite (Left_Opnd (N), New_Copy (Val));
+ Rewrite (Right_Opnd (N), New_Copy (R));
+
+ else
+ Rewrite (Left_Opnd (N), New_Copy (L));
+ Rewrite (Right_Opnd (N), New_Copy (Val));
+ end if;
+
+ return Skip;
+ end;
+
else
return OK;
end if;
@@ -6418,7 +6533,10 @@ package body Sem_Eval is
-- Entity name
- when N_Expanded_Name | N_Identifier | N_Operator_Symbol =>
+ when N_Expanded_Name
+ | N_Identifier
+ | N_Operator_Symbol
+ =>
E := Entity (N);
if Is_Named_Number (E) then
@@ -6492,10 +6610,13 @@ package body Sem_Eval is
-- Binary operator
- when N_Binary_Op | N_Short_Circuit | N_Membership_Test =>
+ when N_Binary_Op
+ | N_Membership_Test
+ | N_Short_Circuit
+ =>
if Nkind (N) in N_Op_Shift then
Error_Msg_N
- ("!shift functions are never static (RM 4.9(6,18))", N);
+ ("!shift functions are never static (RM 4.9(6,18))", N);
else
Why_Not_Static (Left_Opnd (N));
Why_Not_Static (Right_Opnd (N));
@@ -6614,7 +6735,9 @@ package body Sem_Eval is
-- Aggregate
- when N_Aggregate | N_Extension_Aggregate =>
+ when N_Aggregate
+ | N_Extension_Aggregate
+ =>
Error_Msg_N ("!an aggregate is never static (RM 4.9)", N);
-- Range
@@ -6664,7 +6787,6 @@ package body Sem_Eval is
when others =>
null;
-
end case;
end Why_Not_Static;
diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads
index 7f206e71d0..b689b80011 100644
--- a/gcc/ada/sem_eval.ads
+++ b/gcc/ada/sem_eval.ads
@@ -159,6 +159,11 @@ package Sem_Eval is
-- customer for this procedure is Sem_Attr (because Eval_Attribute is
-- there). There is also one special case arising from ranges (see body of
-- Resolve_Range).
+ --
+ -- Note: this procedure is also called by GNATprove on real literals
+ -- that are not sub-expressions of static expressions, to convert them to
+ -- machine numbers, as GNATprove cannot perform this conversion contrary
+ -- to gigi.
procedure Check_String_Literal_Length (N : Node_Id; Ttype : Entity_Id);
-- N is either a string literal, or a constraint error node. In the latter
@@ -198,88 +203,10 @@ package Sem_Eval is
-- True for a recursive call from within Compile_Time_Compare to avoid some
-- infinite recursion cases. It should never be set by a client.
- procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id);
- -- This procedure is called after it has been determined that Expr is not
- -- static when it is required to be. Msg is the text of a message that
- -- explains the error. This procedure checks if an error is already posted
- -- on Expr, if so, it does nothing unless All_Errors_Mode is set in which
- -- case this flag is ignored. Otherwise the given message is posted using
- -- Error_Msg_F, and then Why_Not_Static is called on Expr to generate
- -- additional messages. The string given as Msg should end with ! to make
- -- it an unconditional message, to ensure that if it is posted, the entire
- -- set of messages is all posted.
-
- function Is_OK_Static_Expression (N : Node_Id) return Boolean;
- -- An OK static expression is one that is static in the RM definition sense
- -- and which does not raise constraint error. For most legality checking
- -- purposes you should use Is_Static_Expression. For those legality checks
- -- where the expression N should not raise constraint error use this
- -- routine. This routine is *not* to be used in contexts where the test is
- -- for compile time evaluation purposes. Use Compile_Time_Known_Value
- -- instead (see section on "Compile-Time Known Values" above).
-
- function Is_OK_Static_Range (N : Node_Id) return Boolean;
- -- Determines if range is static, as defined in RM 4.9(26), and also checks
- -- that neither bound of the range raises constraint error, thus ensuring
- -- that both bounds of the range are compile-time evaluable (i.e. do not
- -- raise constraint error). A result of true means that the bounds are
- -- compile time evaluable. A result of false means they are not (either
- -- because the range is not static, or because one or the other bound
- -- raises CE).
-
- function Is_Static_Subtype (Typ : Entity_Id) return Boolean;
- -- Determines whether a subtype fits the definition of an Ada static
- -- subtype as given in (RM 4.9(26)). Important note: This check does not
- -- include the Ada 2012 case of a non-static predicate which results in an
- -- otherwise static subtype being non-static. Such a subtype will return
- -- True for this test, so if the distinction is important, the caller must
- -- deal with this.
- --
- -- Implementation note: an attempt to include this Ada 2012 case failed,
- -- since it appears that this routine is called in some cases before the
- -- Static_Discrete_Predicate field is set ???
- --
- -- This differs from Is_OK_Static_Subtype (which is what must be used by
- -- clients) in that it does not care whether the bounds raise a constraint
- -- error exception or not. Used for checking whether expressions are static
- -- in the 4.9 sense (without worrying about exceptions).
-
- function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean;
- -- Determines whether a subtype fits the definition of an Ada static
- -- subtype as given in (RM 4.9(26)) with the additional check that neither
- -- bound raises constraint error (meaning that Expr_Value[_R|S] can be used
- -- on these bounds). Important note: This check does not include the Ada
- -- 2012 case of a non-static predicate which results in an otherwise static
- -- subtype being non-static. Such a subtype will return True for this test,
- -- so if the distinction is important, the caller must deal with this.
- --
- -- Implementation note: an attempt to include this Ada 2012 case failed,
- -- since it appears that this routine is called in some cases before the
- -- Static_Discrete_Predicate field is set ???
- --
- -- This differs from Is_Static_Subtype in that it includes the constraint
- -- error checks, which are missing from Is_Static_Subtype.
-
- function Subtypes_Statically_Compatible
- (T1 : Entity_Id;
- T2 : Entity_Id;
- Formal_Derived_Matching : Boolean := False) return Boolean;
- -- Returns true if the subtypes are unconstrained or the constraint on
- -- on T1 is statically compatible with T2 (as defined by 4.9.1(4)).
- -- Otherwise returns false. Formal_Derived_Matching indicates whether
- -- the type T1 is a generic actual being checked against ancestor T2
- -- in a formal derived type association.
-
- function Subtypes_Statically_Match
- (T1 : Entity_Id;
- T2 : Entity_Id;
- Formal_Derived_Matching : Boolean := False) return Boolean;
- -- Determine whether two types T1, T2, which have the same base type,
- -- are statically matching subtypes (RM 4.9.1(1-2)). Also includes the
- -- extra GNAT rule that object sizes must match (this can be false for
- -- types that match in the RM sense because of use of 'Object_Size),
- -- except when testing a generic actual T1 against an ancestor T2 in a
- -- formal derived type association (indicated by Formal_Derived_Matching).
+ function Compile_Time_Known_Bounds (T : Entity_Id) return Boolean;
+ -- If T is an array whose index bounds are all known at compile time, then
+ -- True is returned. If T is not an array type, or one or more of its index
+ -- bounds is not known at compile time, then False is returned.
function Compile_Time_Known_Value (Op : Node_Id) return Boolean;
-- Returns true if Op is an expression not raising Constraint_Error whose
@@ -306,6 +233,15 @@ package Sem_Eval is
-- efficient with compile time known values, e.g. range analysis for the
-- purpose of removing checks is more effective if we know precise bounds.
+ function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean;
+ -- Similar to Compile_Time_Known_Value, but also returns True if the value
+ -- is a compile-time-known aggregate, i.e. an aggregate all of whose
+ -- constituent expressions are either compile-time-known values (based on
+ -- calling Compile_Time_Known_Value) or compile-time-known aggregates.
+ -- Note that the aggregate could still involve run-time checks that might
+ -- fail (such as for subtype checks in component associations), but the
+ -- evaluation of the expressions themselves will not raise an exception.
+
function CRT_Safe_Compile_Time_Known_Value (Op : Node_Id) return Boolean;
-- In the case of configurable run-times, there may be an issue calling
-- Compile_Time_Known_Value with non-static expressions where the legality
@@ -328,19 +264,16 @@ package Sem_Eval is
-- if we are in configurable run-time mode, even if the expression would
-- normally be considered compile-time known.
- function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean;
- -- Similar to Compile_Time_Known_Value, but also returns True if the value
- -- is a compile-time-known aggregate, i.e. an aggregate all of whose
- -- constituent expressions are either compile-time-known values (based on
- -- calling Compile_Time_Known_Value) or compile-time-known aggregates.
- -- Note that the aggregate could still involve run-time checks that might
- -- fail (such as for subtype checks in component associations), but the
- -- evaluation of the expressions themselves will not raise an exception.
-
- function Compile_Time_Known_Bounds (T : Entity_Id) return Boolean;
- -- If T is an array whose index bounds are all known at compile time, then
- -- True is returned. If T is not an array type, or one or more of its index
- -- bounds is not known at compile time, then False is returned.
+ function Expr_Rep_Value (N : Node_Id) return Uint;
+ -- This is identical to Expr_Value, except in the case of enumeration
+ -- literals of types for which an enumeration representation clause has
+ -- been given, in which case it returns the representation value rather
+ -- than the pos value. This is the value that is needed for generating code
+ -- sequences, while the Expr_Value value is appropriate for compile time
+ -- constraint errors or getting the logical value. Note that this function
+ -- does NOT concern itself with biased values, if the caller needs a
+ -- properly biased value, the subtraction of the bias must be handled
+ -- explicitly.
function Expr_Value (N : Node_Id) return Uint;
-- Returns the folded value of the expression N. This function is called in
@@ -372,17 +305,6 @@ package Sem_Eval is
-- is static or its value is known at compile time. This version is used
-- for string types and returns the corresponding N_String_Literal node.
- function Expr_Rep_Value (N : Node_Id) return Uint;
- -- This is identical to Expr_Value, except in the case of enumeration
- -- literals of types for which an enumeration representation clause has
- -- been given, in which case it returns the representation value rather
- -- than the pos value. This is the value that is needed for generating code
- -- sequences, while the Expr_Value value is appropriate for compile time
- -- constraint errors or getting the logical value. Note that this function
- -- does NOT concern itself with biased values, if the caller needs a
- -- properly biased value, the subtraction of the bias must be handled
- -- explicitly.
-
procedure Eval_Actual (N : Node_Id);
procedure Eval_Allocator (N : Node_Id);
procedure Eval_Arithmetic_Op (N : Node_Id);
@@ -411,6 +333,17 @@ package Sem_Eval is
procedure Eval_Unary_Op (N : Node_Id);
procedure Eval_Unchecked_Conversion (N : Node_Id);
+ procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id);
+ -- This procedure is called after it has been determined that Expr is not
+ -- static when it is required to be. Msg is the text of a message that
+ -- explains the error. This procedure checks if an error is already posted
+ -- on Expr, if so, it does nothing unless All_Errors_Mode is set in which
+ -- case this flag is ignored. Otherwise the given message is posted using
+ -- Error_Msg_F, and then Why_Not_Static is called on Expr to generate
+ -- additional messages. The string given as Msg should end with ! to make
+ -- it an unconditional message, to ensure that if it is posted, the entire
+ -- set of messages is all posted.
+
procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean);
-- Rewrite N with a new N_String_Literal node as the result of the compile
-- time evaluation of the node N. Val is the resulting string value from
@@ -474,6 +407,38 @@ package Sem_Eval is
-- is some independent way of knowing that it is valid, i.e. either it is
-- an entity with Is_Known_Valid set, or Assume_No_Invalid_Values is True.
+ function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean;
+ -- Returns True if it can guarantee that Lo .. Hi is a null range. If it
+ -- cannot (because the value of Lo or Hi is not known at compile time) then
+ -- it returns False.
+
+ function Is_OK_Static_Expression (N : Node_Id) return Boolean;
+ -- An OK static expression is one that is static in the RM definition sense
+ -- and which does not raise constraint error. For most legality checking
+ -- purposes you should use Is_Static_Expression. For those legality checks
+ -- where the expression N should not raise constraint error use this
+ -- routine. This routine is *not* to be used in contexts where the test is
+ -- for compile time evaluation purposes. Use Compile_Time_Known_Value
+ -- instead (see section on "Compile-Time Known Values" above).
+
+ function Is_OK_Static_Range (N : Node_Id) return Boolean;
+ -- Determines if range is static, as defined in RM 4.9(26), and also checks
+ -- that neither bound of the range raises constraint error, thus ensuring
+ -- that both bounds of the range are compile-time evaluable (i.e. do not
+ -- raise constraint error). A result of true means that the bounds are
+ -- compile time evaluable. A result of false means they are not (either
+ -- because the range is not static, or because one or the other bound
+ -- raises CE).
+
+ function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean;
+ -- Determines whether a subtype fits the definition of an Ada static
+ -- subtype as given in (RM 4.9(26)) with the additional check that neither
+ -- bound raises constraint error (meaning that Expr_Value[_R|S] can be used
+ -- on these bounds).
+ --
+ -- This differs from Is_Static_Subtype in that it includes the constraint
+ -- error checks, which are missing from Is_Static_Subtype.
+
function Is_Out_Of_Range
(N : Node_Id;
Typ : Entity_Id;
@@ -488,6 +453,19 @@ package Sem_Eval is
-- that it is out of range. The parameters Assume_Valid, Fixed_Int, and
-- Int_Real are as described for Is_In_Range above.
+ function Is_Static_Subtype (Typ : Entity_Id) return Boolean;
+ -- Determines whether a subtype fits the definition of an Ada static
+ -- subtype as given in (RM 4.9(26)).
+ --
+ -- This differs from Is_OK_Static_Subtype (which is what must be used by
+ -- clients) in that it does not care whether the bounds raise a constraint
+ -- error exception or not. Used for checking whether expressions are static
+ -- in the 4.9 sense (without worrying about exceptions).
+
+ function Is_Statically_Unevaluated (Expr : Node_Id) return Boolean;
+ -- This function returns True if the given expression Expr is statically
+ -- unevaluated, as defined in (RM 4.9 (32.1-32.6)).
+
function In_Subrange_Of
(T1 : Entity_Id;
T2 : Entity_Id;
@@ -498,15 +476,6 @@ package Sem_Eval is
-- it cannot be determined at compile time. Flag Fixed_Int is used as in
-- routine Is_In_Range above.
- function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean;
- -- Returns True if it can guarantee that Lo .. Hi is a null range. If it
- -- cannot (because the value of Lo or Hi is not known at compile time) then
- -- it returns False.
-
- function Is_Statically_Unevaluated (Expr : Node_Id) return Boolean;
- -- This function returns True if the given expression Expr is statically
- -- unevaluated, as defined in (RM 4.9 (32.1-32.6)).
-
function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean;
-- Returns True if it can guarantee that Lo .. Hi is not a null range. If
-- it cannot (because the value of Lo or Hi is not known at compile time)
@@ -518,6 +487,27 @@ package Sem_Eval is
-- predicates match. Separated out from Subtypes_Statically_Match so
-- that it can be used in specializing error messages.
+ function Subtypes_Statically_Compatible
+ (T1 : Entity_Id;
+ T2 : Entity_Id;
+ Formal_Derived_Matching : Boolean := False) return Boolean;
+ -- Returns true if the subtypes are unconstrained or the constraint on
+ -- on T1 is statically compatible with T2 (as defined by 4.9.1(4)).
+ -- Otherwise returns false. Formal_Derived_Matching indicates whether
+ -- the type T1 is a generic actual being checked against ancestor T2
+ -- in a formal derived type association.
+
+ function Subtypes_Statically_Match
+ (T1 : Entity_Id;
+ T2 : Entity_Id;
+ Formal_Derived_Matching : Boolean := False) return Boolean;
+ -- Determine whether two types T1, T2, which have the same base type,
+ -- are statically matching subtypes (RM 4.9.1(1-2)). Also includes the
+ -- extra GNAT rule that object sizes must match (this can be false for
+ -- types that match in the RM sense because of use of 'Object_Size),
+ -- except when testing a generic actual T1 against an ancestor T2 in a
+ -- formal derived type association (indicated by Formal_Derived_Matching).
+
procedure Why_Not_Static (Expr : Node_Id);
-- This procedure may be called after generating an error message that
-- complains that something is non-static. If it finds good reasons, it
diff --git a/gcc/ada/sem_intr.adb b/gcc/ada/sem_intr.adb
index 69a1d5ffd8..c038dc4d79 100644
--- a/gcc/ada/sem_intr.adb
+++ b/gcc/ada/sem_intr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -31,6 +31,7 @@ with Errout; use Errout;
with Fname; use Fname;
with Lib; use Lib;
with Namet; use Namet;
+with Opt; use Opt;
with Sem_Aux; use Sem_Aux;
with Sem_Eval; use Sem_Eval;
with Sem_Util; use Sem_Util;
@@ -59,13 +60,16 @@ package body Sem_Intr is
procedure Check_Shift (E : Entity_Id; N : Node_Id);
-- Check intrinsic shift subprogram, the two arguments are the same
-- as for Check_Intrinsic_Subprogram (i.e. the entity of the subprogram
- -- declaration, and the node for the pragma argument, used for messages)
+ -- declaration, and the node for the pragma argument, used for messages).
- procedure Errint (Msg : String; S : Node_Id; N : Node_Id);
+ procedure Errint
+ (Msg : String; S : Node_Id; N : Node_Id; Relaxed : Boolean := False);
-- Post error message for bad intrinsic, the message itself is posted
-- on the appropriate spec node and another message is placed on the
-- pragma itself, referring to the spec. S is the node in the spec on
-- which the message is to be placed, and N is the pragma argument node.
+ -- Relaxed is True if the message should not be emitted in
+ -- Relaxed_RM_Semantics mode.
------------------------------
-- Check_Exception_Function --
@@ -340,7 +344,7 @@ package body Sem_Intr is
then
null;
- -- Exception functions
+ -- Exception functions
elsif Nam_In (Nam, Name_Exception_Information,
Name_Exception_Message,
@@ -359,6 +363,7 @@ package body Sem_Intr is
Name_Line,
Name_Source_Location,
Name_Enclosing_Entity,
+ Name_Compilation_ISO_Date,
Name_Compilation_Date,
Name_Compilation_Time)
then
@@ -430,7 +435,7 @@ package body Sem_Intr is
then
Errint
("first argument for shift must have size 8, 16, 32 or 64",
- Ptyp1, N);
+ Ptyp1, N, Relaxed => True);
return;
elsif Non_Binary_Modulus (Typ1) then
@@ -448,7 +453,7 @@ package body Sem_Intr is
then
Errint
("modular type for shift must have modulus of 2'*'*8, "
- & "2'*'*16, 2'*'*32, or 2'*'*64", Ptyp1, N);
+ & "2'*'*16, 2'*'*32, or 2'*'*64", Ptyp1, N, Relaxed => True);
elsif Etype (Arg1) /= Etype (E) then
Errint
@@ -463,10 +468,16 @@ package body Sem_Intr is
-- Errint --
------------
- procedure Errint (Msg : String; S : Node_Id; N : Node_Id) is
+ procedure Errint
+ (Msg : String; S : Node_Id; N : Node_Id; Relaxed : Boolean := False) is
begin
- Error_Msg_N (Msg, S);
- Error_Msg_N ("incorrect intrinsic subprogram, see spec", N);
+ -- Ignore errors on Intrinsic in Relaxed_RM_Semantics mode where we can
+ -- be more liberal.
+
+ if not (Relaxed and Relaxed_RM_Semantics) then
+ Error_Msg_N (Msg, S);
+ Error_Msg_N ("incorrect intrinsic subprogram, see spec", N);
+ end if;
end Errint;
end Sem_Intr;
diff --git a/gcc/ada/sem_mech.adb b/gcc/ada/sem_mech.adb
index cfe9f9536c..b28562e050 100644
--- a/gcc/ada/sem_mech.adb
+++ b/gcc/ada/sem_mech.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1996-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1996-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -146,12 +146,12 @@ package body Sem_Mech is
-- the point of view of parameter passing mechanism. Convention
-- Ghost has the same dynamic semantics as convention Ada.
- when Convention_Ada |
- Convention_Intrinsic |
- Convention_Entry |
- Convention_Protected |
- Convention_Stubbed =>
-
+ when Convention_Ada
+ | Convention_Entry
+ | Convention_Intrinsic
+ | Convention_Protected
+ | Convention_Stubbed
+ =>
-- By reference types are passed by reference (RM 6.2(4))
if Is_By_Reference_Type (Typ) then
@@ -183,11 +183,11 @@ package body Sem_Mech is
-- Note: Assembler, C++, Stdcall also use C conventions
- when Convention_Assembler |
- Convention_C |
- Convention_CPP |
- Convention_Stdcall =>
-
+ when Convention_Assembler
+ | Convention_C
+ | Convention_CPP
+ | Convention_Stdcall
+ =>
-- The following values are passed by copy
-- IN Scalar parameters (RM B.3(66))
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 3c8b6a5fb2..cae36e65ca 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -39,10 +39,12 @@ with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
+with Exp_Ch7; use Exp_Ch7;
with Exp_Dist; use Exp_Dist;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Ghost; use Ghost;
+with Gnatvsn; use Gnatvsn;
with Lib; use Lib;
with Lib.Writ; use Lib.Writ;
with Lib.Xref; use Lib.Xref;
@@ -220,6 +222,13 @@ package body Sem_Prag is
-- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma
-- Prag that duplicates previous pragma Prev.
+ function Find_Encapsulating_State
+ (States : Elist_Id;
+ Constit_Id : Entity_Id) return Entity_Id;
+ -- Given the entity of a constituent Constit_Id, find the corresponding
+ -- encapsulating state which appears in States. The routine returns Empty
+ -- if no such state is found.
+
function Find_Related_Context
(Prag : Node_Id;
Do_Checks : Boolean := False) return Node_Id;
@@ -237,18 +246,21 @@ package body Sem_Prag is
function Get_SPARK_Mode_Type (N : Name_Id) return SPARK_Mode_Type;
-- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
- -- Get_SPARK_Mode_Type. Convert a name into a corresponding value of type
- -- SPARK_Mode_Type.
+ -- Get_SPARK_Mode_From_Annotation. Convert a name into a corresponding
+ -- value of type SPARK_Mode_Type.
function Has_Extra_Parentheses (Clause : Node_Id) return Boolean;
-- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
-- Determine whether dependency clause Clause is surrounded by extra
-- parentheses. If this is the case, issue an error message.
- function Is_CCT_Instance (Ref : Node_Id) return Boolean;
+ function Is_CCT_Instance
+ (Ref_Id : Entity_Id;
+ Context_Id : Entity_Id) return Boolean;
-- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
- -- Global. Determine whether reference Ref denotes the current instance of
- -- a concurrent type.
+ -- Global. Determine whether entity Ref_Id denotes the current instance of
+ -- a concurrent type. Context_Id denotes the associated context where the
+ -- pragma appears.
function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean;
-- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
@@ -270,11 +282,16 @@ package body Sem_Prag is
-- function, this routine finds the corresponding state and sets the entity
-- of N to that of the state.
- procedure Rewrite_Assertion_Kind (N : Node_Id);
+ procedure Rewrite_Assertion_Kind
+ (N : Node_Id;
+ From_Policy : Boolean := False);
-- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
-- then it is rewritten as an identifier with the corresponding special
-- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
- -- and Check_Policy.
+ -- and Check_Policy. If the names are Precondition or Postcondition, this
+ -- combination is deprecated in favor of Assertion_Policy and Ada2012
+ -- Aspect names. The parameter From_Policy indicates that the pragma
+ -- is the old non-standard Check_Policy and not a rewritten pragma.
procedure Set_Elab_Unit_Name (N : Node_Id; With_Item : Node_Id);
-- Place semantic information on the argument of an Elaborate/Elaborate_All
@@ -349,6 +366,10 @@ package body Sem_Prag is
-- Analyze_Contract_Cases_In_Decl_Part --
-----------------------------------------
+ -- WARNING: This routine manages Ghost regions. Return statements must be
+ -- replaced by gotos which jump to the end of the routine and restore the
+ -- Ghost mode.
+
procedure Analyze_Contract_Cases_In_Decl_Part
(N : Node_Id;
Freeze_Id : Entity_Id := Empty)
@@ -447,9 +468,8 @@ package body Sem_Prag is
CCases : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
-
CCase : Node_Id;
+ Mode : Ghost_Mode_Type;
Restore_Scope : Boolean := False;
-- Start of processing for Analyze_Contract_Cases_In_Decl_Part
@@ -463,10 +483,10 @@ package body Sem_Prag is
-- Set the Ghost mode in effect from the pragma. Due to the delayed
-- analysis of the pragma, the Ghost mode at point of declaration and
- -- point of analysis may not necessarely be the same. Use the mode in
+ -- point of analysis may not necessarily be the same. Use the mode in
-- effect at the point of declaration.
- Set_Ghost_Mode (N);
+ Set_Ghost_Mode (N, Mode);
-- Single and multiple contract cases must appear in aggregate form. If
-- this is not the case, then either the parser of the analysis of the
@@ -512,8 +532,8 @@ package body Sem_Prag is
Error_Msg_N ("wrong syntax for constract cases", N);
end if;
- Ghost_Mode := Save_Ghost_Mode;
Set_Is_Analyzed_Pragma (N);
+ Restore_Ghost_Mode (Mode);
end Analyze_Contract_Cases_In_Decl_Part;
----------------------------------
@@ -559,6 +579,10 @@ package body Sem_Prag is
-- Two lists containing the full set of inputs and output of the related
-- subprograms. Note that these lists contain both nodes and entities.
+ Task_Input_Seen : Boolean := False;
+ Task_Output_Seen : Boolean := False;
+ -- Flags used to track the implicit dependence of a task unit on itself
+
procedure Add_Item_To_Name_Buffer (Item_Id : Entity_Id);
-- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
-- to the name buffer. The individual kinds are as follows:
@@ -590,7 +614,7 @@ package body Sem_Prag is
Item_Id : Entity_Id;
Is_Input : Boolean;
Self_Ref : Boolean);
- -- Ensure that an item fulfils its designated input and/or output role
+ -- Ensure that an item fulfills its designated input and/or output role
-- as specified by pragma Global (if any) or the enclosing context. If
-- this is not the case, emit an error. Item and Item_Id denote the
-- attributes of an item. Flag Is_Input should be set when item comes
@@ -763,10 +787,31 @@ package body Sem_Prag is
Null_Seen : in out Boolean;
Non_Null_Seen : in out Boolean)
is
+ procedure Current_Task_Instance_Seen;
+ -- Set the appropriate global flag when the current instance of a
+ -- task unit is encountered.
+
+ --------------------------------
+ -- Current_Task_Instance_Seen --
+ --------------------------------
+
+ procedure Current_Task_Instance_Seen is
+ begin
+ if Is_Input then
+ Task_Input_Seen := True;
+ else
+ Task_Output_Seen := True;
+ end if;
+ end Current_Task_Instance_Seen;
+
+ -- Local variables
+
Is_Output : constant Boolean := not Is_Input;
Grouped : Node_Id;
Item_Id : Entity_Id;
+ -- Start of processing for Analyze_Input_Output
+
begin
-- Multiple input or output items appear as an aggregate
@@ -899,18 +944,45 @@ package body Sem_Prag is
Ekind_In (Item_Id, E_Abstract_State, E_Variable)
then
- -- The item denotes a concurrent type, but it is not the
- -- current instance of an enclosing concurrent type.
+ -- The item denotes a concurrent type. Note that single
+ -- protected/task types are not considered here because
+ -- they behave as objects in the context of pragma
+ -- [Refined_]Depends.
+
+ if Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then
+
+ -- This use is legal as long as the concurrent type is
+ -- the current instance of an enclosing type.
+
+ if Is_CCT_Instance (Item_Id, Spec_Id) then
+
+ -- The dependence of a task unit on itself is
+ -- implicit and may or may not be explicitly
+ -- specified (SPARK RM 6.1.4).
+
+ if Ekind (Item_Id) = E_Task_Type then
+ Current_Task_Instance_Seen;
+ end if;
+
+ -- Otherwise this is not the current instance
+
+ else
+ SPARK_Msg_N
+ ("invalid use of subtype mark in dependency "
+ & "relation", Item);
+ end if;
+
+ -- The dependency of a task unit on itself is implicit
+ -- and may or may not be explicitly specified
+ -- (SPARK RM 6.1.4).
- if Ekind_In (Item_Id, E_Protected_Type, E_Task_Type)
- and then not Is_CCT_Instance (Item)
+ elsif Is_Single_Task_Object (Item_Id)
+ and then Is_CCT_Instance (Item_Id, Spec_Id)
then
- SPARK_Msg_N
- ("invalid use of subtype mark in dependency "
- & "relation", Item);
+ Current_Task_Instance_Seen;
end if;
- -- Ensure that the item fulfils its role as input and/or
+ -- Ensure that the item fulfills its role as input and/or
-- output as specified by pragma Global or the enclosing
-- context.
@@ -1427,14 +1499,31 @@ package body Sem_Prag is
if Present (Item_Id)
and then not Contains (Used_Items, Item_Id)
then
- -- The current instance of a concurrent type behaves as a
- -- formal parameter (SPARK RM 6.1.4).
+ if Is_Formal (Item_Id) then
+ Usage_Error (Item_Id);
+
+ -- The current instance of a protected type behaves as a formal
+ -- parameter (SPARK RM 6.1.4).
- if Is_Formal (Item_Id)
- or else Ekind_In (Item_Id, E_Protected_Type, E_Task_Type)
+ elsif Ekind (Item_Id) = E_Protected_Type
+ or else Is_Single_Protected_Object (Item_Id)
then
Usage_Error (Item_Id);
+ -- The current instance of a task type behaves as a formal
+ -- parameter (SPARK RM 6.1.4).
+
+ elsif Ekind (Item_Id) = E_Task_Type
+ or else Is_Single_Task_Object (Item_Id)
+ then
+ -- The dependence of a task unit on itself is implicit and
+ -- may or may not be explicitly specified (SPARK RM 6.1.4).
+ -- Emit an error if only one input/output is present.
+
+ if Task_Input_Seen /= Task_Output_Seen then
+ Usage_Error (Item_Id);
+ end if;
+
-- States and global objects are not used properly only when
-- the subprogram is subject to pragma Global.
@@ -2036,20 +2125,18 @@ package body Sem_Prag is
end if;
-- A global item may denote a concurrent type as long as it is
- -- the current instance of an enclosing concurrent type
+ -- the current instance of an enclosing protected or task type
-- (SPARK RM 6.1.4).
elsif Ekind_In (Item_Id, E_Protected_Type, E_Task_Type) then
- if Is_CCT_Instance (Item) then
+ if Is_CCT_Instance (Item_Id, Spec_Id) then
-- Pragma [Refined_]Global associated with a protected
-- subprogram cannot mention the current instance of a
-- protected type because the instance behaves as a
-- formal parameter.
- if Ekind (Item_Id) = E_Protected_Type
- and then Scope (Spec_Id) = Item_Id
- then
+ if Ekind (Item_Id) = E_Protected_Type then
Error_Msg_Name_1 := Chars (Item_Id);
SPARK_Msg_NE
(Fix_Msg (Spec_Id, "global item of subprogram & "
@@ -2061,9 +2148,7 @@ package body Sem_Prag is
-- cannot mention the current instance of a task type
-- because the instance behaves as a formal parameter.
- elsif Ekind (Item_Id) = E_Task_Type
- and then Spec_Id = Item_Id
- then
+ else pragma Assert (Ekind (Item_Id) = E_Task_Type);
Error_Msg_Name_1 := Chars (Item_Id);
SPARK_Msg_NE
(Fix_Msg (Spec_Id, "global item of subprogram & "
@@ -2081,6 +2166,39 @@ package body Sem_Prag is
return;
end if;
+ -- A global item may denote the anonymous object created for a
+ -- single protected/task type as long as the current instance
+ -- is the same single type (SPARK RM 6.1.4).
+
+ elsif Is_Single_Concurrent_Object (Item_Id)
+ and then Is_CCT_Instance (Item_Id, Spec_Id)
+ then
+ -- Pragma [Refined_]Global associated with a protected
+ -- subprogram cannot mention the current instance of a
+ -- protected type because the instance behaves as a formal
+ -- parameter.
+
+ if Is_Single_Protected_Object (Item_Id) then
+ Error_Msg_Name_1 := Chars (Item_Id);
+ SPARK_Msg_NE
+ (Fix_Msg (Spec_Id, "global item of subprogram & cannot "
+ & "reference current instance of protected type %"),
+ Item, Spec_Id);
+ return;
+
+ -- Pragma [Refined_]Global associated with a task type
+ -- cannot mention the current instance of a task type
+ -- because the instance behaves as a formal parameter.
+
+ else pragma Assert (Is_Single_Task_Object (Item_Id));
+ Error_Msg_Name_1 := Chars (Item_Id);
+ SPARK_Msg_NE
+ (Fix_Msg (Spec_Id, "global item of subprogram & cannot "
+ & "reference current instance of task type %"),
+ Item, Spec_Id);
+ return;
+ end if;
+
-- A formal object may act as a global item inside a generic
elsif Is_Formal_Object (Item_Id) then
@@ -2210,7 +2328,7 @@ package body Sem_Prag is
-- An effectively volatile object with external property
-- Effective_Reads set to True must have mode Output or
- -- In_Out (SPARK RM 7.1.3(11)).
+ -- In_Out (SPARK RM 7.1.3(10)).
elsif Effective_Reads_Enabled (Item_Id)
and then Global_Mode = Name_Input
@@ -2541,12 +2659,16 @@ package body Sem_Prag is
-- Analyze_Initial_Condition_In_Decl_Part --
--------------------------------------------
+ -- WARNING: This routine manages Ghost regions. Return statements must be
+ -- replaced by gotos which jump to the end of the routine and restore the
+ -- Ghost mode.
+
procedure Analyze_Initial_Condition_In_Decl_Part (N : Node_Id) is
Pack_Decl : constant Node_Id := Find_Related_Package_Or_Body (N);
Pack_Id : constant Entity_Id := Defining_Entity (Pack_Decl);
Expr : constant Node_Id := Expression (Get_Argument (N, Pack_Id));
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
+ Mode : Ghost_Mode_Type;
begin
-- Do not analyze the pragma multiple times
@@ -2557,19 +2679,19 @@ package body Sem_Prag is
-- Set the Ghost mode in effect from the pragma. Due to the delayed
-- analysis of the pragma, the Ghost mode at point of declaration and
- -- point of analysis may not necessarely be the same. Use the mode in
+ -- point of analysis may not necessarily be the same. Use the mode in
-- effect at the point of declaration.
- Set_Ghost_Mode (N);
+ Set_Ghost_Mode (N, Mode);
-- The expression is preanalyzed because it has not been moved to its
-- final place yet. A direct analysis may generate side effects and this
-- is not desired at this point.
Preanalyze_Assert_Expression (Expr, Standard_Boolean);
- Ghost_Mode := Save_Ghost_Mode;
-
Set_Is_Analyzed_Pragma (N);
+
+ Restore_Ghost_Mode (Mode);
end Analyze_Initial_Condition_In_Decl_Part;
--------------------------------------
@@ -2725,6 +2847,7 @@ package body Sem_Prag is
procedure Analyze_Input_Item (Input : Node_Id) is
Input_Id : Entity_Id;
+ Input_OK : Boolean := True;
begin
-- Null input list
@@ -2759,6 +2882,8 @@ package body Sem_Prag is
if Ekind_In (Input_Id, E_Abstract_State,
E_Constant,
+ E_Generic_In_Out_Parameter,
+ E_Generic_In_Parameter,
E_In_Parameter,
E_In_Out_Parameter,
E_Out_Parameter,
@@ -2768,20 +2893,44 @@ package body Sem_Prag is
-- within the related package (SPARK RM 7.1.5(4)).
if Within_Scope (Input_Id, Current_Scope) then
- Error_Msg_Name_1 := Chars (Pack_Id);
- SPARK_Msg_NE
- ("input item & cannot denote a visible object or "
- & "state of package %", Input, Input_Id);
+
+ -- Do not consider generic formal parameters or their
+ -- respective mappings to generic formals. Even though
+ -- the formals appear within the scope of the package,
+ -- it is allowed for an initialization item to depend
+ -- on an input item.
+
+ if Ekind_In (Input_Id, E_Generic_In_Out_Parameter,
+ E_Generic_In_Parameter)
+ then
+ null;
+
+ elsif Ekind_In (Input_Id, E_Constant, E_Variable)
+ and then Present (Corresponding_Generic_Association
+ (Declaration_Node (Input_Id)))
+ then
+ null;
+
+ else
+ Input_OK := False;
+ Error_Msg_Name_1 := Chars (Pack_Id);
+ SPARK_Msg_NE
+ ("input item & cannot denote a visible object or "
+ & "state of package %", Input, Input_Id);
+ end if;
+ end if;
-- Detect a duplicate use of the same input item
-- (SPARK RM 7.1.5(5)).
- elsif Contains (Inputs_Seen, Input_Id) then
+ if Contains (Inputs_Seen, Input_Id) then
+ Input_OK := False;
SPARK_Msg_N ("duplicate input item", Input);
+ end if;
-- Input is legal, add it to the list of processed inputs
- else
+ if Input_OK then
Append_New_Elmt (Input_Id, Inputs_Seen);
if Ekind (Input_Id) = E_Abstract_State then
@@ -3159,7 +3308,7 @@ package body Sem_Prag is
elsif Ekind (Item_Id) = E_Constant then
Error_Msg_Name_1 := Chars (Encap_Id);
SPARK_Msg_NE
- (Fix_Msg (Encap_Typ, "consant & cannot act as constituent of "
+ (Fix_Msg (Encap_Typ, "constant & cannot act as constituent of "
& "single protected type %"), Indic, Item_Id);
-- The constituent is a package instantiation
@@ -3214,6 +3363,7 @@ package body Sem_Prag is
Errors : constant Nat := Serious_Errors_Detected;
Var_Decl : constant Node_Id := Find_Related_Context (N);
Var_Id : constant Entity_Id := Defining_Entity (Var_Decl);
+ Constits : Elist_Id;
Encap_Id : Entity_Id;
Legal : Boolean;
@@ -3234,9 +3384,22 @@ package body Sem_Prag is
if Legal then
pragma Assert (Present (Encap_Id));
+ Constits := Part_Of_Constituents (Encap_Id);
- Append_Elmt (Var_Id, Part_Of_Constituents (Encap_Id));
+ if No (Constits) then
+ Constits := New_Elmt_List;
+ Set_Part_Of_Constituents (Encap_Id, Constits);
+ end if;
+
+ Append_Elmt (Var_Id, Constits);
Set_Encapsulating_State (Var_Id, Encap_Id);
+
+ -- A Part_Of constituent partially refines an abstract state. This
+ -- property does not apply to protected or task units.
+
+ if Ekind (Encap_Id) = E_Abstract_State then
+ Set_Has_Partial_Visible_Refinement (Encap_Id);
+ end if;
end if;
-- Emit a clarification message when the encapsulator is undefined,
@@ -3258,7 +3421,7 @@ package body Sem_Prag is
Loc : constant Source_Ptr := Sloc (N);
Prag_Id : Pragma_Id;
- Pname : Name_Id;
+ Pname : Name_Id := Pragma_Name (N);
-- Name of the source pragma, or name of the corresponding aspect for
-- pragmas which originate in a source aspect. In the latter case, the
-- name may be different from the pragma name.
@@ -3329,6 +3492,16 @@ package body Sem_Prag is
-- related subprogram. Body_Id is the entity of the subprogram body.
-- Flag Legal is set when the pragma is legal.
+ procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False);
+ -- Perform full analysis of pragma Unmodified and the write aspect of
+ -- pragma Unused. Flag Is_Unused should be set when verifying the
+ -- semantics of pragma Unused.
+
+ procedure Analyze_Unreferenced_Or_Unused (Is_Unused : Boolean := False);
+ -- Perform full analysis of pragma Unreferenced and the read aspect of
+ -- pragma Unused. Flag Is_Unused should be set when verifying the
+ -- semantics of pragma Unused.
+
procedure Check_Ada_83_Warning;
-- Issues a warning message for the current pragma if operating in Ada
-- 83 mode (used for language pragmas that are not a standard part of
@@ -3749,7 +3922,7 @@ package body Sem_Prag is
-- Enabled: inlining is requested/required for the subprogram
procedure Process_Inline (Status : Inline_Status);
- -- Common processing for Inline, Inline_Always and No_Inline. Parameter
+ -- Common processing for No_Inline, Inline and Inline_Always. Parameter
-- indicates the inline status specified by the pragma.
procedure Process_Interface_Name
@@ -3972,7 +4145,7 @@ package body Sem_Prag is
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, Spec_Id);
+ Mark_Ghost_Pragma (N, Spec_Id);
Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
end Analyze_Depends_Global;
@@ -4155,16 +4328,16 @@ package body Sem_Prag is
Subp_Id := Defining_Entity (Subp_Decl);
+ -- A pragma that applies to a Ghost entity becomes Ghost for the
+ -- purposes of legality checks and removal of ignored Ghost code.
+
+ Mark_Ghost_Pragma (N, Subp_Id);
+
-- Chain the pragma on the contract for further processing by
-- Analyze_Pre_Post_Condition_In_Decl_Part.
Add_Contract_Item (N, Defining_Entity (Subp_Decl));
- -- A pragma that applies to a Ghost entity becomes Ghost for the
- -- purposes of legality checks and removal of ignored Ghost code.
-
- Mark_Pragma_As_Ghost (N, Subp_Id);
-
-- Fully analyze the pragma when it appears inside an entry or
-- subprogram body because it cannot benefit from forward references.
@@ -4285,13 +4458,284 @@ package body Sem_Prag is
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, Spec_Id);
+ Mark_Ghost_Pragma (N, Spec_Id);
if Nam_In (Pname, Name_Refined_Depends, Name_Refined_Global) then
Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
end if;
end Analyze_Refined_Depends_Global_Post;
+ ----------------------------------
+ -- Analyze_Unmodified_Or_Unused --
+ ----------------------------------
+
+ procedure Analyze_Unmodified_Or_Unused (Is_Unused : Boolean := False) is
+ Arg : Node_Id;
+ Arg_Expr : Node_Id;
+ Arg_Id : Entity_Id;
+
+ Ghost_Error_Posted : Boolean := False;
+ -- Flag set when an error concerning the illegal mix of Ghost and
+ -- non-Ghost variables is emitted.
+
+ Ghost_Id : Entity_Id := Empty;
+ -- The entity of the first Ghost variable encountered while
+ -- processing the arguments of the pragma.
+
+ begin
+ GNAT_Pragma;
+ Check_At_Least_N_Arguments (1);
+
+ -- Loop through arguments
+
+ Arg := Arg1;
+ while Present (Arg) loop
+ Check_No_Identifier (Arg);
+
+ -- Note: the analyze call done by Check_Arg_Is_Local_Name will
+ -- in fact generate reference, so that the entity will have a
+ -- reference, which will inhibit any warnings about it not
+ -- being referenced, and also properly show up in the ali file
+ -- as a reference. But this reference is recorded before the
+ -- Has_Pragma_Unreferenced flag is set, so that no warning is
+ -- generated for this reference.
+
+ Check_Arg_Is_Local_Name (Arg);
+ Arg_Expr := Get_Pragma_Arg (Arg);
+
+ if Is_Entity_Name (Arg_Expr) then
+ Arg_Id := Entity (Arg_Expr);
+
+ -- Skip processing the argument if already flagged
+
+ if Is_Assignable (Arg_Id)
+ and then not Has_Pragma_Unmodified (Arg_Id)
+ and then not Has_Pragma_Unused (Arg_Id)
+ then
+ Set_Has_Pragma_Unmodified (Arg_Id);
+
+ if Is_Unused then
+ Set_Has_Pragma_Unused (Arg_Id);
+ end if;
+
+ -- A pragma that applies to a Ghost entity becomes Ghost for
+ -- the purposes of legality checks and removal of ignored
+ -- Ghost code.
+
+ Mark_Ghost_Pragma (N, Arg_Id);
+
+ -- Capture the entity of the first Ghost variable being
+ -- processed for error detection purposes.
+
+ if Is_Ghost_Entity (Arg_Id) then
+ if No (Ghost_Id) then
+ Ghost_Id := Arg_Id;
+ end if;
+
+ -- Otherwise the variable is non-Ghost. It is illegal to mix
+ -- references to Ghost and non-Ghost entities
+ -- (SPARK RM 6.9).
+
+ elsif Present (Ghost_Id)
+ and then not Ghost_Error_Posted
+ then
+ Ghost_Error_Posted := True;
+
+ Error_Msg_Name_1 := Pname;
+ Error_Msg_N
+ ("pragma % cannot mention ghost and non-ghost "
+ & "variables", N);
+
+ Error_Msg_Sloc := Sloc (Ghost_Id);
+ Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
+
+ Error_Msg_Sloc := Sloc (Arg_Id);
+ Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
+ end if;
+
+ -- Warn if already flagged as Unused or Unmodified
+
+ elsif Has_Pragma_Unmodified (Arg_Id) then
+ if Has_Pragma_Unused (Arg_Id) then
+ Error_Msg_NE
+ ("??pragma Unused already given for &!", Arg_Expr,
+ Arg_Id);
+ else
+ Error_Msg_NE
+ ("??pragma Unmodified already given for &!", Arg_Expr,
+ Arg_Id);
+ end if;
+
+ -- Otherwise the pragma referenced an illegal entity
+
+ else
+ Error_Pragma_Arg
+ ("pragma% can only be applied to a variable", Arg_Expr);
+ end if;
+ end if;
+
+ Next (Arg);
+ end loop;
+ end Analyze_Unmodified_Or_Unused;
+
+ -----------------------------------
+ -- Analyze_Unreference_Or_Unused --
+ -----------------------------------
+
+ procedure Analyze_Unreferenced_Or_Unused
+ (Is_Unused : Boolean := False)
+ is
+ Arg : Node_Id;
+ Arg_Expr : Node_Id;
+ Arg_Id : Entity_Id;
+ Citem : Node_Id;
+
+ Ghost_Error_Posted : Boolean := False;
+ -- Flag set when an error concerning the illegal mix of Ghost and
+ -- non-Ghost names is emitted.
+
+ Ghost_Id : Entity_Id := Empty;
+ -- The entity of the first Ghost name encountered while processing
+ -- the arguments of the pragma.
+
+ begin
+ GNAT_Pragma;
+ Check_At_Least_N_Arguments (1);
+
+ -- Check case of appearing within context clause
+
+ if not Is_Unused and then Is_In_Context_Clause then
+
+ -- The arguments must all be units mentioned in a with clause in
+ -- the same context clause. Note that Par.Prag already checked
+ -- that the arguments are either identifiers or selected
+ -- components.
+
+ Arg := Arg1;
+ while Present (Arg) loop
+ Citem := First (List_Containing (N));
+ while Citem /= N loop
+ Arg_Expr := Get_Pragma_Arg (Arg);
+
+ if Nkind (Citem) = N_With_Clause
+ and then Same_Name (Name (Citem), Arg_Expr)
+ then
+ Set_Has_Pragma_Unreferenced
+ (Cunit_Entity
+ (Get_Source_Unit
+ (Library_Unit (Citem))));
+ Set_Elab_Unit_Name (Arg_Expr, Name (Citem));
+ exit;
+ end if;
+
+ Next (Citem);
+ end loop;
+
+ if Citem = N then
+ Error_Pragma_Arg
+ ("argument of pragma% is not withed unit", Arg);
+ end if;
+
+ Next (Arg);
+ end loop;
+
+ -- Case of not in list of context items
+
+ else
+ Arg := Arg1;
+ while Present (Arg) loop
+ Check_No_Identifier (Arg);
+
+ -- Note: the analyze call done by Check_Arg_Is_Local_Name will
+ -- in fact generate reference, so that the entity will have a
+ -- reference, which will inhibit any warnings about it not
+ -- being referenced, and also properly show up in the ali file
+ -- as a reference. But this reference is recorded before the
+ -- Has_Pragma_Unreferenced flag is set, so that no warning is
+ -- generated for this reference.
+
+ Check_Arg_Is_Local_Name (Arg);
+ Arg_Expr := Get_Pragma_Arg (Arg);
+
+ if Is_Entity_Name (Arg_Expr) then
+ Arg_Id := Entity (Arg_Expr);
+
+ -- Warn if already flagged as Unused or Unreferenced and
+ -- skip processing the argument.
+
+ if Has_Pragma_Unreferenced (Arg_Id) then
+ if Has_Pragma_Unused (Arg_Id) then
+ Error_Msg_NE
+ ("??pragma Unused already given for &!", Arg_Expr,
+ Arg_Id);
+ else
+ Error_Msg_NE
+ ("??pragma Unreferenced already given for &!",
+ Arg_Expr, Arg_Id);
+ end if;
+
+ -- Apply Unreferenced to the entity
+
+ else
+ -- If the entity is overloaded, the pragma applies to the
+ -- most recent overloading, as documented. In this case,
+ -- name resolution does not generate a reference, so it
+ -- must be done here explicitly.
+
+ if Is_Overloaded (Arg_Expr) then
+ Generate_Reference (Arg_Id, N);
+ end if;
+
+ Set_Has_Pragma_Unreferenced (Arg_Id);
+
+ if Is_Unused then
+ Set_Has_Pragma_Unused (Arg_Id);
+ end if;
+
+ -- A pragma that applies to a Ghost entity becomes Ghost
+ -- for the purposes of legality checks and removal of
+ -- ignored Ghost code.
+
+ Mark_Ghost_Pragma (N, Arg_Id);
+
+ -- Capture the entity of the first Ghost name being
+ -- processed for error detection purposes.
+
+ if Is_Ghost_Entity (Arg_Id) then
+ if No (Ghost_Id) then
+ Ghost_Id := Arg_Id;
+ end if;
+
+ -- Otherwise the name is non-Ghost. It is illegal to mix
+ -- references to Ghost and non-Ghost entities
+ -- (SPARK RM 6.9).
+
+ elsif Present (Ghost_Id)
+ and then not Ghost_Error_Posted
+ then
+ Ghost_Error_Posted := True;
+
+ Error_Msg_Name_1 := Pname;
+ Error_Msg_N
+ ("pragma % cannot mention ghost and non-ghost "
+ & "names", N);
+
+ Error_Msg_Sloc := Sloc (Ghost_Id);
+ Error_Msg_NE
+ ("\& # declared as ghost", N, Ghost_Id);
+
+ Error_Msg_Sloc := Sloc (Arg_Id);
+ Error_Msg_NE
+ ("\& # declared as non-ghost", N, Arg_Id);
+ end if;
+ end if;
+ end if;
+
+ Next (Arg);
+ end loop;
+ end if;
+ end Analyze_Unreferenced_Or_Unused;
+
--------------------------
-- Check_Ada_83_Warning --
--------------------------
@@ -4432,6 +4876,25 @@ package body Sem_Prag is
Argx : constant Node_Id := Get_Pragma_Arg (Arg);
begin
+ -- If this pragma came from an aspect specification, we don't want to
+ -- check for this error, because that would cause spurious errors, in
+ -- case a type is frozen in a scope more nested than the type. The
+ -- aspect itself of course can't be anywhere but on the declaration
+ -- itself.
+
+ if Nkind (Arg) = N_Pragma_Argument_Association then
+ if From_Aspect_Specification (Parent (Arg)) then
+ return;
+ end if;
+
+ -- Arg is the Expression of an N_Pragma_Argument_Association
+
+ else
+ if From_Aspect_Specification (Parent (Parent (Arg))) then
+ return;
+ end if;
+ end if;
+
Analyze (Argx);
if Nkind (Argx) not in N_Direct_Name
@@ -4505,7 +4968,7 @@ package body Sem_Prag is
then
OK := True;
- -- If the aspect is a predicate (possibly others ???) and the
+ -- If the aspect is a predicate (possibly others ???) and the
-- context is a record type, this is a discriminant expression
-- within a type declaration, that freezes the predicated
-- subtype.
@@ -4905,12 +5368,15 @@ package body Sem_Prag is
Analyze_And_Resolve (Expr);
end if;
- if Is_OK_Static_Expression (Expr) then
- return;
+ -- An expression cannot be considered static if its resolution failed
+ -- or if it's erroneous. Stop the analysis of the related pragma.
- elsif Etype (Expr) = Any_Type then
+ if Etype (Expr) = Any_Type or else Error_Posted (Expr) then
raise Pragma_Exit;
+ elsif Is_OK_Static_Expression (Expr) then
+ return;
+
-- An interesting special case, if we have a string literal and we
-- are in Ada 83 mode, then we allow it even though it will not be
-- flagged as static. This allows the use of Ada 95 pragmas like
@@ -4922,12 +5388,6 @@ package body Sem_Prag is
then
return;
- -- Static expression that raises Constraint_Error. This has already
- -- been flagged, so just exit from pragma processing.
-
- elsif Is_OK_Static_Expression (Expr) then
- raise Pragma_Exit;
-
-- Finally, we have a real error
else
@@ -5049,32 +5509,22 @@ package body Sem_Prag is
Handler_Proc := Find_Unique_Parameterless_Procedure (Arg1_X, Arg1);
Proc_Scope := Scope (Handler_Proc);
- -- On AAMP only, a pragma Interrupt_Handler is supported for
- -- nonprotected parameterless procedures.
-
- if not AAMP_On_Target
- or else Prag_Id = Pragma_Attach_Handler
- then
- if Ekind (Proc_Scope) /= E_Protected_Type then
- Error_Pragma_Arg
- ("argument of pragma% must be protected procedure", Arg1);
- end if;
+ if Ekind (Proc_Scope) /= E_Protected_Type then
+ Error_Pragma_Arg
+ ("argument of pragma% must be protected procedure", Arg1);
+ end if;
- -- For pragma case (as opposed to access case), check placement.
- -- We don't need to do that for aspects, because we have the
- -- check that they aspect applies an appropriate procedure.
+ -- For pragma case (as opposed to access case), check placement.
+ -- We don't need to do that for aspects, because we have the
+ -- check that they aspect applies an appropriate procedure.
- if not From_Aspect_Specification (N)
- and then Parent (N) /= Protected_Definition (Parent (Proc_Scope))
- then
- Error_Pragma ("pragma% must be in protected definition");
- end if;
+ if not From_Aspect_Specification (N)
+ and then Parent (N) /= Protected_Definition (Parent (Proc_Scope))
+ then
+ Error_Pragma ("pragma% must be in protected definition");
end if;
- if not Is_Library_Level_Entity (Proc_Scope)
- or else (AAMP_On_Target
- and then not Is_Library_Level_Entity (Handler_Proc))
- then
+ if not Is_Library_Level_Entity (Proc_Scope) then
Error_Pragma_Arg
("argument for pragma% must be library level entity", Arg1);
end if;
@@ -5274,7 +5724,7 @@ package body Sem_Prag is
if Nkind (Original_Node (Stmt)) = N_Pragma then
return
- Nam_In (Pragma_Name (Original_Node (Stmt)),
+ Nam_In (Pragma_Name_Unmapped (Original_Node (Stmt)),
Name_Loop_Invariant,
Name_Loop_Variant);
else
@@ -6313,11 +6763,6 @@ package body Sem_Prag is
------------------------------------------------
procedure Process_Atomic_Independent_Shared_Volatile is
- D : Node_Id;
- E : Entity_Id;
- E_Id : Node_Id;
- K : Node_Kind;
-
procedure Set_Atomic_VFA (E : Entity_Id);
-- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
-- no explicit alignment was given, set alignment to unknown, since
@@ -6341,6 +6786,12 @@ package body Sem_Prag is
end if;
end Set_Atomic_VFA;
+ -- Local variables
+
+ Decl : Node_Id;
+ E : Entity_Id;
+ E_Arg : Node_Id;
+
-- Start of processing for Process_Atomic_Independent_Shared_Volatile
begin
@@ -6348,20 +6799,18 @@ package body Sem_Prag is
Check_No_Identifiers;
Check_Arg_Count (1);
Check_Arg_Is_Local_Name (Arg1);
- E_Id := Get_Pragma_Arg (Arg1);
+ E_Arg := Get_Pragma_Arg (Arg1);
- if Etype (E_Id) = Any_Type then
+ if Etype (E_Arg) = Any_Type then
return;
end if;
- E := Entity (E_Id);
- D := Declaration_Node (E);
- K := Nkind (D);
+ E := Entity (E_Arg);
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, E);
+ Mark_Ghost_Pragma (N, E);
-- Check duplicate before we chain ourselves
@@ -6418,6 +6867,8 @@ package body Sem_Prag is
-- Now check appropriateness of the entity
+ Decl := Declaration_Node (E);
+
if Is_Type (E) then
if Rep_Item_Too_Early (E, N)
or else
@@ -6465,8 +6916,8 @@ package body Sem_Prag is
Set_Treat_As_Volatile (Underlying_Type (E));
end if;
- elsif K = N_Object_Declaration
- or else (K = N_Component_Declaration
+ elsif Nkind (Decl) = N_Object_Declaration
+ or else (Nkind (Decl) = N_Component_Declaration
and then Original_Record_Component (E) = E)
then
if Rep_Item_Too_Late (E, N) then
@@ -6520,12 +6971,15 @@ package body Sem_Prag is
-- The following check is only relevant when SPARK_Mode is on as
-- this is not a standard Ada legality rule. Pragma Volatile can
-- only apply to a full type declaration or an object declaration
- -- (SPARK RM C.6(1)).
+ -- (SPARK RM C.6(1)). Original_Node is necessary to account for
+ -- untagged derived types that are rewritten as subtypes of their
+ -- respective root types.
if SPARK_Mode = On
and then Prag_Id = Pragma_Volatile
- and then not Nkind_In (K, N_Full_Type_Declaration,
- N_Object_Declaration)
+ and then
+ not Nkind_In (Original_Node (Decl), N_Full_Type_Declaration,
+ N_Object_Declaration)
then
Error_Pragma_Arg
("argument of pragma % must denote a full type or object "
@@ -6538,102 +6992,64 @@ package body Sem_Prag is
-------------------------------------------
procedure Process_Compile_Time_Warning_Or_Error is
- Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
+ Validation_Needed : Boolean := False;
- begin
- Check_Arg_Count (2);
- Check_No_Identifiers;
- Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
- Analyze_And_Resolve (Arg1x, Standard_Boolean);
+ function Check_Node (N : Node_Id) return Traverse_Result;
+ -- Tree visitor that checks if N is an attribute reference that can
+ -- be statically computed by the back end. Validation_Needed is set
+ -- to True if found.
- if Compile_Time_Known_Value (Arg1x) then
- if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then
- declare
- Str : constant String_Id :=
- Strval (Get_Pragma_Arg (Arg2));
- Len : constant Int := String_Length (Str);
- Cont : Boolean;
- Ptr : Nat;
- CC : Char_Code;
- C : Character;
- Cent : constant Entity_Id :=
- Cunit_Entity (Current_Sem_Unit);
-
- Force : constant Boolean :=
- Prag_Id = Pragma_Compile_Time_Warning
- and then
- Is_Spec_Name (Unit_Name (Current_Sem_Unit))
- and then (Ekind (Cent) /= E_Package
- or else not In_Private_Part (Cent));
- -- Set True if this is the warning case, and we are in the
- -- visible part of a package spec, or in a subprogram spec,
- -- in which case we want to force the client to see the
- -- warning, even though it is not in the main unit.
+ ----------------
+ -- Check_Node --
+ ----------------
+ function Check_Node (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) = N_Attribute_Reference
+ and then Is_Entity_Name (Prefix (N))
+ then
+ declare
+ Attr_Id : constant Attribute_Id :=
+ Get_Attribute_Id (Attribute_Name (N));
begin
- -- Loop through segments of message separated by line feeds.
- -- We output these segments as separate messages with
- -- continuation marks for all but the first.
-
- Cont := False;
- Ptr := 1;
- loop
- Error_Msg_Strlen := 0;
-
- -- Loop to copy characters from argument to error message
- -- string buffer.
+ if Attr_Id = Attribute_Alignment
+ or else Attr_Id = Attribute_Size
+ then
+ Validation_Needed := True;
+ end if;
+ end;
+ end if;
- loop
- exit when Ptr > Len;
- CC := Get_String_Char (Str, Ptr);
- Ptr := Ptr + 1;
+ return OK;
+ end Check_Node;
- -- Ignore wide chars ??? else store character
+ procedure Check_Expression is new Traverse_Proc (Check_Node);
- if In_Character_Range (CC) then
- C := Get_Character (CC);
- exit when C = ASCII.LF;
- Error_Msg_Strlen := Error_Msg_Strlen + 1;
- Error_Msg_String (Error_Msg_Strlen) := C;
- end if;
- end loop;
+ -- Local variables
- -- Here with one line ready to go
+ Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
- Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
+ -- Start of processing for Process_Compile_Time_Warning_Or_Error
- -- If this is a warning in a spec, then we want clients
- -- to see the warning, so mark the message with the
- -- special sequence !! to force the warning. In the case
- -- of a package spec, we do not force this if we are in
- -- the private part of the spec.
+ begin
+ Check_Arg_Count (2);
+ Check_No_Identifiers;
+ Check_Arg_Is_OK_Static_Expression (Arg2, Standard_String);
+ Analyze_And_Resolve (Arg1x, Standard_Boolean);
- if Force then
- if Cont = False then
- Error_Msg_N ("<<~!!", Arg1);
- Cont := True;
- else
- Error_Msg_N ("\<<~!!", Arg1);
- end if;
+ if Compile_Time_Known_Value (Arg1x) then
+ Process_Compile_Time_Warning_Or_Error (N, Sloc (Arg1));
- -- Error, rather than warning, or in a body, so we do not
- -- need to force visibility for client (error will be
- -- output in any case, and this is the situation in which
- -- we do not want a client to get a warning, since the
- -- warning is in the body or the spec private part).
+ -- Register the expression for its validation after the back end has
+ -- been called if it has occurrences of attributes Size or Alignment
+ -- (because they may be statically computed by the back end and hence
+ -- the whole expression needs to be reevaluated).
- else
- if Cont = False then
- Error_Msg_N ("<<~", Arg1);
- Cont := True;
- else
- Error_Msg_N ("\<<~", Arg1);
- end if;
- end if;
+ else
+ Check_Expression (Arg1x);
- exit when Ptr > Len;
- end loop;
- end;
+ if Validation_Needed then
+ Sem_Ch13.Validate_Compile_Time_Warning_Error (N);
end if;
end if;
end Process_Compile_Time_Warning_Or_Error;
@@ -6771,16 +7187,17 @@ package body Sem_Prag is
then
-- Give error if same as our pragma or Export/Convention
- if Nam_In (Pragma_Name (Decl), Name_Export,
- Name_Convention,
- Pragma_Name (N))
+ if Nam_In (Pragma_Name_Unmapped (Decl),
+ Name_Export,
+ Name_Convention,
+ Pragma_Name_Unmapped (N))
then
exit;
-- Case of Import/Interface or the other way round
- elsif Nam_In (Pragma_Name (Decl), Name_Interface,
- Name_Import)
+ elsif Nam_In (Pragma_Name_Unmapped (Decl),
+ Name_Interface, Name_Import)
then
-- Here we know that we have Import and Interface. It
-- doesn't matter which way round they are. See if
@@ -7139,8 +7556,12 @@ package body Sem_Prag is
if C = Convention_Intrinsic
and then not Is_Subprogram_Or_Generic_Subprogram (E)
then
- Error_Pragma_Arg
- ("second argument of pragma% must be a subprogram", Arg2);
+ -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
+
+ if not (Is_Type (E) and then Relaxed_RM_Semantics) then
+ Error_Pragma_Arg
+ ("second argument of pragma% must be a subprogram", Arg2);
+ end if;
end if;
-- Deal with non-subprogram cases
@@ -7217,6 +7638,17 @@ package body Sem_Prag is
goto Continue;
end if;
+ if Is_Subprogram (E1)
+ and then Nkind (Parent (Declaration_Node (E1))) =
+ N_Subprogram_Body
+ and then not Relaxed_RM_Semantics
+ then
+ Set_Has_Completion (E); -- to prevent cascaded error
+ Error_Pragma_Ref
+ ("pragma% requires separate spec and must come before "
+ & "body#", E1);
+ end if;
+
-- Do not set the pragma on inherited operations or on formal
-- subprograms.
@@ -7261,8 +7693,7 @@ package body Sem_Prag is
Rewrite (N,
Make_Pragma (Loc,
- Pragma_Identifier =>
- Make_Identifier (Loc, Nam),
+ Chars => Nam,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression =>
@@ -7951,7 +8382,7 @@ package body Sem_Prag is
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, Def_Id);
+ Mark_Ghost_Pragma (N, Def_Id);
Kill_Size_Check_Code (Def_Id);
Note_Possible_Modification (Get_Pragma_Arg (Arg2), Sure => False);
end if;
@@ -8324,21 +8755,20 @@ package body Sem_Prag is
-- processing the arguments of the pragma.
procedure Make_Inline (Subp : Entity_Id);
- -- Subp is the defining unit name of the subprogram declaration. Set
- -- the flag, as well as the flag in the corresponding body, if there
- -- is one present.
+ -- Subp is the defining unit name of the subprogram declaration. If
+ -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
+ -- the corresponding body, if there is one present.
procedure Set_Inline_Flags (Subp : Entity_Id);
- -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
- -- Has_Pragma_Inline_Always for the Inline_Always case.
+ -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
+ -- Also set or clear Is_Inlined flag on Subp depending on Status.
function Inlining_Not_Possible (Subp : Entity_Id) return Boolean;
-- Returns True if it can be determined at this stage that inlining
-- is not possible, for example if the body is available and contains
-- exception handlers, we prevent inlining, since otherwise we can
-- get undefined symbols at link time. This function also emits a
- -- warning if front-end inlining is enabled and the pragma appears
- -- too late.
+ -- warning if the pragma appears too late.
--
-- ??? is business with link symbols still valid, or does it relate
-- to front end ZCX which is being phased out ???
@@ -8360,9 +8790,7 @@ package body Sem_Prag is
elsif Nkind (Decl) = N_Subprogram_Declaration
and then Present (Corresponding_Body (Decl))
then
- if Front_End_Inlining
- and then Analyzed (Corresponding_Body (Decl))
- then
+ if Analyzed (Corresponding_Body (Decl)) then
Error_Msg_N ("pragma appears too late, ignored??", N);
return True;
@@ -8412,6 +8840,7 @@ package body Sem_Prag is
-- If inlining is not possible, for now do not treat as an error
elsif Status /= Suppressed
+ and then Front_End_Inlining
and then Inlining_Not_Possible (Subp)
then
Applies := True;
@@ -8459,9 +8888,16 @@ package body Sem_Prag is
-- Processing for procedure, operator or function. If subprogram
-- is aliased (as for an instance) indicate that the renamed
-- entity (if declared in the same unit) is inlined.
+ -- If this is the anonymous subprogram created for a subprogram
+ -- instance, the inlining applies to it directly. Otherwise we
+ -- retrieve it as the alias of the visible subprogram instance.
if Is_Subprogram (Subp) then
- Inner_Subp := Ultimate_Alias (Inner_Subp);
+ if Is_Wrapper_Package (Scope (Subp)) then
+ Inner_Subp := Subp;
+ else
+ Inner_Subp := Ultimate_Alias (Inner_Subp);
+ end if;
if In_Same_Source_Unit (Subp, Inner_Subp) then
Set_Inline_Flags (Inner_Subp);
@@ -8473,18 +8909,20 @@ package body Sem_Prag is
then
Set_Inline_Flags (Corresponding_Body (Decl));
- elsif Is_Generic_Instance (Subp) then
-
+ elsif Is_Generic_Instance (Subp)
+ and then Comes_From_Source (Subp)
+ then
-- Indicate that the body needs to be created for
-- inlining subsequent calls. The instantiation node
-- follows the declaration of the wrapper package
- -- created for it.
+ -- created for it. The subprogram that requires the
+ -- body is the anonymous one in the wrapper package.
if Scope (Subp) /= Standard_Standard
and then
Need_Subprogram_Instance_Body
- (Next (Unit_Declaration_Node (Scope (Alias (Subp)))),
- Subp)
+ (Next (Unit_Declaration_Node
+ (Scope (Alias (Subp)))), Subp)
then
null;
end if;
@@ -8572,9 +9010,7 @@ package body Sem_Prag is
end if;
end if;
- if not Has_Pragma_Inline (Subp) then
- Set_Has_Pragma_Inline (Subp);
- end if;
+ Set_Has_Pragma_Inline (Subp);
end if;
-- Then adjust the Is_Inlined flag. It can never be set if the
@@ -8583,8 +9019,10 @@ package body Sem_Prag is
case Status is
when Suppressed =>
Set_Is_Inlined (Subp, False);
+
when Disabled =>
null;
+
when Enabled =>
if not Has_Pragma_No_Inline (Subp) then
Set_Is_Inlined (Subp, True);
@@ -8594,7 +9032,7 @@ package body Sem_Prag is
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, Subp);
+ Mark_Ghost_Pragma (N, Subp);
-- Capture the entity of the first Ghost subprogram being
-- processed for error detection purposes.
@@ -8854,17 +9292,12 @@ package body Sem_Prag is
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, Handler);
+ Mark_Ghost_Pragma (N, Handler);
Set_Is_Interrupt_Handler (Handler);
- -- If the pragma is not associated with a handler procedure within a
- -- protected type, then it must be for a nonprotected procedure for
- -- the AAMP target, in which case we don't associate a representation
- -- item with the procedure's scope.
+ pragma Assert (Ekind (Prot_Typ) = E_Protected_Type);
- if Ekind (Prot_Typ) = E_Protected_Type then
- Record_Rep_Item (Prot_Typ, N);
- end if;
+ Record_Rep_Item (Prot_Typ, N);
-- Chain the pragma on the contract for completeness
@@ -9352,7 +9785,7 @@ package body Sem_Prag is
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, E);
+ Mark_Ghost_Pragma (N, E);
-- Enforce RM 11.5(7) which requires that for a pragma that
-- appears within a package spec, the named entity must be
@@ -9752,7 +10185,7 @@ package body Sem_Prag is
begin
Get_Name_String (Chars (Prof_Nam));
- Adjust_Name_Case (Sloc (Prof_Nam));
+ Adjust_Name_Case (Global_Name_Buffer, Sloc (Prof_Nam));
Error_Msg_Strlen := Name_Len;
Error_Msg_String (1 .. Name_Len) := Name_Buffer (1 .. Name_Len);
end Set_Error_Msg_To_Profile_Name;
@@ -9935,9 +10368,15 @@ package body Sem_Prag is
Set_Analyzed (N);
end if;
- -- Deal with unrecognized pragma
+ Check_Restriction_No_Use_Of_Pragma (N);
+
+ -- Ignore pragma if Ignore_Pragma applies
+
+ if Get_Name_Table_Boolean3 (Pname) then
+ return;
+ end if;
- Pname := Pragma_Name (N);
+ -- Deal with unrecognized pragma
if not Is_Pragma_Name (Pname) then
if Warn_On_Unrecognized_Pragma then
@@ -9957,12 +10396,6 @@ package body Sem_Prag is
return;
end if;
- -- Ignore pragma if Ignore_Pragma applies
-
- if Get_Name_Table_Boolean3 (Pname) then
- return;
- end if;
-
-- Here to start processing for recognized pragma
Prag_Id := Get_Pragma_Id (Pname);
@@ -9973,10 +10406,13 @@ package body Sem_Prag is
case Opt.Uneval_Old is
when 'A' =>
Set_Uneval_Old_Accept (N);
+
when 'E' =>
null;
+
when 'W' =>
Set_Uneval_Old_Warn (N);
+
when others =>
raise Program_Error;
end case;
@@ -10038,8 +10474,6 @@ package body Sem_Prag is
end if;
end if;
- Check_Restriction_No_Use_Of_Pragma (N);
-
-- An enumeration type defines the pragmas that are supported by the
-- implementation. Get_Pragma_Id (in package Prag) transforms a name
-- into the corresponding enumeration value for the following case.
@@ -10408,6 +10842,7 @@ package body Sem_Prag is
procedure Analyze_Part_Of_Option (Opt : Node_Id) is
Encap : constant Node_Id := Expression (Opt);
+ Constits : Elist_Id;
Encap_Id : Entity_Id;
Legal : Boolean;
@@ -10427,8 +10862,14 @@ package body Sem_Prag is
if Legal then
pragma Assert (Present (Encap_Id));
+ Constits := Part_Of_Constituents (Encap_Id);
+
+ if No (Constits) then
+ Constits := New_Elmt_List;
+ Set_Part_Of_Constituents (Encap_Id, Constits);
+ end if;
- Append_Elmt (State_Id, Part_Of_Constituents (Encap_Id));
+ Append_Elmt (State_Id, Constits);
Set_Encapsulating_State (State_Id, Encap_Id);
end if;
end Analyze_Part_Of_Option;
@@ -10510,13 +10951,11 @@ package body Sem_Prag is
-- Null states never come from source
- Set_Comes_From_Source (State_Id, not Is_Null);
- Set_Parent (State_Id, State);
- Set_Ekind (State_Id, E_Abstract_State);
- Set_Etype (State_Id, Standard_Void_Type);
- Set_Encapsulating_State (State_Id, Empty);
- Set_Refinement_Constituents (State_Id, New_Elmt_List);
- Set_Part_Of_Constituents (State_Id, New_Elmt_List);
+ Set_Comes_From_Source (State_Id, not Is_Null);
+ Set_Parent (State_Id, State);
+ Set_Ekind (State_Id, E_Abstract_State);
+ Set_Etype (State_Id, Standard_Void_Type);
+ Set_Encapsulating_State (State_Id, Empty);
-- An abstract state declared within a Ghost region becomes
-- Ghost (SPARK RM 6.9(2)).
@@ -10804,6 +11243,12 @@ package body Sem_Prag is
Pack_Id := Defining_Entity (Pack_Decl);
+ -- A pragma that applies to a Ghost entity becomes Ghost for the
+ -- purposes of legality checks and removal of ignored Ghost code.
+
+ Mark_Ghost_Pragma (N, Pack_Id);
+ Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
+
-- Chain the pragma on the contract for completeness
Add_Contract_Item (N, Pack_Id);
@@ -10819,13 +11264,6 @@ package body Sem_Prag is
-- Analyze all these pragmas in the order outlined above
Analyze_If_Present (Pragma_SPARK_Mode);
-
- -- A pragma that applies to a Ghost entity becomes Ghost for the
- -- purposes of legality checks and removal of ignored Ghost code.
-
- Mark_Pragma_As_Ghost (N, Pack_Id);
- Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
-
States := Expression (Get_Argument (N, Pack_Id));
-- Multiple non-null abstract states appear as an aggregate
@@ -10889,9 +11327,11 @@ package body Sem_Prag is
-- Now set Ada 83 mode
- Ada_Version := Ada_83;
- Ada_Version_Explicit := Ada_83;
- Ada_Version_Pragma := N;
+ if not Latest_Ada_Only then
+ Ada_Version := Ada_83;
+ Ada_Version_Explicit := Ada_83;
+ Ada_Version_Pragma := N;
+ end if;
------------
-- Ada_95 --
@@ -10921,9 +11361,11 @@ package body Sem_Prag is
-- Now set Ada 95 mode
- Ada_Version := Ada_95;
- Ada_Version_Explicit := Ada_95;
- Ada_Version_Pragma := N;
+ if not Latest_Ada_Only then
+ Ada_Version := Ada_95;
+ Ada_Version_Explicit := Ada_95;
+ Ada_Version_Pragma := N;
+ end if;
---------------------
-- Ada_05/Ada_2005 --
@@ -10948,7 +11390,10 @@ package body Sem_Prag is
-- otherwise legal pre-Ada_2005 programs. The one argument form is
-- intended for exclusive use in the GNAT run-time library.
- when Pragma_Ada_05 | Pragma_Ada_2005 => declare
+ when Pragma_Ada_05
+ | Pragma_Ada_2005
+ =>
+ declare
E_Id : Node_Id;
begin
@@ -10978,9 +11423,11 @@ package body Sem_Prag is
-- Now set appropriate Ada mode
- Ada_Version := Ada_2005;
- Ada_Version_Explicit := Ada_2005;
- Ada_Version_Pragma := N;
+ if not Latest_Ada_Only then
+ Ada_Version := Ada_2005;
+ Ada_Version_Explicit := Ada_2005;
+ Ada_Version_Pragma := N;
+ end if;
end if;
end;
@@ -11007,7 +11454,10 @@ package body Sem_Prag is
-- otherwise legal pre-Ada_2012 programs. The one argument form is
-- intended for exclusive use in the GNAT run-time library.
- when Pragma_Ada_12 | Pragma_Ada_2012 => declare
+ when Pragma_Ada_12
+ | Pragma_Ada_2012
+ =>
+ declare
E_Id : Node_Id;
begin
@@ -11066,7 +11516,7 @@ package body Sem_Prag is
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, Lib_Entity);
+ Mark_Ghost_Pragma (N, Lib_Entity);
-- This pragma should only apply to a RCI unit (RM E.2.3(23))
@@ -11142,7 +11592,7 @@ package body Sem_Prag is
if Is_Entity_Name (Get_Pragma_Arg (Nam_Arg))
and then Present (Entity (Get_Pragma_Arg (Nam_Arg)))
then
- Mark_Pragma_As_Ghost (N, Entity (Get_Pragma_Arg (Nam_Arg)));
+ Mark_Ghost_Pragma (N, Entity (Get_Pragma_Arg (Nam_Arg)));
end if;
-- Not allowed in compiler units (bootstrap issues)
@@ -11223,10 +11673,11 @@ package body Sem_Prag is
-- ( [Check => ] Boolean_EXPRESSION
-- [, [Message =>] Static_String_EXPRESSION]);
- when Pragma_Assert |
- Pragma_Assert_And_Cut |
- Pragma_Assume |
- Pragma_Loop_Invariant =>
+ when Pragma_Assert
+ | Pragma_Assert_And_Cut
+ | Pragma_Assume
+ | Pragma_Loop_Invariant
+ =>
Assert : declare
function Contains_Loop_Entry (Expr : Node_Id) return Boolean;
-- Determine whether expression Expr contains a Loop_Entry
@@ -11394,7 +11845,7 @@ package body Sem_Prag is
-- identically named aspects and pragmas, depending on the specified
-- policy identifier:
- -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
+ -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
-- Note: Check and Ignore are language-defined. Disable is a GNAT
-- implementation-defined addition that results in totally ignoring
@@ -11410,6 +11861,35 @@ package body Sem_Prag is
-- processing is required here.
when Pragma_Assertion_Policy => Assertion_Policy : declare
+ procedure Resolve_Suppressible (Policy : Node_Id);
+ -- Converts the assertion policy 'Suppressible' to either Check or
+ -- Ignore based on whether checks are suppressed via -gnatp.
+
+ --------------------------
+ -- Resolve_Suppressible --
+ --------------------------
+
+ procedure Resolve_Suppressible (Policy : Node_Id) is
+ Arg : constant Node_Id := Get_Pragma_Arg (Policy);
+ Nam : Name_Id;
+
+ begin
+ -- Transform policy argument Suppressible into either Ignore or
+ -- Check depending on whether checks are enabled or suppressed.
+
+ if Chars (Arg) = Name_Suppressible then
+ if Suppress_Checks then
+ Nam := Name_Ignore;
+ else
+ Nam := Name_Check;
+ end if;
+
+ Rewrite (Arg, Make_Identifier (Sloc (Arg), Nam));
+ end if;
+ end Resolve_Suppressible;
+
+ -- Local variables
+
Arg : Node_Id;
Kind : Name_Id;
LocP : Source_Ptr;
@@ -11438,8 +11918,10 @@ package body Sem_Prag is
and then (Nkind (Arg1) /= N_Pragma_Argument_Association
or else Chars (Arg1) = No_Name)
then
- Check_Arg_Is_One_Of
- (Arg1, Name_Check, Name_Disable, Name_Ignore);
+ Check_Arg_Is_One_Of (Arg1,
+ Name_Check, Name_Disable, Name_Ignore, Name_Suppressible);
+
+ Resolve_Suppressible (Arg1);
-- Treat one argument Assertion_Policy as equivalent to:
@@ -11485,15 +11967,42 @@ package body Sem_Prag is
-- Check Kind and Policy have allowed forms
- Kind := Chars (Arg);
+ Kind := Chars (Arg);
+ Policy := Get_Pragma_Arg (Arg);
if not Is_Valid_Assertion_Kind (Kind) then
Error_Pragma_Arg
("invalid assertion kind for pragma%", Arg);
end if;
- Check_Arg_Is_One_Of
- (Arg, Name_Check, Name_Disable, Name_Ignore);
+ Check_Arg_Is_One_Of (Arg,
+ Name_Check, Name_Disable, Name_Ignore, Name_Suppressible);
+
+ Resolve_Suppressible (Arg);
+
+ if Kind = Name_Ghost then
+
+ -- The Ghost policy must be either Check or Ignore
+ -- (SPARK RM 6.9(6)).
+
+ if not Nam_In (Chars (Policy), Name_Check,
+ Name_Ignore)
+ then
+ Error_Pragma_Arg
+ ("argument of pragma % Ghost must be Check or "
+ & "Ignore", Policy);
+ end if;
+
+ -- Pragma Assertion_Policy specifying a Ghost policy
+ -- cannot occur within a Ghost subprogram or package
+ -- (SPARK RM 6.9(14)).
+
+ if Ghost_Mode > None then
+ Error_Pragma
+ ("pragma % cannot appear within ghost subprogram or "
+ & "package");
+ end if;
+ end if;
-- Rewrite the Assertion_Policy pragma as a series of
-- Check_Policy pragmas of the form:
@@ -11512,7 +12021,7 @@ package body Sem_Prag is
Make_Pragma_Argument_Association (LocP,
Expression => Make_Identifier (LocP, Kind)),
Make_Pragma_Argument_Association (LocP,
- Expression => Get_Pragma_Arg (Arg)))));
+ Expression => Policy))));
Arg := Next (Arg);
end loop;
@@ -11600,10 +12109,11 @@ package body Sem_Prag is
-- pragma Effective_Reads [ (boolean_EXPRESSION) ];
-- pragma Effective_Writes [ (boolean_EXPRESSION) ];
- when Pragma_Async_Readers |
- Pragma_Async_Writers |
- Pragma_Effective_Reads |
- Pragma_Effective_Writes =>
+ when Pragma_Async_Readers
+ | Pragma_Async_Writers
+ | Pragma_Effective_Reads
+ | Pragma_Effective_Writes
+ =>
Async_Effective : declare
Obj_Decl : Node_Id;
Obj_Id : Entity_Id;
@@ -11635,16 +12145,16 @@ package body Sem_Prag is
if Ekind (Obj_Id) = E_Variable then
- -- Chain the pragma on the contract for further processing by
- -- Analyze_External_Property_In_Decl_Part.
-
- Add_Contract_Item (N, Obj_Id);
-
-- A pragma that applies to a Ghost entity becomes Ghost for
-- the purposes of legality checks and removal of ignored Ghost
-- code.
- Mark_Pragma_As_Ghost (N, Obj_Id);
+ Mark_Ghost_Pragma (N, Obj_Id);
+
+ -- Chain the pragma on the contract for further processing by
+ -- Analyze_External_Property_In_Decl_Part.
+
+ Add_Contract_Item (N, Obj_Id);
-- Analyze the Boolean expression (if any)
@@ -11726,7 +12236,7 @@ package body Sem_Prag is
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, Nm);
+ Mark_Ghost_Pragma (N, Nm);
if not Is_Remote_Call_Interface (C_Ent)
and then not Is_Remote_Types (C_Ent)
@@ -11822,8 +12332,9 @@ package body Sem_Prag is
-- This processing is shared by Volatile_Components
- when Pragma_Atomic_Components |
- Pragma_Volatile_Components =>
+ when Pragma_Atomic_Components
+ | Pragma_Volatile_Components
+ =>
Atomic_Components : declare
D : Node_Id;
E : Entity_Id;
@@ -11846,7 +12357,7 @@ package body Sem_Prag is
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, E);
+ Mark_Ghost_Pragma (N, E);
Check_Duplicate_Pragma (E);
if Rep_Item_Too_Early (E, N)
@@ -11991,20 +12502,23 @@ package body Sem_Prag is
-- The identifiers Assertions and Statement_Assertions are not
-- allowed, since they have special meaning for Check_Policy.
+ -- WARNING: The code below manages Ghost regions. Return statements
+ -- must be replaced by gotos which jump to the end of the code and
+ -- restore the Ghost mode.
+
when Pragma_Check => Check : declare
Cname : Name_Id;
Eloc : Source_Ptr;
Expr : Node_Id;
+ Mode : Ghost_Mode_Type;
Str : Node_Id;
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
-
begin
-- Pragma Check is Ghost when it applies to a Ghost entity. Set
-- the mode now to ensure that any nodes generated during analysis
-- and expansion are marked as Ghost.
- Set_Ghost_Mode (N);
+ Set_Ghost_Mode (N, Mode);
GNAT_Pragma;
Check_At_Least_N_Arguments (2);
@@ -12089,11 +12603,11 @@ package body Sem_Prag is
case Cname is
- -- Nothing to do for invariants and predicates as the checks
- -- occur in the client units. The SCO for the aspect in the
- -- declaration unit is conservatively always enabled.
+ -- Nothing to do for predicates as the checks occur in the
+ -- client units. The SCO for the aspect in the declaration
+ -- unit is conservatively always enabled.
- when Name_Invariant | Name_Predicate =>
+ when Name_Predicate =>
null;
-- Otherwise mark aspect/pragma SCO as enabled
@@ -12201,7 +12715,7 @@ package body Sem_Prag is
In_Assertion_Expr := In_Assertion_Expr - 1;
end if;
- Ghost_Mode := Save_Ghost_Mode;
+ Restore_Ghost_Mode (Mode);
end Check;
--------------------------
@@ -12271,8 +12785,7 @@ package body Sem_Prag is
-- new form syntax.
when Pragma_Check_Policy => Check_Policy : declare
- Ident : Node_Id;
- Kind : Node_Id;
+ Kind : Node_Id;
begin
GNAT_Pragma;
@@ -12299,7 +12812,8 @@ package body Sem_Prag is
Check_Arg_Count (2);
Check_Optional_Identifier (Arg1, Name_Name);
Kind := Get_Pragma_Arg (Arg1);
- Rewrite_Assertion_Kind (Kind);
+ Rewrite_Assertion_Kind (Kind,
+ From_Policy => Comes_From_Source (N));
Check_Arg_Is_Identifier (Arg1);
-- Check forbidden check kind
@@ -12316,29 +12830,6 @@ package body Sem_Prag is
Check_Arg_Is_One_Of
(Arg2,
Name_On, Name_Off, Name_Check, Name_Disable, Name_Ignore);
- Ident := Get_Pragma_Arg (Arg2);
-
- if Chars (Kind) = Name_Ghost then
-
- -- Pragma Check_Policy specifying a Ghost policy cannot
- -- occur within a ghost subprogram or package.
-
- if Ghost_Mode > None then
- Error_Pragma
- ("pragma % cannot appear within ghost subprogram or "
- & "package");
-
- -- The policy identifier of pragma Ghost must be either
- -- Check or Ignore (SPARK RM 6.9(7)).
-
- elsif not Nam_In (Chars (Ident), Name_Check,
- Name_Ignore)
- then
- Error_Pragma_Arg
- ("argument of pragma % Ghost must be Check or Ignore",
- Arg2);
- end if;
- end if;
-- And chain pragma on the Check_Policy_List for search
@@ -12352,9 +12843,10 @@ package body Sem_Prag is
else
declare
- Arg : Node_Id;
- Argx : Node_Id;
- LocP : Source_Ptr;
+ Arg : Node_Id;
+ Argx : Node_Id;
+ LocP : Source_Ptr;
+ New_P : Node_Id;
begin
Arg := Arg1;
@@ -12374,7 +12866,7 @@ package body Sem_Prag is
-- Construct equivalent old form syntax Check_Policy
-- pragma and insert it to get remaining checks.
- Insert_Action (N,
+ New_P :=
Make_Pragma (LocP,
Chars => Name_Check_Policy,
Pragma_Argument_Associations => New_List (
@@ -12382,9 +12874,20 @@ package body Sem_Prag is
Expression =>
Make_Identifier (LocP, Chars (Arg))),
Make_Pragma_Argument_Association (Sloc (Argx),
- Expression => Argx))));
+ Expression => Argx)));
Arg := Next (Arg);
+
+ -- For a configuration pragma, insert old form in
+ -- the corresponding file.
+
+ if Is_Configuration_Pragma then
+ Insert_After (N, New_P);
+ Analyze (New_P);
+
+ else
+ Insert_Action (N, New_P);
+ end if;
end loop;
-- Rewrite original Check_Policy pragma to null, since we
@@ -12473,7 +12976,9 @@ package body Sem_Prag is
-- older run-times that use this pragma. That's an unusual case, but
-- it's easy enough to handle, so why not?
- when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning =>
+ when Pragma_Compiler_Unit
+ | Pragma_Compiler_Unit_Warning
+ =>
GNAT_Pragma;
Check_Arg_Count (0);
@@ -12610,9 +13115,21 @@ package body Sem_Prag is
("invalid Form parameter for pragma%", Form);
end if;
+ -- The pragma appears in a configuration file
+
+ if No (Parent (N)) then
+ Check_Valid_Configuration_Pragma;
+
+ -- Capture the component alignment in a global variable when
+ -- the pragma appears in a configuration file. Note that the
+ -- scope stack is empty at this point and cannot be used to
+ -- store the alignment value.
+
+ Configuration_Component_Alignment := Atype;
+
-- Case with no name, supplied, affects scope table entry
- if No (Name) then
+ elsif No (Name) then
Scope_Stack.Table
(Scope_Stack.Last).Component_Alignment_Default := Atype;
@@ -12699,14 +13216,14 @@ package body Sem_Prag is
return;
end if;
- -- Chain the pragma on the contract for completeness
-
- Add_Contract_Item (N, Obj_Id);
-
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, Obj_Id);
+ Mark_Ghost_Pragma (N, Obj_Id);
+
+ -- Chain the pragma on the contract for completeness
+
+ Add_Contract_Item (N, Obj_Id);
-- Analyze the Boolean expression (if any)
@@ -12811,17 +13328,17 @@ package body Sem_Prag is
Spec_Id := Unique_Defining_Entity (Subp_Decl);
- -- Chain the pragma on the contract for further processing by
- -- Analyze_Contract_Cases_In_Decl_Part.
-
- Add_Contract_Item (N, Defining_Entity (Subp_Decl));
-
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, Spec_Id);
+ Mark_Ghost_Pragma (N, Spec_Id);
Ensure_Aggregate_Form (Get_Argument (N, Spec_Id));
+ -- Chain the pragma on the contract for further processing by
+ -- Analyze_Contract_Cases_In_Decl_Part.
+
+ Add_Contract_Item (N, Defining_Entity (Subp_Decl));
+
-- Fully analyze the pragma when it appears inside an entry
-- or subprogram body because it cannot benefit from forward
-- references.
@@ -12876,6 +13393,7 @@ package body Sem_Prag is
E : Entity_Id;
pragma Warnings (Off, C);
pragma Warnings (Off, E);
+
begin
Check_Arg_Order ((Name_Convention, Name_Entity));
Check_Ada_83_Warning;
@@ -12885,7 +13403,7 @@ package body Sem_Prag is
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, E);
+ Mark_Ghost_Pragma (N, E);
end Convention;
---------------------------
@@ -12925,8 +13443,7 @@ package body Sem_Prag is
-- pragma CPP_Class ([Entity =>] LOCAL_NAME)
- when Pragma_CPP_Class => CPP_Class : declare
- begin
+ when Pragma_CPP_Class =>
GNAT_Pragma;
if Warn_On_Obsolescent_Feature then
@@ -12945,7 +13462,6 @@ package body Sem_Prag is
Expression => Make_Identifier (Loc, Name_CPP)),
New_Copy (First (Pragma_Argument_Associations (N))))));
Analyze (N);
- end CPP_Class;
---------------------
-- CPP_Constructor --
@@ -13050,8 +13566,7 @@ package body Sem_Prag is
-- CPP_Virtual --
-----------------
- when Pragma_CPP_Virtual => CPP_Virtual : declare
- begin
+ when Pragma_CPP_Virtual =>
GNAT_Pragma;
if Warn_On_Obsolescent_Feature then
@@ -13059,14 +13574,12 @@ package body Sem_Prag is
("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
& "effect?j?", N);
end if;
- end CPP_Virtual;
----------------
-- CPP_Vtable --
----------------
- when Pragma_CPP_Vtable => CPP_Vtable : declare
- begin
+ when Pragma_CPP_Vtable =>
GNAT_Pragma;
if Warn_On_Obsolescent_Feature then
@@ -13074,7 +13587,6 @@ package body Sem_Prag is
("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
& "effect?j?", N);
end if;
- end CPP_Vtable;
---------
-- CPU --
@@ -13306,7 +13818,7 @@ package body Sem_Prag is
-- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
- when Pragma_Default_Initial_Condition => Default_Init_Cond : declare
+ when Pragma_Default_Initial_Condition => DIC : declare
Discard : Boolean;
Stmt : Node_Id;
Typ : Entity_Id;
@@ -13328,9 +13840,13 @@ package body Sem_Prag is
Error_Msg_N ("pragma % duplicates pragma declared#", N);
end if;
- -- Skip internally generated code
+ -- Skip internally generated code. Note that derived type
+ -- declarations of untagged types with discriminants are
+ -- rewritten as private type declarations.
- elsif not Comes_From_Source (Stmt) then
+ elsif not Comes_From_Source (Stmt)
+ and then Nkind (Stmt) /= N_Private_Type_Declaration
+ then
null;
-- The associated private type [extension] has been found, stop
@@ -13356,14 +13872,22 @@ package body Sem_Prag is
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, Typ);
- Set_Has_Default_Init_Cond (Typ);
- Set_Has_Inherited_Default_Init_Cond (Typ, False);
+ Mark_Ghost_Pragma (N, Typ);
+
+ -- The pragma signals that the type defines its own DIC assertion
+ -- expression.
+
+ Set_Has_Own_DIC (Typ);
-- Chain the pragma on the rep item chain for further processing
Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
- end Default_Init_Cond;
+
+ -- Create the declaration of the procedure which verifies the
+ -- assertion expression of pragma DIC at runtime.
+
+ Build_DIC_Procedure_Declaration (Typ);
+ end DIC;
----------------------------------
-- Default_Scalar_Storage_Order --
@@ -13430,6 +13954,17 @@ package body Sem_Prag is
Check_Is_In_Decl_Part_Or_Package_Spec;
end if;
+ if From_Aspect_Specification (N) then
+ declare
+ E : constant Entity_Id := Entity (Corresponding_Aspect (N));
+ begin
+ if not In_Open_Scopes (E) then
+ Error_Msg_N
+ ("aspect must apply to package or subprogram", N);
+ end if;
+ end;
+ end if;
+
if Present (Arg1) then
Pool := Get_Pragma_Arg (Arg1);
@@ -13466,7 +14001,7 @@ package body Sem_Prag is
-- for the purposes of legality checks and removal of
-- ignored Ghost code.
- Mark_Pragma_As_Ghost (N, Entity (Pool));
+ Mark_Ghost_Pragma (N, Entity (Pool));
else
Error_Pragma_Arg
@@ -13650,7 +14185,7 @@ package body Sem_Prag is
-- the purposes of legality checks and removal of ignored
-- Ghost code.
- Mark_Pragma_As_Ghost (N, E);
+ Mark_Ghost_Pragma (N, E);
if (Is_First_Subtype (E)
and then
@@ -13699,7 +14234,7 @@ package body Sem_Prag is
-- the purposes of legality checks and removal of ignored Ghost
-- code.
- Mark_Pragma_As_Ghost (N, Ent);
+ Mark_Ghost_Pragma (N, Ent);
-- The expression must be analyzed in the special manner
-- described in "Handling of Default and Per-Object
@@ -13925,7 +14460,7 @@ package body Sem_Prag is
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, Cunit_Ent);
+ Mark_Ghost_Pragma (N, Cunit_Ent);
if Nkind_In (Unit (Cunit_Node), N_Package_Body,
N_Subprogram_Body)
@@ -13971,8 +14506,7 @@ package body Sem_Prag is
-- checks in SPARK mode).
Dynamic_Elaboration_Checks :=
- (Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic)
- and then SPARK_Mode /= On;
+ Chars (Get_Pragma_Arg (Arg1)) = Name_Dynamic;
---------------
-- Eliminate --
@@ -14118,7 +14652,7 @@ package body Sem_Prag is
-- the purposes of legality checks and removal of ignored Ghost
-- code.
- Mark_Pragma_As_Ghost (N, Def_Id);
+ Mark_Ghost_Pragma (N, Def_Id);
if Ekind (Def_Id) /= E_Constant then
Note_Possible_Modification
@@ -14399,8 +14933,7 @@ package body Sem_Prag is
-- pragma Extend_System ([Name =>] Identifier);
- when Pragma_Extend_System => Extend_System : declare
- begin
+ when Pragma_Extend_System =>
GNAT_Pragma;
Check_Valid_Configuration_Pragma;
Check_Arg_Count (1);
@@ -14432,7 +14965,6 @@ package body Sem_Prag is
else
Error_Pragma ("incorrect name for pragma%, must be Aux_xxx");
end if;
- end Extend_System;
------------------------
-- Extensions_Allowed --
@@ -14538,6 +15070,13 @@ package body Sem_Prag is
return;
end if;
+ -- Mark the pragma as Ghost if the related subprogram is also
+ -- Ghost. This also ensures that any expansion performed further
+ -- below will produce Ghost nodes.
+
+ Spec_Id := Unique_Defining_Entity (Subp_Decl);
+ Mark_Ghost_Pragma (N, Spec_Id);
+
-- Chain the pragma on the contract for completeness
Add_Contract_Item (N, Defining_Entity (Subp_Decl));
@@ -14548,13 +15087,6 @@ package body Sem_Prag is
Analyze_If_Present (Pragma_SPARK_Mode);
- -- Mark the pragma as Ghost if the related subprogram is also
- -- Ghost. This also ensures that any expansion performed further
- -- below will produce Ghost nodes.
-
- Spec_Id := Unique_Defining_Entity (Subp_Decl);
- Mark_Pragma_As_Ghost (N, Spec_Id);
-
-- Examine the formals of the related subprogram
Formal := First_Formal (Spec_Id);
@@ -14629,7 +15161,7 @@ package body Sem_Prag is
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, E);
+ Mark_Ghost_Pragma (N, E);
Note_Possible_Modification
(Get_Pragma_Arg (Arg2), Sure => False);
@@ -14645,8 +15177,7 @@ package body Sem_Prag is
-- UPPERCASE | LOWERCASE
-- [, AS_IS | UPPERCASE | LOWERCASE]);
- when Pragma_External_Name_Casing => External_Name_Casing : declare
- begin
+ when Pragma_External_Name_Casing =>
GNAT_Pragma;
Check_No_Identifiers;
@@ -14684,7 +15215,6 @@ package body Sem_Prag is
when others =>
null;
end case;
- end External_Name_Casing;
---------------
-- Fast_Math --
@@ -14717,7 +15247,7 @@ package body Sem_Prag is
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, Typ);
+ Mark_Ghost_Pragma (N, Typ);
-- If it's an access-to-subprogram type (in particular, not a
-- subtype), set the flag on that type.
@@ -14835,6 +15365,18 @@ package body Sem_Prag is
Id := Defining_Entity (Stmt);
exit;
+ -- When pragma Ghost applies to an object declaration which
+ -- is initialized by means of a function call that returns
+ -- on the secondary stack, the object declaration becomes a
+ -- renaming.
+
+ elsif Nkind (Stmt) = N_Object_Renaming_Declaration
+ and then Comes_From_Source (Orig_Stmt)
+ and then Nkind (Orig_Stmt) = N_Object_Declaration
+ then
+ Id := Defining_Entity (Stmt);
+ exit;
+
-- When pragma Ghost applies to an expression function, the
-- expression function is transformed into a subprogram.
@@ -14911,6 +15453,12 @@ package body Sem_Prag is
and then No (Corresponding_Spec (Context))
then
Id := Defining_Entity (Context);
+
+ -- Pragma Ghost applies to a subprogram declaration that acts
+ -- as a compilation unit.
+
+ elsif Nkind (Context) = N_Subprogram_Declaration then
+ Id := Defining_Entity (Context);
end if;
end if;
@@ -14921,14 +15469,6 @@ package body Sem_Prag is
return;
end if;
- -- A derived type or type extension cannot be subject to pragma
- -- Ghost if either the parent type or one of the progenitor types
- -- is not Ghost (SPARK RM 6.9(9)).
-
- if Is_Derived_Type (Id) then
- Check_Ghost_Derivation (Id);
- end if;
-
-- Handle completions of types and constants that are subject to
-- pragma Ghost.
@@ -14940,7 +15480,7 @@ package body Sem_Prag is
-- The full declaration of a deferred constant cannot be
-- subject to pragma Ghost unless the deferred declaration
- -- is also Ghost (SPARK RM 6.9(10)).
+ -- is also Ghost (SPARK RM 6.9(9)).
if Ekind (Prev_Id) = E_Constant then
Error_Msg_Name_1 := Pname;
@@ -14958,7 +15498,7 @@ package body Sem_Prag is
-- The full declaration of a type cannot be subject to
-- pragma Ghost unless the partial view is also Ghost
- -- (SPARK RM 6.9(10)).
+ -- (SPARK RM 6.9(9)).
else
Error_Msg_NE (Fix_Error
@@ -14992,7 +15532,7 @@ package body Sem_Prag is
if Is_OK_Static_Expression (Expr) then
-- "Ghostness" cannot be turned off once enabled within a
- -- region (SPARK RM 6.9(7)).
+ -- region (SPARK RM 6.9(6)).
if Is_False (Expr_Value (Expr))
and then Ghost_Mode > None
@@ -15111,7 +15651,10 @@ package body Sem_Prag is
-- Note: pragma Comment shares this processing. Pragma Ident is
-- identical in effect to pragma Commment.
- when Pragma_Ident | Pragma_Comment => Ident : declare
+ when Pragma_Comment
+ | Pragma_Ident
+ =>
+ Ident : declare
Str : Node_Id;
begin
@@ -15608,7 +16151,7 @@ package body Sem_Prag is
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, E);
+ Mark_Ghost_Pragma (N, E);
-- Check duplicate before we chain ourselves
@@ -15714,6 +16257,11 @@ package body Sem_Prag is
Pack_Id := Defining_Entity (Pack_Decl);
+ -- A pragma that applies to a Ghost entity becomes Ghost for the
+ -- purposes of legality checks and removal of ignored Ghost code.
+
+ Mark_Ghost_Pragma (N, Pack_Id);
+
-- Chain the pragma on the contract for further processing by
-- Analyze_Initial_Condition_In_Decl_Part.
@@ -15732,11 +16280,6 @@ package body Sem_Prag is
Analyze_If_Present (Pragma_SPARK_Mode);
Analyze_If_Present (Pragma_Abstract_State);
Analyze_If_Present (Pragma_Initializes);
-
- -- A pragma that applies to a Ghost entity becomes Ghost for the
- -- purposes of legality checks and removal of ignored Ghost code.
-
- Mark_Pragma_As_Ghost (N, Pack_Id);
end Initial_Condition;
------------------------
@@ -15828,6 +16371,12 @@ package body Sem_Prag is
Pack_Id := Defining_Entity (Pack_Decl);
+ -- A pragma that applies to a Ghost entity becomes Ghost for the
+ -- purposes of legality checks and removal of ignored Ghost code.
+
+ Mark_Ghost_Pragma (N, Pack_Id);
+ Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
+
-- Chain the pragma on the contract for further processing by
-- Analyze_Initializes_In_Decl_Part.
@@ -15845,13 +16394,6 @@ package body Sem_Prag is
Analyze_If_Present (Pragma_SPARK_Mode);
Analyze_If_Present (Pragma_Abstract_State);
-
- -- A pragma that applies to a Ghost entity becomes Ghost for the
- -- purposes of legality checks and removal of ignored Ghost code.
-
- Mark_Pragma_As_Ghost (N, Pack_Id);
- Ensure_Aggregate_Form (Get_Argument (N, Pack_Id));
-
Analyze_If_Present (Pragma_Initial_Condition);
end Initializes;
@@ -15871,7 +16413,23 @@ package body Sem_Prag is
if not GNATprove_Mode then
- -- Inline status is Enabled if inlining option is active
+ -- Inline status is Enabled if option -gnatn is specified.
+ -- However this status determines only the value of the
+ -- Is_Inlined flag on the subprogram and does not prevent
+ -- the pragma itself from being recorded for later use,
+ -- in particular for a later modification of Is_Inlined
+ -- independently of the -gnatn option.
+
+ -- In other words, if -gnatn is specified for a unit, then
+ -- all Inline pragmas processed for the compilation of this
+ -- unit, including those in the spec of other units, are
+ -- activated, so subprograms will be inlined across units.
+
+ -- If -gnatn is not specified, no Inline pragma is activated
+ -- here, which means that subprograms will not be inlined
+ -- across units. The Is_Inlined flag will nevertheless be
+ -- set later when bodies are analyzed, so subprograms will
+ -- be inlined within the unit.
if Inline_Active then
Process_Inline (Enabled);
@@ -16050,8 +16608,8 @@ package body Sem_Prag is
if Is_Imported (Def_Id)
and then Present (First_Rep_Item (Def_Id))
and then Nkind (First_Rep_Item (Def_Id)) = N_Pragma
- and then
- Pragma_Name (First_Rep_Item (Def_Id)) = Name_Interface
+ and then Pragma_Name (First_Rep_Item (Def_Id)) =
+ Name_Interface
then
null;
else
@@ -16303,7 +16861,7 @@ package body Sem_Prag is
when Pragma_Invariant => Invariant : declare
Discard : Boolean;
Typ : Entity_Id;
- Type_Id : Node_Id;
+ Typ_Arg : Node_Id;
begin
GNAT_Pragma;
@@ -16319,14 +16877,16 @@ package body Sem_Prag is
Check_Arg_Is_Local_Name (Arg1);
- Type_Id := Get_Pragma_Arg (Arg1);
- Find_Type (Type_Id);
- Typ := Entity (Type_Id);
+ Typ_Arg := Get_Pragma_Arg (Arg1);
+ Find_Type (Typ_Arg);
+ Typ := Entity (Typ_Arg);
+
+ -- Nothing to do of the related type is erroneous in some way
if Typ = Any_Type then
return;
- -- Invariants allowed in interface types (RM 7.3.2(3/3))
+ -- AI12-0041: Invariants are allowed in interface types
elsif Is_Interface (Typ) then
null;
@@ -16336,64 +16896,76 @@ package body Sem_Prag is
-- a class-wide invariant can only appear on a private declaration
-- or private extension, not a completion.
- elsif Ekind_In (Typ, E_Private_Type,
- E_Record_Type_With_Private,
- E_Limited_Private_Type)
+ -- A [class-wide] invariant may be associated a [limited] private
+ -- type or a private extension.
+
+ elsif Ekind_In (Typ, E_Limited_Private_Type,
+ E_Private_Type,
+ E_Record_Type_With_Private)
then
null;
- elsif In_Private_Part (Current_Scope)
- and then Has_Private_Declaration (Typ)
+ -- A non-class-wide invariant may be associated with the full view
+ -- of a [limited] private type or a private extension.
+
+ elsif Has_Private_Declaration (Typ)
and then not Class_Present (N)
then
null;
- elsif In_Private_Part (Current_Scope) then
+ -- A class-wide invariant may appear on the partial view only
+
+ elsif Class_Present (N) then
Error_Pragma_Arg
- ("pragma% only allowed for private type declared in "
- & "visible part", Arg1);
+ ("pragma % only allowed for private type", Arg1);
+ return;
+
+ -- A regular invariant may appear on both views
else
Error_Pragma_Arg
- ("pragma% only allowed for private type", Arg1);
+ ("pragma % only allowed for private type or corresponding "
+ & "full view", Arg1);
+ return;
end if;
- -- A pragma that applies to a Ghost entity becomes Ghost for the
- -- purposes of legality checks and removal of ignored Ghost code.
-
- Mark_Pragma_As_Ghost (N, Typ);
-
- -- Not allowed for abstract type in the non-class case (it is
- -- allowed to use Invariant'Class for abstract types).
+ -- An invariant associated with an abstract type (this includes
+ -- interfaces) must be class-wide.
if Is_Abstract_Type (Typ) and then not Class_Present (N) then
Error_Pragma_Arg
- ("pragma% not allowed for abstract type", Arg1);
+ ("pragma % not allowed for abstract type", Arg1);
+ return;
end if;
- -- Link the pragma on to the rep item chain, for processing when
- -- the type is frozen.
+ -- A pragma that applies to a Ghost entity becomes Ghost for the
+ -- purposes of legality checks and removal of ignored Ghost code.
- Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
+ Mark_Ghost_Pragma (N, Typ);
- -- Note that the type has at least one invariant, and also that
- -- it has inheritable invariants if we have Invariant'Class
- -- or Type_Invariant'Class. Build the corresponding invariant
- -- procedure declaration, so that calls to it can be generated
- -- before the body is built (e.g. within an expression function).
+ -- The pragma defines a type-specific invariant, the type is said
+ -- to have invariants of its "own".
- -- Interface types have no invariant procedure; their invariants
- -- are propagated to the build invariant procedure of all the
- -- types covering the interface type.
+ Set_Has_Own_Invariants (Typ);
- if not Is_Interface (Typ) then
- Insert_After_And_Analyze
- (N, Build_Invariant_Procedure_Declaration (Typ));
- end if;
+ -- If the invariant is class-wide, then it can be inherited by
+ -- derived or interface implementing types. The type is said to
+ -- have "inheritable" invariants.
if Class_Present (N) then
Set_Has_Inheritable_Invariants (Typ);
end if;
+
+ -- Chain the pragma on to the rep item chain, for processing when
+ -- the type is frozen.
+
+ Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
+
+ -- Create the declaration of the invariant procedure which will
+ -- verify the invariant at run-time. Note that interfaces do not
+ -- carry such a declaration.
+
+ Build_Invariant_Procedure_Declaration (Typ);
end Invariant;
----------------
@@ -16598,8 +17170,9 @@ package body Sem_Prag is
-- pragma Linker_Destructor (procedure_LOCAL_NAME);
- when Pragma_Linker_Constructor |
- Pragma_Linker_Destructor =>
+ when Pragma_Linker_Constructor
+ | Pragma_Linker_Destructor
+ =>
Linker_Constructor : declare
Arg1_X : Node_Id;
Proc : Entity_Id;
@@ -16704,7 +17277,10 @@ package body Sem_Prag is
-- all we need to do is to set the Linker_Section_pragma field,
-- checking that we do not have a duplicate.
- when E_Constant | E_Variable | Type_Kind =>
+ when Type_Kind
+ | E_Constant
+ | E_Variable
+ =>
LPE := Linker_Section_Pragma (Ent);
if Present (LPE) then
@@ -16719,7 +17295,7 @@ package body Sem_Prag is
-- the purposes of legality checks and removal of ignored
-- Ghost code.
- Mark_Pragma_As_Ghost (N, Ent);
+ Mark_Ghost_Pragma (N, Ent);
-- Subprograms
@@ -16743,7 +17319,7 @@ package body Sem_Prag is
-- Ghost for the purposes of legality checks and
-- removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, Ent);
+ Mark_Ghost_Pragma (N, Ent);
-- Capture the entity of the first Ghost subprogram
-- being processed for error detection purposes.
@@ -16873,12 +17449,9 @@ package body Sem_Prag is
LP_Val := Chars (Get_Pragma_Arg (Arg1));
case LP_Val is
- when Name_Ceiling_Locking =>
- LP := 'C';
- when Name_Inheritance_Locking =>
- LP := 'I';
- when Name_Concurrent_Readers_Locking =>
- LP := 'R';
+ when Name_Ceiling_Locking => LP := 'C';
+ when Name_Concurrent_Readers_Locking => LP := 'R';
+ when Name_Inheritance_Locking => LP := 'I';
end case;
if Locking_Policy /= ' '
@@ -17108,6 +17681,79 @@ package body Sem_Prag is
end loop;
end Main_Storage;
+ ----------------------
+ -- Max_Queue_Length --
+ ----------------------
+
+ -- pragma Max_Queue_Length (static_integer_EXPRESSION);
+
+ when Pragma_Max_Queue_Length => Max_Queue_Length : declare
+ Arg : Node_Id;
+ Entry_Decl : Node_Id;
+ Entry_Id : Entity_Id;
+ Val : Uint;
+
+ begin
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+
+ Entry_Decl :=
+ Find_Related_Declaration_Or_Body (N, Do_Checks => True);
+
+ -- Entry declaration
+
+ if Nkind (Entry_Decl) = N_Entry_Declaration then
+
+ -- Entry illegally within a task
+
+ if Nkind (Parent (N)) = N_Task_Definition then
+ Error_Pragma ("pragma % cannot apply to task entries");
+ return;
+ end if;
+
+ Entry_Id := Unique_Defining_Entity (Entry_Decl);
+
+ -- Otherwise the pragma is associated with an illegal construct
+
+ else
+ Error_Pragma ("pragma % must apply to a protected entry");
+ return;
+ end if;
+
+ -- Mark the pragma as Ghost if the related subprogram is also
+ -- Ghost. This also ensures that any expansion performed further
+ -- below will produce Ghost nodes.
+
+ Mark_Ghost_Pragma (N, Entry_Id);
+
+ -- Analyze the Integer expression
+
+ Arg := Get_Pragma_Arg (Arg1);
+ Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
+
+ Val := Expr_Value (Arg);
+
+ if Val <= 0 then
+ Error_Pragma_Arg
+ ("argument for pragma% must be positive", Arg1);
+
+ elsif not UI_Is_In_Int_Range (Val) then
+ Error_Pragma_Arg
+ ("argument for pragma% out of range of Integer", Arg1);
+
+ end if;
+
+ -- Manually substitute the expression value of the pragma argument
+ -- if it's not an integer literal because this is not taken care
+ -- of automatically elsewhere.
+
+ if Nkind (Arg) /= N_Integer_Literal then
+ Rewrite (Arg, Make_Integer_Literal (Sloc (Arg), Val));
+ end if;
+
+ Record_Rep_Item (Entry_Id, N);
+ end Max_Queue_Length;
+
-----------------
-- Memory_Size --
-----------------
@@ -17259,7 +17905,7 @@ package body Sem_Prag is
-- for the purposes of legality checks and removal of
-- ignored Ghost code.
- Mark_Pragma_As_Ghost (N, E);
+ Mark_Ghost_Pragma (N, E);
-- Capture the entity of the first Ghost procedure being
-- processed for error detection purposes.
@@ -17334,28 +17980,38 @@ package body Sem_Prag is
Check_Valid_Configuration_Pragma;
Check_Arg_Count (0);
- No_Run_Time_Mode := True;
- Configurable_Run_Time_Mode := True;
+ -- Remove backward compatibility if Build_Type is FSF or GPL and
+ -- generate a warning.
- -- Set Duration to 32 bits if word size is 32
+ declare
+ Ignore : constant Boolean := Build_Type in FSF .. GPL;
+ begin
+ if Ignore then
+ Error_Pragma ("pragma% is ignored, has no effect??");
+ else
+ No_Run_Time_Mode := True;
+ Configurable_Run_Time_Mode := True;
- if Ttypes.System_Word_Size = 32 then
- Duration_32_Bits_On_Target := True;
- end if;
+ -- Set Duration to 32 bits if word size is 32
- -- Set appropriate restrictions
+ if Ttypes.System_Word_Size = 32 then
+ Duration_32_Bits_On_Target := True;
+ end if;
- Set_Restriction (No_Finalization, N);
- Set_Restriction (No_Exception_Handlers, N);
- Set_Restriction (Max_Tasks, N, 0);
- Set_Restriction (No_Tasking, N);
+ -- Set appropriate restrictions
- -----------------------
- -- No_Tagged_Streams --
- -----------------------
+ Set_Restriction (No_Finalization, N);
+ Set_Restriction (No_Exception_Handlers, N);
+ Set_Restriction (Max_Tasks, N, 0);
+ Set_Restriction (No_Tasking, N);
+ end if;
+ end;
+
+ -----------------------
+ -- No_Tagged_Streams --
+ -----------------------
- -- pragma No_Tagged_Streams;
- -- pragma No_Tagged_Streams ([Entity => ]tagged_type_local_NAME);
+ -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
when Pragma_No_Tagged_Streams => No_Tagged_Strms : declare
E : Entity_Id;
@@ -17493,7 +18149,7 @@ package body Sem_Prag is
-- the purposes of legality checks and removal of ignored Ghost
-- code.
- Mark_Pragma_As_Ghost (N, E);
+ Mark_Ghost_Pragma (N, E);
-- Entity name was given
@@ -17712,12 +18368,10 @@ package body Sem_Prag is
Nam : constant Name_Id := Chars (Get_Pragma_Arg (Arg1));
begin
case Nam is
- when Name_Time =>
- Opt.Optimize_Alignment := 'T';
- when Name_Space =>
- Opt.Optimize_Alignment := 'S';
- when Name_Off =>
- Opt.Optimize_Alignment := 'O';
+ when Name_Off => Opt.Optimize_Alignment := 'O';
+ when Name_Space => Opt.Optimize_Alignment := 'S';
+ when Name_Time => Opt.Optimize_Alignment := 'T';
+
when others =>
Error_Pragma_Arg ("invalid argument for pragma%", Arg1);
end case;
@@ -17897,7 +18551,7 @@ package body Sem_Prag is
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, Typ);
+ Mark_Ghost_Pragma (N, Typ);
if not Is_Array_Type (Typ) and then not Is_Record_Type (Typ) then
Error_Pragma ("pragma% must specify array or record type");
@@ -18011,7 +18665,8 @@ package body Sem_Prag is
-----------------------
procedure Propagate_Part_Of (Pack_Id : Entity_Id) is
- Item_Id : Entity_Id;
+ Constits : Elist_Id;
+ Item_Id : Entity_Id;
begin
-- Traverse the entity chain of the package and set relevant
@@ -18035,8 +18690,14 @@ package body Sem_Prag is
E_Variable)
then
Has_Item := True;
+ Constits := Part_Of_Constituents (State_Id);
+
+ if No (Constits) then
+ Constits := New_Elmt_List;
+ Set_Part_Of_Constituents (State_Id, Constits);
+ end if;
- Append_Elmt (Item_Id, Part_Of_Constituents (State_Id));
+ Append_Elmt (Item_Id, Constits);
Set_Encapsulating_State (Item_Id, State_Id);
-- Recursively handle nested packages and instantiations
@@ -18066,6 +18727,7 @@ package body Sem_Prag is
-- Local variables
+ Constits : Elist_Id;
Encap : Node_Id;
Encap_Id : Entity_Id;
Item_Id : Entity_Id;
@@ -18112,19 +18774,18 @@ package body Sem_Prag is
end if;
Item_Id := Defining_Entity (Stmt);
- Encap := Get_Pragma_Arg (Arg1);
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, Item_Id);
+ Mark_Ghost_Pragma (N, Item_Id);
-- Chain the pragma on the contract for further processing by
-- Analyze_Part_Of_In_Decl_Part or for completeness.
Add_Contract_Item (N, Item_Id);
- -- A variable may act as consituent of a single concurrent type
+ -- A variable may act as constituent of a single concurrent type
-- which in turn could be declared after the variable. Due to this
-- discrepancy, the full analysis of indicator Part_Of is delayed
-- until the end of the enclosing declarative region (see routine
@@ -18137,6 +18798,8 @@ package body Sem_Prag is
-- instantiation.
else
+ Encap := Get_Pragma_Arg (Arg1);
+
-- Detect any discrepancies between the placement of the
-- constant or package instantiation with respect to state
-- space and the encapsulating state.
@@ -18152,7 +18815,14 @@ package body Sem_Prag is
pragma Assert (Present (Encap_Id));
if Ekind (Item_Id) = E_Constant then
- Append_Elmt (Item_Id, Part_Of_Constituents (Encap_Id));
+ Constits := Part_Of_Constituents (Encap_Id);
+
+ if No (Constits) then
+ Constits := New_Elmt_List;
+ Set_Part_Of_Constituents (Encap_Id, Constits);
+ end if;
+
+ Append_Elmt (Item_Id, Constits);
Set_Encapsulating_State (Item_Id, Encap_Id);
-- Propagate the Part_Of indicator to the visible state
@@ -18174,7 +18844,7 @@ package body Sem_Prag is
-- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
- when Pragma_Partition_Elaboration_Policy => declare
+ when Pragma_Partition_Elaboration_Policy => PEP : declare
subtype PEP_Range is Name_Id
range First_Partition_Elaboration_Policy_Name
.. Last_Partition_Elaboration_Policy_Name;
@@ -18190,10 +18860,8 @@ package body Sem_Prag is
PEP_Val := Chars (Get_Pragma_Arg (Arg1));
case PEP_Val is
- when Name_Concurrent =>
- PEP := 'C';
- when Name_Sequential =>
- PEP := 'S';
+ when Name_Concurrent => PEP := 'C';
+ when Name_Sequential => PEP := 'S';
end case;
if Partition_Elaboration_Policy /= ' '
@@ -18213,7 +18881,7 @@ package body Sem_Prag is
Partition_Elaboration_Policy_Sloc := Loc;
end if;
end if;
- end;
+ end PEP;
-------------
-- Passive --
@@ -18256,7 +18924,7 @@ package body Sem_Prag is
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, Ent);
+ Mark_Ghost_Pragma (N, Ent);
-- The pragma may come from an aspect on a private declaration,
-- even if the freeze point at which this is analyzed in the
@@ -18344,13 +19012,12 @@ package body Sem_Prag is
end if;
Ent := Entity (Get_Pragma_Arg (Arg1));
- Decl := Parent (Ent);
-- A pragma that applies to a Ghost entity becomes Ghost for
-- the purposes of legality checks and removal of ignored Ghost
-- code.
- Mark_Pragma_As_Ghost (N, Ent);
+ Mark_Ghost_Pragma (N, Ent);
-- Check for duplication before inserting in list of
-- representation items.
@@ -18361,6 +19028,8 @@ package body Sem_Prag is
return;
end if;
+ Decl := Parent (Ent);
+
if Present (Expression (Decl)) then
Error_Pragma_Arg
("object for pragma% cannot have initialization", Arg1);
@@ -18386,6 +19055,48 @@ package body Sem_Prag is
end if;
end Persistent_BSS;
+ --------------------
+ -- Rename_Pragma --
+ --------------------
+
+ -- pragma Rename_Pragma (
+ -- [New_Name =>] IDENTIFIER,
+ -- [Renamed =>] pragma_IDENTIFIER);
+
+ when Pragma_Rename_Pragma => Rename_Pragma : declare
+ New_Name : constant Node_Id := Get_Pragma_Arg (Arg1);
+ Old_Name : constant Node_Id := Get_Pragma_Arg (Arg2);
+
+ begin
+ GNAT_Pragma;
+ Check_Valid_Configuration_Pragma;
+ Check_Arg_Count (2);
+ Check_Optional_Identifier (Arg1, Name_New_Name);
+ Check_Optional_Identifier (Arg2, Name_Renamed);
+
+ if Nkind (New_Name) /= N_Identifier then
+ Error_Pragma_Arg ("identifier expected", Arg1);
+ end if;
+
+ if Nkind (Old_Name) /= N_Identifier then
+ Error_Pragma_Arg ("identifier expected", Arg2);
+ end if;
+
+ -- The New_Name arg should not be an existing pragma (but we allow
+ -- it; it's just a warning). The Old_Name arg must be an existing
+ -- pragma.
+
+ if Is_Pragma_Name (Chars (New_Name)) then
+ Error_Pragma_Arg ("??pragma is already defined", Arg1);
+ end if;
+
+ if not Is_Pragma_Name (Chars (Old_Name)) then
+ Error_Pragma_Arg ("existing pragma name expected", Arg1);
+ end if;
+
+ Map_Pragma_Name (From => Chars (New_Name), To => Chars (Old_Name));
+ end Rename_Pragma;
+
-------------
-- Polling --
-------------
@@ -18440,9 +19151,10 @@ package body Sem_Prag is
-- the "pragma on subprogram declaration" case. In that scenario
-- the annotation must instantiate itself.
- when Pragma_Post |
- Pragma_Post_Class |
- Pragma_Postcondition =>
+ when Pragma_Post
+ | Pragma_Post_Class
+ | Pragma_Postcondition
+ =>
Analyze_Pre_Post_Condition;
--------------------------------
@@ -18486,9 +19198,10 @@ package body Sem_Prag is
-- the "pragma on subprogram declaration" case. In that scenario
-- the annotation must instantiate itself.
- when Pragma_Pre |
- Pragma_Pre_Class |
- Pragma_Precondition =>
+ when Pragma_Pre
+ | Pragma_Pre_Class
+ | Pragma_Precondition
+ =>
Analyze_Pre_Post_Condition;
---------------
@@ -18523,14 +19236,23 @@ package body Sem_Prag is
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, Typ);
+ Mark_Ghost_Pragma (N, Typ);
-- The remaining processing is simply to link the pragma on to
-- the rep item chain, for processing when the type is frozen.
-- This is accomplished by a call to Rep_Item_Too_Late. We also
-- mark the type as having predicates.
+ -- If the current policy for predicate checking is Ignore mark the
+ -- subtype accordingly. In the case of predicates we consider them
+ -- enabled unless Ignore is specified (either directly or with a
+ -- general Assertion_Policy pragma) to preserve existing warnings.
+
Set_Has_Predicates (Typ);
+ Set_Predicates_Ignored (Typ,
+ Present (Check_Policy_List)
+ and then
+ Policy_In_Effect (Name_Dynamic_Predicate) = Name_Ignore);
Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
end Predicate;
@@ -18566,7 +19288,7 @@ package body Sem_Prag is
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, Typ);
+ Mark_Ghost_Pragma (N, Typ);
-- The remaining processing is simply to link the pragma on to
-- the rep item chain, for processing when the type is frozen.
@@ -18601,7 +19323,7 @@ package body Sem_Prag is
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, Ent);
+ Mark_Ghost_Pragma (N, Ent);
Check_Duplicate_Pragma (Ent);
-- This filters out pragmas inside generic parents that show up
@@ -18681,22 +19403,15 @@ package body Sem_Prag is
-- where we ignore the value if out of range.
else
- declare
- Val : constant Uint := Expr_Value (Arg);
- begin
- if not Relaxed_RM_Semantics
- and then
- (Val < 0
- or else Val > Expr_Value (Expression
- (Parent (RTE (RE_Max_Priority)))))
- then
- Error_Pragma_Arg
- ("main subprogram priority is out of range", Arg1);
- else
- Set_Main_Priority
- (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
- end if;
- end;
+ if not Relaxed_RM_Semantics
+ and then not Is_In_Range (Arg, RTE (RE_Priority))
+ then
+ Error_Pragma_Arg
+ ("main subprogram priority is out of range", Arg1);
+ else
+ Set_Main_Priority
+ (Current_Sem_Unit, UI_To_Int (Expr_Value (Arg)));
+ end if;
end if;
-- Load an arbitrary entity from System.Tasking.Stages or
@@ -19021,7 +19736,7 @@ package body Sem_Prag is
Import :=
Make_Pragma (Loc,
- Pragma_Identifier => Make_Identifier (Loc, Name_Import),
+ Chars => Name_Import,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Make_Identifier (Loc, Name_Intrinsic)),
@@ -19101,7 +19816,9 @@ package body Sem_Prag is
-- [, [External =>] EXTERNAL_SYMBOL]
-- [, [Size =>] EXTERNAL_SYMBOL]);
- when Pragma_Psect_Object | Pragma_Common_Object =>
+ when Pragma_Common_Object
+ | Pragma_Psect_Object
+ =>
Psect_Object : declare
Args : Args_List (1 .. 3);
Names : constant Name_List (1 .. 3) := (
@@ -19224,7 +19941,15 @@ package body Sem_Prag is
begin
Check_Ada_83_Warning;
- Check_Valid_Library_Unit_Pragma;
+
+ -- If the pragma comes from a subprogram instantiation, nothing to
+ -- check, this can happen at any level of nesting.
+
+ if Is_Wrapper_Package (Current_Scope) then
+ return;
+ else
+ Check_Valid_Library_Unit_Pragma;
+ end if;
if Nkind (N) = N_Null_Statement then
return;
@@ -19235,7 +19960,7 @@ package body Sem_Prag is
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, Ent);
+ Mark_Ghost_Pragma (N, Ent);
if not Debug_Flag_U then
Set_Is_Pure (Ent);
@@ -19274,7 +19999,7 @@ package body Sem_Prag is
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, E);
+ Mark_Ghost_Pragma (N, E);
if Present (E) then
loop
@@ -19619,6 +20344,11 @@ package body Sem_Prag is
Spec_Id := Corresponding_Spec (Pack_Decl);
+ -- A pragma that applies to a Ghost entity becomes Ghost for the
+ -- purposes of legality checks and removal of ignored Ghost code.
+
+ Mark_Ghost_Pragma (N, Spec_Id);
+
-- Chain the pragma on the contract for further processing by
-- Analyze_Refined_State_In_Decl_Part.
@@ -19629,11 +20359,6 @@ package body Sem_Prag is
Analyze_If_Present (Pragma_SPARK_Mode);
- -- A pragma that applies to a Ghost entity becomes Ghost for the
- -- purposes of legality checks and removal of ignored Ghost code.
-
- Mark_Pragma_As_Ghost (N, Spec_Id);
-
-- State refinement is allowed only when the corresponding package
-- declaration has non-null pragma Abstract_State. Refinement not
-- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
@@ -19717,7 +20442,7 @@ package body Sem_Prag is
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, E);
+ Mark_Ghost_Pragma (N, E);
if Nkind (Parent (E)) = N_Formal_Type_Declaration
and then Ekind (E) = E_General_Access_Type
@@ -19731,7 +20456,7 @@ package body Sem_Prag is
else
Error_Pragma_Arg
- ("pragma% applies only to formal access to classwide types",
+ ("pragma% applies only to formal access-to-class-wide types",
Arg1);
end if;
end Remote_Access_Type;
@@ -19762,7 +20487,7 @@ package body Sem_Prag is
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, Cunit_Ent);
+ Mark_Ghost_Pragma (N, Cunit_Ent);
if K = N_Package_Declaration
or else K = N_Generic_Package_Declaration
@@ -19804,7 +20529,7 @@ package body Sem_Prag is
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, Cunit_Ent);
+ Mark_Ghost_Pragma (N, Cunit_Ent);
if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
N_Generic_Package_Declaration)
@@ -19902,6 +20627,49 @@ package body Sem_Prag is
rv;
--------------------------
+ -- Secondary_Stack_Size --
+ --------------------------
+
+ -- pragma Secondary_Stack_Size (EXPRESSION);
+
+ when Pragma_Secondary_Stack_Size => Secondary_Stack_Size : declare
+ P : constant Node_Id := Parent (N);
+ Arg : Node_Id;
+ Ent : Entity_Id;
+
+ begin
+ GNAT_Pragma;
+ Check_No_Identifiers;
+ Check_Arg_Count (1);
+
+ if Nkind (P) = N_Task_Definition then
+ Arg := Get_Pragma_Arg (Arg1);
+ Ent := Defining_Identifier (Parent (P));
+
+ -- The expression must be analyzed in the special manner
+ -- described in "Handling of Default Expressions" in sem.ads.
+
+ Preanalyze_Spec_Expression (Arg, Any_Integer);
+
+ -- The pragma cannot appear if the No_Secondary_Stack
+ -- restriction is in effect.
+
+ Check_Restriction (No_Secondary_Stack, Arg);
+
+ -- Anything else is incorrect
+
+ else
+ Pragma_Misplaced;
+ end if;
+
+ -- Check duplicate pragma before we chain the pragma in the Rep
+ -- Item chain of Ent.
+
+ Check_Duplicate_Pragma (Ent);
+ Record_Rep_Item (Ent, N);
+ end Secondary_Stack_Size;
+
+ --------------------------
-- Short_Circuit_And_Or --
--------------------------
@@ -19961,7 +20729,7 @@ package body Sem_Prag is
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, Cunit_Ent);
+ Mark_Ghost_Pragma (N, Cunit_Ent);
if not Nkind_In (Unit (Cunit_Node), N_Package_Declaration,
N_Generic_Package_Declaration)
@@ -20013,7 +20781,7 @@ package body Sem_Prag is
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, Typ);
+ Mark_Ghost_Pragma (N, Typ);
-- We require the pragma to apply to a type declared in a package
-- declaration, but not (immediately) within a package body.
@@ -20245,8 +21013,8 @@ package body Sem_Prag is
-- Issue an error if the new mode is less restrictive than
-- that of the context.
- if Get_SPARK_Mode_From_Pragma (Context_Pragma) = Off
- and then Get_SPARK_Mode_From_Pragma (N) = On
+ if Get_SPARK_Mode_From_Annotation (Context_Pragma) = Off
+ and then Get_SPARK_Mode_From_Annotation (N) = On
then
Error_Msg_N
("cannot change SPARK_Mode from Off to On", Err_N);
@@ -20283,8 +21051,8 @@ package body Sem_Prag is
-- Issue an error if the new mode is less restrictive
-- than that of the initial declaration.
- if Get_SPARK_Mode_From_Pragma (Entity_Pragma) = Off
- and then Get_SPARK_Mode_From_Pragma (N) = On
+ if Get_SPARK_Mode_From_Annotation (Entity_Pragma) = Off
+ and then Get_SPARK_Mode_From_Annotation (N) = On
then
Error_Msg_N ("incorrect use of SPARK_Mode", Err_N);
Error_Msg_Sloc := Sloc (Entity_Pragma);
@@ -20601,12 +21369,8 @@ package body Sem_Prag is
procedure Set_SPARK_Context is
begin
- SPARK_Mode := Mode_Id;
+ SPARK_Mode := Mode_Id;
SPARK_Mode_Pragma := N;
-
- if SPARK_Mode = On then
- Dynamic_Elaboration_Checks := False;
- end if;
end Set_SPARK_Context;
-- Local variables
@@ -20644,7 +21408,7 @@ package body Sem_Prag is
Mode_Id := Get_SPARK_Mode_Type (Mode);
Context := Parent (N);
- -- The pragma appears in a configuration pragmas file
+ -- The pragma appears in a configuration file
if No (Context) then
Check_Valid_Configuration_Pragma;
@@ -20925,7 +21689,6 @@ package body Sem_Prag is
-- [Write =>] function NAME);
when Pragma_Stream_Convert => Stream_Convert : declare
-
procedure Check_OK_Stream_Convert_Function (Arg : Node_Id);
-- Check that the given argument is the name of a local function
-- of one argument that is not overloaded earlier in the current
@@ -21087,17 +21850,17 @@ package body Sem_Prag is
Check_Arg_Count (1);
if Nkind (A) = N_String_Literal then
- S := Strval (A);
+ S := Strval (A);
declare
Slen : constant Natural := Natural (String_Length (S));
Options : String (1 .. Slen);
- J : Natural;
+ J : Positive;
begin
J := 1;
loop
- C := Get_String_Char (S, Int (J));
+ C := Get_String_Char (S, Pos (J));
exit when not In_Character_Range (C);
Options (J) := Get_Character (C);
@@ -21199,7 +21962,7 @@ package body Sem_Prag is
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, Nam_Id);
+ Mark_Ghost_Pragma (N, Nam_Id);
Set_Debug_Info_Off (Nam_Id);
end Suppress_Debug_Info;
@@ -21242,7 +22005,7 @@ package body Sem_Prag is
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, E);
+ Mark_Ghost_Pragma (N, E);
if not Is_Type (E) and then Ekind (E) /= E_Variable then
Error_Pragma_Arg
@@ -21595,7 +22358,8 @@ package body Sem_Prag is
-- Otherwise the placement is illegal
else
- Pragma_Misplaced;
+ Error_Pragma
+ ("pragma % must be specified within a package declaration");
return;
end if;
@@ -21634,22 +22398,24 @@ package body Sem_Prag is
-- Otherwise the placement is illegal
else
- Pragma_Misplaced;
+ Error_Pragma
+ ("pragma % must be applied to a library-level subprogram "
+ & "declaration");
return;
end if;
Subp_Id := Defining_Entity (Subp_Decl);
+ -- A pragma that applies to a Ghost entity becomes Ghost for the
+ -- purposes of legality checks and removal of ignored Ghost code.
+
+ Mark_Ghost_Pragma (N, Subp_Id);
+
-- Chain the pragma on the contract for further processing by
-- Analyze_Test_Case_In_Decl_Part.
Add_Contract_Item (N, Subp_Id);
- -- A pragma that applies to a Ghost entity becomes Ghost for the
- -- purposes of legality checks and removal of ignored Ghost code.
-
- Mark_Pragma_As_Ghost (N, Subp_Id);
-
-- Preanalyze the original aspect argument "Name" for ASIS or for
-- a generic subprogram to properly capture global references.
@@ -21723,7 +22489,7 @@ package body Sem_Prag is
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, E);
+ Mark_Ghost_Pragma (N, E);
if Rep_Item_Too_Early (E, N)
or else
@@ -21823,8 +22589,9 @@ package body Sem_Prag is
-- ([Entity =>] type_LOCAL_NAME,
-- [Check =>] EXPRESSION);
- when Pragma_Type_Invariant |
- Pragma_Type_Invariant_Class =>
+ when Pragma_Type_Invariant
+ | Pragma_Type_Invariant_Class
+ =>
Type_Invariant : declare
I_Pragma : Node_Id;
@@ -21872,7 +22639,7 @@ package body Sem_Prag is
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, Typ);
+ Mark_Ghost_Pragma (N, Typ);
if Typ = Any_Type
or else Rep_Item_Too_Early (Typ, N)
@@ -21951,6 +22718,30 @@ package body Sem_Prag is
Set_Is_Unchecked_Union (Base_Type (Typ));
end Unchecked_Union;
+ ----------------------------
+ -- Unevaluated_Use_Of_Old --
+ ----------------------------
+
+ -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
+
+ when Pragma_Unevaluated_Use_Of_Old =>
+ GNAT_Pragma;
+ Check_Arg_Count (1);
+ Check_No_Identifiers;
+ Check_Arg_Is_One_Of (Arg1, Name_Error, Name_Warn, Name_Allow);
+
+ -- Suppress/Unsuppress can appear as a configuration pragma, or in
+ -- a declarative part or a package spec.
+
+ if not Is_Configuration_Pragma then
+ Check_Is_In_Decl_Part_Or_Package_Spec;
+ end if;
+
+ -- Store proper setting of Uneval_Old
+
+ Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
+ Uneval_Old := Fold_Upper (Name_Buffer (1));
+
------------------------
-- Unimplemented_Unit --
------------------------
@@ -21962,10 +22753,9 @@ package body Sem_Prag is
-- body, not in the spec).
when Pragma_Unimplemented_Unit => Unimplemented_Unit : declare
- Cunitent : constant Entity_Id :=
+ Cunitent : constant Entity_Id :=
Cunit_Entity (Get_Source_Unit (Loc));
- Ent_Kind : constant Entity_Kind :=
- Ekind (Cunitent);
+ Ent_Kind : constant Entity_Kind := Ekind (Cunitent);
begin
GNAT_Pragma;
@@ -22010,7 +22800,7 @@ package body Sem_Prag is
-- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code.
- Mark_Pragma_As_Ghost (N, E_Id);
+ Mark_Ghost_Pragma (N, E_Id);
Set_Universal_Aliasing (Implementation_Base_Type (E_Id));
Record_Rep_Item (E_Id, N);
end Universal_Alias;
@@ -22023,22 +22813,7 @@ package body Sem_Prag is
when Pragma_Universal_Data =>
GNAT_Pragma;
-
- -- If this is a configuration pragma, then set the universal
- -- addressing option, otherwise confirm that the pragma satisfies
- -- the requirements of library unit pragma placement and leave it
- -- to the GNAAMP back end to detect the pragma (avoids transitive
- -- setting of the option due to withed units).
-
- if Is_Configuration_Pragma then
- Universal_Addressing_On_AAMP := True;
- else
- Check_Valid_Library_Unit_Pragma;
- end if;
-
- if not AAMP_On_Target then
- Error_Pragma ("??pragma% ignored (applies only to AAMP)");
- end if;
+ Error_Pragma ("??pragma% ignored (applies only to AAMP)");
----------------
-- Unmodified --
@@ -22046,92 +22821,8 @@ package body Sem_Prag is
-- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
- when Pragma_Unmodified => Unmodified : declare
- Arg : Node_Id;
- Arg_Expr : Node_Id;
- Arg_Id : Entity_Id;
-
- Ghost_Error_Posted : Boolean := False;
- -- Flag set when an error concerning the illegal mix of Ghost and
- -- non-Ghost variables is emitted.
-
- Ghost_Id : Entity_Id := Empty;
- -- The entity of the first Ghost variable encountered while
- -- processing the arguments of the pragma.
-
- begin
- GNAT_Pragma;
- Check_At_Least_N_Arguments (1);
-
- -- Loop through arguments
-
- Arg := Arg1;
- while Present (Arg) loop
- Check_No_Identifier (Arg);
-
- -- Note: the analyze call done by Check_Arg_Is_Local_Name will
- -- in fact generate reference, so that the entity will have a
- -- reference, which will inhibit any warnings about it not
- -- being referenced, and also properly show up in the ali file
- -- as a reference. But this reference is recorded before the
- -- Has_Pragma_Unreferenced flag is set, so that no warning is
- -- generated for this reference.
-
- Check_Arg_Is_Local_Name (Arg);
- Arg_Expr := Get_Pragma_Arg (Arg);
-
- if Is_Entity_Name (Arg_Expr) then
- Arg_Id := Entity (Arg_Expr);
-
- if Is_Assignable (Arg_Id) then
- Set_Has_Pragma_Unmodified (Arg_Id);
-
- -- A pragma that applies to a Ghost entity becomes Ghost
- -- for the purposes of legality checks and removal of
- -- ignored Ghost code.
-
- Mark_Pragma_As_Ghost (N, Arg_Id);
-
- -- Capture the entity of the first Ghost variable being
- -- processed for error detection purposes.
-
- if Is_Ghost_Entity (Arg_Id) then
- if No (Ghost_Id) then
- Ghost_Id := Arg_Id;
- end if;
-
- -- Otherwise the variable is non-Ghost. It is illegal
- -- to mix references to Ghost and non-Ghost entities
- -- (SPARK RM 6.9).
-
- elsif Present (Ghost_Id)
- and then not Ghost_Error_Posted
- then
- Ghost_Error_Posted := True;
-
- Error_Msg_Name_1 := Pname;
- Error_Msg_N
- ("pragma % cannot mention ghost and non-ghost "
- & "variables", N);
-
- Error_Msg_Sloc := Sloc (Ghost_Id);
- Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
-
- Error_Msg_Sloc := Sloc (Arg_Id);
- Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
- end if;
-
- -- Otherwise the pragma referenced an illegal entity
-
- else
- Error_Pragma_Arg
- ("pragma% can only be applied to a variable", Arg_Expr);
- end if;
- end if;
-
- Next (Arg);
- end loop;
- end Unmodified;
+ when Pragma_Unmodified =>
+ Analyze_Unmodified_Or_Unused;
------------------
-- Unreferenced --
@@ -22143,133 +22834,8 @@ package body Sem_Prag is
-- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
- when Pragma_Unreferenced => Unreferenced : declare
- Arg : Node_Id;
- Arg_Expr : Node_Id;
- Arg_Id : Entity_Id;
- Citem : Node_Id;
-
- Ghost_Error_Posted : Boolean := False;
- -- Flag set when an error concerning the illegal mix of Ghost and
- -- non-Ghost names is emitted.
-
- Ghost_Id : Entity_Id := Empty;
- -- The entity of the first Ghost name encountered while processing
- -- the arguments of the pragma.
-
- begin
- GNAT_Pragma;
- Check_At_Least_N_Arguments (1);
-
- -- Check case of appearing within context clause
-
- if Is_In_Context_Clause then
-
- -- The arguments must all be units mentioned in a with clause
- -- in the same context clause. Note we already checked (in
- -- Par.Prag) that the arguments are either identifiers or
- -- selected components.
-
- Arg := Arg1;
- while Present (Arg) loop
- Citem := First (List_Containing (N));
- while Citem /= N loop
- Arg_Expr := Get_Pragma_Arg (Arg);
-
- if Nkind (Citem) = N_With_Clause
- and then Same_Name (Name (Citem), Arg_Expr)
- then
- Set_Has_Pragma_Unreferenced
- (Cunit_Entity
- (Get_Source_Unit
- (Library_Unit (Citem))));
- Set_Elab_Unit_Name (Arg_Expr, Name (Citem));
- exit;
- end if;
-
- Next (Citem);
- end loop;
-
- if Citem = N then
- Error_Pragma_Arg
- ("argument of pragma% is not withed unit", Arg);
- end if;
-
- Next (Arg);
- end loop;
-
- -- Case of not in list of context items
-
- else
- Arg := Arg1;
- while Present (Arg) loop
- Check_No_Identifier (Arg);
-
- -- Note: the analyze call done by Check_Arg_Is_Local_Name
- -- will in fact generate reference, so that the entity will
- -- have a reference, which will inhibit any warnings about
- -- it not being referenced, and also properly show up in the
- -- ali file as a reference. But this reference is recorded
- -- before the Has_Pragma_Unreferenced flag is set, so that
- -- no warning is generated for this reference.
-
- Check_Arg_Is_Local_Name (Arg);
- Arg_Expr := Get_Pragma_Arg (Arg);
-
- if Is_Entity_Name (Arg_Expr) then
- Arg_Id := Entity (Arg_Expr);
-
- -- If the entity is overloaded, the pragma applies to the
- -- most recent overloading, as documented. In this case,
- -- name resolution does not generate a reference, so it
- -- must be done here explicitly.
-
- if Is_Overloaded (Arg_Expr) then
- Generate_Reference (Arg_Id, N);
- end if;
-
- Set_Has_Pragma_Unreferenced (Arg_Id);
-
- -- A pragma that applies to a Ghost entity becomes Ghost
- -- for the purposes of legality checks and removal of
- -- ignored Ghost code.
-
- Mark_Pragma_As_Ghost (N, Arg_Id);
-
- -- Capture the entity of the first Ghost name being
- -- processed for error detection purposes.
-
- if Is_Ghost_Entity (Arg_Id) then
- if No (Ghost_Id) then
- Ghost_Id := Arg_Id;
- end if;
-
- -- Otherwise the name is non-Ghost. It is illegal to mix
- -- references to Ghost and non-Ghost entities
- -- (SPARK RM 6.9).
-
- elsif Present (Ghost_Id)
- and then not Ghost_Error_Posted
- then
- Ghost_Error_Posted := True;
-
- Error_Msg_Name_1 := Pname;
- Error_Msg_N
- ("pragma % cannot mention ghost and non-ghost names",
- N);
-
- Error_Msg_Sloc := Sloc (Ghost_Id);
- Error_Msg_NE ("\& # declared as ghost", N, Ghost_Id);
-
- Error_Msg_Sloc := Sloc (Arg_Id);
- Error_Msg_NE ("\& # declared as non-ghost", N, Arg_Id);
- end if;
- end if;
-
- Next (Arg);
- end loop;
- end if;
- end Unreferenced;
+ when Pragma_Unreferenced =>
+ Analyze_Unreferenced_Or_Unused;
--------------------------
-- Unreferenced_Objects --
@@ -22310,7 +22876,7 @@ package body Sem_Prag is
-- for the purposes of legality checks and removal of
-- ignored Ghost code.
- Mark_Pragma_As_Ghost (N, Arg_Id);
+ Mark_Ghost_Pragma (N, Arg_Id);
-- Capture the entity of the first Ghost type being
-- processed for error detection purposes.
@@ -22377,29 +22943,15 @@ package body Sem_Prag is
Ada_2005_Pragma;
Process_Suppress_Unsuppress (Suppress_Case => False);
- ----------------------------
- -- Unevaluated_Use_Of_Old --
- ----------------------------
-
- -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
-
- when Pragma_Unevaluated_Use_Of_Old =>
- GNAT_Pragma;
- Check_Arg_Count (1);
- Check_No_Identifiers;
- Check_Arg_Is_One_Of (Arg1, Name_Error, Name_Warn, Name_Allow);
-
- -- Suppress/Unsuppress can appear as a configuration pragma, or in
- -- a declarative part or a package spec.
-
- if not Is_Configuration_Pragma then
- Check_Is_In_Decl_Part_Or_Package_Spec;
- end if;
+ ------------
+ -- Unused --
+ ------------
- -- Store proper setting of Uneval_Old
+ -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
- Get_Name_String (Chars (Get_Pragma_Arg (Arg1)));
- Uneval_Old := Fold_Upper (Name_Buffer (1));
+ when Pragma_Unused =>
+ Analyze_Unmodified_Or_Unused (Is_Unused => True);
+ Analyze_Unreferenced_Or_Unused (Is_Unused => True);
-------------------
-- Use_VADS_Size --
@@ -22439,14 +22991,14 @@ package body Sem_Prag is
declare
Slen : constant Natural := Natural (String_Length (S));
Options : String (1 .. Slen);
- J : Natural;
+ J : Positive;
begin
-- Couldn't we use a for loop here over Options'Range???
J := 1;
loop
- C := Get_String_Char (S, Int (J));
+ C := Get_String_Char (S, Pos (J));
-- This is a weird test, it skips setting validity
-- checks entirely if any element of S is out of
@@ -22558,6 +23110,11 @@ package body Sem_Prag is
return;
end if;
+ -- A pragma that applies to a Ghost entity becomes Ghost for the
+ -- purposes of legality checks and removal of ignored Ghost code.
+
+ Mark_Ghost_Pragma (N, Spec_Id);
+
-- Chain the pragma on the contract for completeness
Add_Contract_Item (N, Spec_Id);
@@ -22568,11 +23125,6 @@ package body Sem_Prag is
Analyze_If_Present (Pragma_SPARK_Mode);
- -- A pragma that applies to a Ghost entity becomes Ghost for the
- -- purposes of legality checks and removal of ignored Ghost code.
-
- Mark_Pragma_As_Ghost (N, Spec_Id);
-
-- A volatile function cannot override a non-volatile function
-- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
-- in New_Overloaded_Entity, however at that point the pragma has
@@ -22588,12 +23140,12 @@ package body Sem_Prag is
Error_Msg_Sloc := Sloc (Over_Id);
Error_Msg_N
- ("\& declared # with Volatile_Function value `False`",
+ ("\& declared # with Volatile_Function value False",
Spec_Id);
Error_Msg_Sloc := Sloc (Spec_Id);
Error_Msg_N
- ("\overridden # with Volatile_Function value `True`",
+ ("\overridden # with Volatile_Function value True",
Spec_Id);
end if;
@@ -23037,154 +23589,89 @@ package body Sem_Prag is
-- Analyze_Pre_Post_Condition_In_Decl_Part --
---------------------------------------------
+ -- WARNING: This routine manages Ghost regions. Return statements must be
+ -- replaced by gotos which jump to the end of the routine and restore the
+ -- Ghost mode.
+
procedure Analyze_Pre_Post_Condition_In_Decl_Part
(N : Node_Id;
Freeze_Id : Entity_Id := Empty)
is
- procedure Process_Class_Wide_Condition
- (Expr : Node_Id;
- Spec_Id : Entity_Id;
- Subp_Decl : Node_Id);
- -- Replace the type of all references to the controlling formal of
- -- subprogram Spec_Id found in expression Expr with the corresponding
- -- class-wide type. Subp_Decl is the subprogram [body] declaration
- -- where the pragma resides.
-
- ----------------------------------
- -- Process_Class_Wide_Condition --
- ----------------------------------
-
- procedure Process_Class_Wide_Condition
- (Expr : Node_Id;
- Spec_Id : Entity_Id;
- Subp_Decl : Node_Id)
- is
- Disp_Typ : constant Entity_Id := Find_Dispatching_Type (Spec_Id);
-
- ACW : Entity_Id := Empty;
- -- Access to Disp_Typ'Class, created if there is a controlling formal
- -- that is an access parameter.
-
- function Access_Class_Wide_Type return Entity_Id;
- -- If expression Expr contains a reference to a controlling access
- -- parameter, create an access to Disp_Typ'Class for the necessary
- -- conversions if one does not exist.
-
- function Replace_Type (N : Node_Id) return Traverse_Result;
- -- ARM 6.1.1: Within the expression for a Pre'Class or Post'Class
- -- aspect for a primitive subprogram of a tagged type Disp_Typ, a
- -- name that denotes a formal parameter of type Disp_Typ is treated
- -- as having type Disp_Typ'Class. Similarly, a name that denotes a
- -- formal access parameter of type access-to-Disp_Typ is interpreted
- -- as with type access-to-Disp_Typ'Class. This ensures the expression
- -- is well defined for a primitive subprogram of a type descended
- -- from Disp_Typ.
-
- ----------------------------
- -- Access_Class_Wide_Type --
- ----------------------------
-
- function Access_Class_Wide_Type return Entity_Id is
- Loc : constant Source_Ptr := Sloc (N);
-
- begin
- if No (ACW) then
- ACW := Make_Temporary (Loc, 'T');
+ Disp_Typ : Entity_Id;
+ -- The dispatching type of the subprogram subject to the pre- or
+ -- postcondition.
- Insert_Before_And_Analyze (Subp_Decl,
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => ACW,
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- Subtype_Indication =>
- New_Occurrence_Of (Class_Wide_Type (Disp_Typ), Loc),
- All_Present => True)));
+ function Check_References (Nod : Node_Id) return Traverse_Result;
+ -- Check that expression Nod does not mention non-primitives of the
+ -- type, global objects of the type, or other illegalities described
+ -- and implied by AI12-0113.
- Freeze_Before (Subp_Decl, ACW);
- end if;
-
- return ACW;
- end Access_Class_Wide_Type;
-
- ------------------
- -- Replace_Type --
- ------------------
-
- function Replace_Type (N : Node_Id) return Traverse_Result is
- Context : constant Node_Id := Parent (N);
- Loc : constant Source_Ptr := Sloc (N);
- CW_Typ : Entity_Id := Empty;
- Ent : Entity_Id;
- Typ : Entity_Id;
-
- begin
- if Is_Entity_Name (N)
- and then Present (Entity (N))
- and then Is_Formal (Entity (N))
- then
- Ent := Entity (N);
- Typ := Etype (Ent);
+ ----------------------
+ -- Check_References --
+ ----------------------
- -- Do not perform the type replacement for selector names in
- -- parameter associations. These carry an entity for reference
- -- purposes, but semantically they are just identifiers.
+ function Check_References (Nod : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (Nod) = N_Function_Call
+ and then Is_Entity_Name (Name (Nod))
+ then
+ declare
+ Func : constant Entity_Id := Entity (Name (Nod));
+ Form : Entity_Id;
- if Nkind (Context) = N_Type_Conversion then
- null;
+ begin
+ -- An operation of the type must be a primitive
- elsif Nkind (Context) = N_Parameter_Association
- and then Selector_Name (Context) = N
- then
- null;
+ if No (Find_Dispatching_Type (Func)) then
+ Form := First_Formal (Func);
+ while Present (Form) loop
+ if Etype (Form) = Disp_Typ then
+ Error_Msg_NE
+ ("operation in class-wide condition must be "
+ & "primitive of &", Nod, Disp_Typ);
+ end if;
- elsif Typ = Disp_Typ then
- CW_Typ := Class_Wide_Type (Typ);
+ Next_Formal (Form);
+ end loop;
- elsif Is_Access_Type (Typ)
- and then Designated_Type (Typ) = Disp_Typ
- then
- CW_Typ := Access_Class_Wide_Type;
- end if;
+ -- A return object of the type is illegal as well
- if Present (CW_Typ) then
- Rewrite (N,
- Make_Type_Conversion (Loc,
- Subtype_Mark => New_Occurrence_Of (CW_Typ, Loc),
- Expression => New_Occurrence_Of (Ent, Loc)));
- Set_Etype (N, CW_Typ);
+ if Etype (Func) = Disp_Typ
+ or else Etype (Func) = Class_Wide_Type (Disp_Typ)
+ then
+ Error_Msg_NE
+ ("operation in class-wide condition must be primitive "
+ & "of &", Nod, Disp_Typ);
+ end if;
end if;
- end if;
-
- return OK;
- end Replace_Type;
-
- procedure Replace_Types is new Traverse_Proc (Replace_Type);
-
- -- Start of processing for Process_Class_Wide_Condition
-
- begin
- -- The subprogram subject to Pre'Class/Post'Class does not have a
- -- dispatching type, therefore the aspect/pragma is illegal.
-
- if No (Disp_Typ) then
- Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
-
- if From_Aspect_Specification (N) then
- Error_Msg_N
- ("aspect % can only be specified for a primitive operation "
- & "of a tagged type", Corresponding_Aspect (N));
-
- -- The pragma is a source construct
+ end;
- else
- Error_Msg_N
- ("pragma % can only be specified for a primitive operation "
- & "of a tagged type", N);
- end if;
+ elsif Is_Entity_Name (Nod)
+ and then
+ (Etype (Nod) = Disp_Typ
+ or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
+ and then Ekind_In (Entity (Nod), E_Constant, E_Variable)
+ then
+ Error_Msg_NE
+ ("object in class-wide condition must be formal of type &",
+ Nod, Disp_Typ);
+
+ elsif Nkind (Nod) = N_Explicit_Dereference
+ and then (Etype (Nod) = Disp_Typ
+ or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
+ and then (not Is_Entity_Name (Prefix (Nod))
+ or else not Is_Formal (Entity (Prefix (Nod))))
+ then
+ Error_Msg_NE
+ ("operation in class-wide condition must be primitive of &",
+ Nod, Disp_Typ);
end if;
- Replace_Types (Expr);
- end Process_Class_Wide_Condition;
+ return OK;
+ end Check_References;
+
+ procedure Check_Class_Wide_Condition is
+ new Traverse_Proc (Check_References);
-- Local variables
@@ -23192,9 +23679,8 @@ package body Sem_Prag is
Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
-
Errors : Nat;
+ Mode : Ghost_Mode_Type;
Restore_Scope : Boolean := False;
-- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
@@ -23208,10 +23694,10 @@ package body Sem_Prag is
-- Set the Ghost mode in effect from the pragma. Due to the delayed
-- analysis of the pragma, the Ghost mode at point of declaration and
- -- point of analysis may not necessarely be the same. Use the mode in
+ -- point of analysis may not necessarily be the same. Use the mode in
-- effect at the point of declaration.
- Set_Ghost_Mode (N);
+ Set_Ghost_Mode (N, Mode);
-- Ensure that the subprogram and its formals are visible when analyzing
-- the expression of the pragma.
@@ -23240,13 +23726,36 @@ package body Sem_Prag is
Contract_Freeze_Error (Spec_Id, Freeze_Id);
end if;
- -- For a class-wide condition, a reference to a controlling formal must
- -- be interpreted as having the class-wide type (or an access to such)
- -- so that the inherited condition can be properly applied to any
- -- overriding operation (see ARM12 6.6.1 (7)).
-
if Class_Present (N) then
- Process_Class_Wide_Condition (Expr, Spec_Id, Subp_Decl);
+
+ -- Verify that a class-wide condition is legal, i.e. the operation is
+ -- a primitive of a tagged type. Note that a generic subprogram is
+ -- not a primitive operation.
+
+ Disp_Typ := Find_Dispatching_Type (Spec_Id);
+
+ if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
+ Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
+
+ if From_Aspect_Specification (N) then
+ Error_Msg_N
+ ("aspect % can only be specified for a primitive operation "
+ & "of a tagged type", Corresponding_Aspect (N));
+
+ -- The pragma is a source construct
+
+ else
+ Error_Msg_N
+ ("pragma % can only be specified for a primitive operation "
+ & "of a tagged type", N);
+ end if;
+
+ -- Remaining semantic checks require a full tree traversal
+
+ else
+ Check_Class_Wide_Condition (Expr);
+ end if;
+
end if;
if Restore_Scope then
@@ -23257,9 +23766,9 @@ package body Sem_Prag is
-- subprogram subject to pragma Inline_Always.
Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
- Ghost_Mode := Save_Ghost_Mode;
-
Set_Is_Analyzed_Pragma (N);
+
+ Restore_Ghost_Mode (Mode);
end Analyze_Pre_Post_Condition_In_Decl_Part;
------------------------------------------
@@ -23267,56 +23776,78 @@ package body Sem_Prag is
------------------------------------------
procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
- Body_Inputs : Elist_Id := No_Elist;
- Body_Outputs : Elist_Id := No_Elist;
- -- The inputs and outputs of the subprogram body synthesized from pragma
- -- Refined_Depends.
-
- Dependencies : List_Id := No_List;
- Depends : Node_Id;
- -- The corresponding Depends pragma along with its clauses
-
- Matched_Items : Elist_Id := No_Elist;
- -- A list containing the entities of all successfully matched items
- -- found in pragma Depends.
-
- Refinements : List_Id := No_List;
- -- The clauses of pragma Refined_Depends
-
- Spec_Id : Entity_Id;
- -- The entity of the subprogram subject to pragma Refined_Depends
-
- Spec_Inputs : Elist_Id := No_Elist;
- Spec_Outputs : Elist_Id := No_Elist;
- -- The inputs and outputs of the subprogram spec synthesized from pragma
- -- Depends.
-
- procedure Check_Dependency_Clause (Dep_Clause : Node_Id);
+ procedure Check_Dependency_Clause
+ (Spec_Id : Entity_Id;
+ Dep_Clause : Node_Id;
+ Dep_States : Elist_Id;
+ Refinements : List_Id;
+ Matched_Items : in out Elist_Id);
-- Try to match a single dependency clause Dep_Clause against one or
-- more refinement clauses found in list Refinements. Each successful
-- match eliminates at least one refinement clause from Refinements.
-
- procedure Check_Output_States;
+ -- Spec_Id denotes the entity of the related subprogram. Dep_States
+ -- denotes the entities of all abstract states which appear in pragma
+ -- Depends. Matched_Items contains the entities of all successfully
+ -- matched items found in pragma Depends.
+
+ procedure Check_Output_States
+ (Spec_Id : Entity_Id;
+ Spec_Inputs : Elist_Id;
+ Spec_Outputs : Elist_Id;
+ Body_Inputs : Elist_Id;
+ Body_Outputs : Elist_Id);
-- Determine whether pragma Depends contains an output state with a
-- visible refinement and if so, ensure that pragma Refined_Depends
- -- mentions all its constituents as outputs.
+ -- mentions all its constituents as outputs. Spec_Id is the entity of
+ -- the related subprograms. Spec_Inputs and Spec_Outputs denote the
+ -- inputs and outputs of the subprogram spec synthesized from pragma
+ -- Depends. Body_Inputs and Body_Outputs denote the inputs and outputs
+ -- of the subprogram body synthesized from pragma Refined_Depends.
+
+ function Collect_States (Clauses : List_Id) return Elist_Id;
+ -- Given a normalized list of dependencies obtained from calling
+ -- Normalize_Clauses, return a list containing the entities of all
+ -- states appearing in dependencies. It helps in checking refinements
+ -- involving a state and a corresponding constituent which is not a
+ -- direct constituent of the state.
procedure Normalize_Clauses (Clauses : List_Id);
-- Given a list of dependence or refinement clauses Clauses, normalize
-- each clause by creating multiple dependencies with exactly one input
-- and one output.
- procedure Report_Extra_Clauses;
- -- Emit an error for each extra clause found in list Refinements
+ procedure Remove_Extra_Clauses
+ (Clauses : List_Id;
+ Matched_Items : Elist_Id);
+ -- Given a list of refinement clauses Clauses, remove all clauses whose
+ -- inputs and/or outputs have been previously matched. See the body for
+ -- all special cases. Matched_Items contains the entities of all matched
+ -- items found in pragma Depends.
+
+ procedure Report_Extra_Clauses
+ (Spec_Id : Entity_Id;
+ Clauses : List_Id);
+ -- Emit an error for each extra clause found in list Clauses. Spec_Id
+ -- denotes the entity of the related subprogram.
-----------------------------
-- Check_Dependency_Clause --
-----------------------------
- procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is
+ procedure Check_Dependency_Clause
+ (Spec_Id : Entity_Id;
+ Dep_Clause : Node_Id;
+ Dep_States : Elist_Id;
+ Refinements : List_Id;
+ Matched_Items : in out Elist_Id)
+ is
Dep_Input : constant Node_Id := Expression (Dep_Clause);
Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
+ function Is_Already_Matched (Dep_Item : Node_Id) return Boolean;
+ -- Determine whether dependency item Dep_Item has been matched in a
+ -- previous clause.
+
function Is_In_Out_State_Clause return Boolean;
-- Determine whether dependence clause Dep_Clause denotes an abstract
-- state that depends on itself (State => State).
@@ -23330,7 +23861,7 @@ package body Sem_Prag is
Ref_Item : Node_Id;
Matched : out Boolean);
-- Try to match dependence item Dep_Item against refinement item
- -- Ref_Item. To match against a possible null refinement (see 2, 7),
+ -- Ref_Item. To match against a possible null refinement (see 2, 9),
-- set Ref_Item to Empty. Flag Matched is set to True when one of
-- the following conformance scenarios is in effect:
-- 1) Both items denote null
@@ -23344,16 +23875,39 @@ package body Sem_Prag is
-- and Ref_Item denotes null.
-- 9) Dep_Item is an abstract state with visible null refinement
-- and Ref_Item is Empty (special case).
- -- 10) Dep_Item is an abstract state with visible non-null
- -- refinement and Ref_Item denotes one of its constituents.
- -- 11) Dep_Item is an abstract state without a visible refinement
- -- and Ref_Item denotes the same state.
+ -- 10) Dep_Item is an abstract state with full or partial visible
+ -- non-null refinement and Ref_Item denotes one of its
+ -- constituents.
+ -- 11) Dep_Item is an abstract state without a full visible
+ -- refinement and Ref_Item denotes the same state.
-- When scenario 10 is in effect, the entity of the abstract state
-- denoted by Dep_Item is added to list Refined_States.
procedure Record_Item (Item_Id : Entity_Id);
-- Store the entity of an item denoted by Item_Id in Matched_Items
+ ------------------------
+ -- Is_Already_Matched --
+ ------------------------
+
+ function Is_Already_Matched (Dep_Item : Node_Id) return Boolean is
+ Item_Id : Entity_Id := Empty;
+
+ begin
+ -- When the dependency item denotes attribute 'Result, check for
+ -- the entity of the related subprogram.
+
+ if Is_Attribute_Result (Dep_Item) then
+ Item_Id := Spec_Id;
+
+ elsif Is_Entity_Name (Dep_Item) then
+ Item_Id := Available_View (Entity_Of (Dep_Item));
+ end if;
+
+ return
+ Present (Item_Id) and then Contains (Matched_Items, Item_Id);
+ end Is_Already_Matched;
+
----------------------------
-- Is_In_Out_State_Clause --
----------------------------
@@ -23431,8 +23985,13 @@ package body Sem_Prag is
-- Attribute 'Result matches attribute 'Result
elsif Is_Attribute_Result (Dep_Item)
- and then Is_Attribute_Result (Dep_Item)
+ and then Is_Attribute_Result (Ref_Item)
then
+ -- Put the entity of the related function on the list of
+ -- matched items because attribute 'Result does not carry
+ -- an entity similar to states and constituents.
+
+ Record_Item (Spec_Id);
Matched := True;
-- Abstract states, current instances of concurrent types,
@@ -23456,7 +24015,8 @@ package body Sem_Prag is
Matched := True;
-- An abstract state with visible non-null refinement
- -- matches one of its constituents.
+ -- matches one of its constituents, or itself for an
+ -- abstract state with partial visible refinement.
elsif Has_Non_Null_Visible_Refinement (Dep_Item_Id) then
if Is_Entity_Name (Ref_Item) then
@@ -23466,8 +24026,14 @@ package body Sem_Prag is
E_Constant,
E_Variable)
and then Present (Encapsulating_State (Ref_Item_Id))
- and then Encapsulating_State (Ref_Item_Id) =
- Dep_Item_Id
+ and then Find_Encapsulating_State
+ (Dep_States, Ref_Item_Id) = Dep_Item_Id
+ then
+ Record_Item (Dep_Item_Id);
+ Matched := True;
+
+ elsif not Has_Visible_Refinement (Dep_Item_Id)
+ and then Ref_Item_Id = Dep_Item_Id
then
Record_Item (Dep_Item_Id);
Matched := True;
@@ -23502,9 +24068,11 @@ package body Sem_Prag is
procedure Record_Item (Item_Id : Entity_Id) is
begin
- if not Contains (Matched_Items, Item_Id) then
- Append_New_Elmt (Item_Id, Matched_Items);
+ if No (Matched_Items) then
+ Matched_Items := New_Elmt_List;
end if;
+
+ Append_Unique_Elmt (Item_Id, Matched_Items);
end Record_Item;
-- Local variables
@@ -23592,7 +24160,7 @@ package body Sem_Prag is
-- the pool of candidates. The seach continues because a single
-- dependence clause may have multiple matching refinements.
- if Inputs_Match and then Outputs_Match then
+ if Inputs_Match and Outputs_Match then
Clause_Matched := True;
Remove (Ref_Clause);
end if;
@@ -23603,8 +24171,8 @@ package body Sem_Prag is
-- Depending on the order or composition of refinement clauses, an
-- In_Out state clause may not be directly refinable.
- -- Depends => ((Output, State) => (Input, State))
-- Refined_State => (State => (Constit_1, Constit_2))
+ -- Depends => ((Output, State) => (Input, State))
-- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
-- Matching normalized clause (State => State) fails because there is
@@ -23616,25 +24184,24 @@ package body Sem_Prag is
if not Clause_Matched
and then Is_In_Out_State_Clause
- and then
- Contains (Matched_Items, Available_View (Entity_Of (Dep_Input)))
+ and then Is_Already_Matched (Dep_Input)
then
Clause_Matched := True;
end if;
-- A clause where the input is an abstract state with visible null
- -- refinement is implicitly matched when the output has already been
- -- matched in a previous clause.
+ -- refinement or a 'Result attribute is implicitly matched when the
+ -- output has already been matched in a previous clause.
- -- Depends => (Output => State) -- implicitly OK
-- Refined_State => (State => null)
+ -- Depends => (Output => State) -- implicitly OK
-- Refined_Depends => (Output => ...)
+ -- Depends => (...'Result => State) -- implicitly OK
+ -- Refined_Depends => (...'Result => ...)
if not Clause_Matched
and then Is_Null_Refined_State (Dep_Input)
- and then Is_Entity_Name (Dep_Output)
- and then
- Contains (Matched_Items, Available_View (Entity_Of (Dep_Output)))
+ and then Is_Already_Matched (Dep_Output)
then
Clause_Matched := True;
end if;
@@ -23643,15 +24210,13 @@ package body Sem_Prag is
-- refinement is implicitly matched when the input has already been
-- matched in a previous clause.
- -- Depends => (State => Input) -- implicitly OK
-- Refined_State => (State => null)
+ -- Depends => (State => Input) -- implicitly OK
-- Refined_Depends => (... => Input)
if not Clause_Matched
and then Is_Null_Refined_State (Dep_Output)
- and then Is_Entity_Name (Dep_Input)
- and then
- Contains (Matched_Items, Available_View (Entity_Of (Dep_Input)))
+ and then Is_Already_Matched (Dep_Input)
then
Clause_Matched := True;
end if;
@@ -23660,8 +24225,8 @@ package body Sem_Prag is
-- pragma Refined_Depends contains a solitary null. Only an abstract
-- state with null refinement can possibly match these cases.
- -- Depends => (State => null)
-- Refined_State => (State => null)
+ -- Depends => (State => null)
-- Refined_Depends => null -- OK
if not Clause_Matched then
@@ -23693,56 +24258,87 @@ package body Sem_Prag is
-- Check_Output_States --
-------------------------
- procedure Check_Output_States is
+ procedure Check_Output_States
+ (Spec_Id : Entity_Id;
+ Spec_Inputs : Elist_Id;
+ Spec_Outputs : Elist_Id;
+ Body_Inputs : Elist_Id;
+ Body_Outputs : Elist_Id)
+ is
procedure Check_Constituent_Usage (State_Id : Entity_Id);
- -- Determine whether all constituents of state State_Id with visible
- -- refinement are used as outputs in pragma Refined_Depends. Emit an
- -- error if this is not the case.
+ -- Determine whether all constituents of state State_Id with full
+ -- visible refinement are used as outputs in pragma Refined_Depends.
+ -- Emit an error if this is not the case (SPARK RM 7.2.4(5)).
-----------------------------
-- Check_Constituent_Usage --
-----------------------------
procedure Check_Constituent_Usage (State_Id : Entity_Id) is
+ Constits : constant Elist_Id :=
+ Partial_Refinement_Constituents (State_Id);
Constit_Elmt : Elmt_Id;
Constit_Id : Entity_Id;
+ Only_Partial : constant Boolean :=
+ not Has_Visible_Refinement (State_Id);
Posted : Boolean := False;
begin
- Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id));
- while Present (Constit_Elmt) loop
- Constit_Id := Node (Constit_Elmt);
+ if Present (Constits) then
+ Constit_Elmt := First_Elmt (Constits);
+ while Present (Constit_Elmt) loop
+ Constit_Id := Node (Constit_Elmt);
- -- The constituent acts as an input (SPARK RM 7.2.5(3))
+ -- Issue an error when a constituent of State_Id is used,
+ -- and State_Id has only partial visible refinement
+ -- (SPARK RM 7.2.4(3d)).
- if Present (Body_Inputs)
- and then Appears_In (Body_Inputs, Constit_Id)
- then
- Error_Msg_Name_1 := Chars (State_Id);
- SPARK_Msg_NE
- ("constituent & of state % must act as output in "
- & "dependence refinement", N, Constit_Id);
+ if Only_Partial then
+ if (Present (Body_Inputs)
+ and then Appears_In (Body_Inputs, Constit_Id))
+ or else
+ (Present (Body_Outputs)
+ and then Appears_In (Body_Outputs, Constit_Id))
+ then
+ Error_Msg_Name_1 := Chars (State_Id);
+ SPARK_Msg_NE
+ ("constituent & of state % cannot be used in "
+ & "dependence refinement", N, Constit_Id);
+ Error_Msg_Name_1 := Chars (State_Id);
+ SPARK_Msg_N ("\use state % instead", N);
+ end if;
- -- The constituent is altogether missing (SPARK RM 7.2.5(3))
+ -- The constituent acts as an input (SPARK RM 7.2.5(3))
- elsif No (Body_Outputs)
- or else not Appears_In (Body_Outputs, Constit_Id)
- then
- if not Posted then
- Posted := True;
+ elsif Present (Body_Inputs)
+ and then Appears_In (Body_Inputs, Constit_Id)
+ then
+ Error_Msg_Name_1 := Chars (State_Id);
SPARK_Msg_NE
- ("output state & must be replaced by all its "
- & "constituents in dependence refinement",
- N, State_Id);
- end if;
+ ("constituent & of state % must act as output in "
+ & "dependence refinement", N, Constit_Id);
- SPARK_Msg_NE
- ("\constituent & is missing in output list",
- N, Constit_Id);
- end if;
+ -- The constituent is altogether missing (SPARK RM 7.2.5(3))
- Next_Elmt (Constit_Elmt);
- end loop;
+ elsif No (Body_Outputs)
+ or else not Appears_In (Body_Outputs, Constit_Id)
+ then
+ if not Posted then
+ Posted := True;
+ SPARK_Msg_NE
+ ("output state & must be replaced by all its "
+ & "constituents in dependence refinement",
+ N, State_Id);
+ end if;
+
+ SPARK_Msg_NE
+ ("\constituent & is missing in output list",
+ N, Constit_Id);
+ end if;
+
+ Next_Elmt (Constit_Elmt);
+ end loop;
+ end if;
end Check_Constituent_Usage;
-- Local variables
@@ -23798,6 +24394,64 @@ package body Sem_Prag is
end if;
end Check_Output_States;
+ --------------------
+ -- Collect_States --
+ --------------------
+
+ function Collect_States (Clauses : List_Id) return Elist_Id is
+ procedure Collect_State
+ (Item : Node_Id;
+ States : in out Elist_Id);
+ -- Add the entity of Item to list States when it denotes to a state
+
+ -------------------
+ -- Collect_State --
+ -------------------
+
+ procedure Collect_State
+ (Item : Node_Id;
+ States : in out Elist_Id)
+ is
+ Id : Entity_Id;
+
+ begin
+ if Is_Entity_Name (Item) then
+ Id := Entity_Of (Item);
+
+ if Ekind (Id) = E_Abstract_State then
+ if No (States) then
+ States := New_Elmt_List;
+ end if;
+
+ Append_Unique_Elmt (Id, States);
+ end if;
+ end if;
+ end Collect_State;
+
+ -- Local variables
+
+ Clause : Node_Id;
+ Input : Node_Id;
+ Output : Node_Id;
+ States : Elist_Id := No_Elist;
+
+ -- Start of processing for Collect_States
+
+ begin
+ Clause := First (Clauses);
+ while Present (Clause) loop
+ Input := Expression (Clause);
+ Output := First (Choices (Clause));
+
+ Collect_State (Input, States);
+ Collect_State (Output, States);
+
+ Next (Clause);
+ end loop;
+
+ return States;
+ end Collect_States;
+
-----------------------
-- Normalize_Clauses --
-----------------------
@@ -23964,10 +24618,90 @@ package body Sem_Prag is
end Normalize_Clauses;
--------------------------
+ -- Remove_Extra_Clauses --
+ --------------------------
+
+ procedure Remove_Extra_Clauses
+ (Clauses : List_Id;
+ Matched_Items : Elist_Id)
+ is
+ Clause : Node_Id;
+ Input : Node_Id;
+ Input_Id : Entity_Id;
+ Next_Clause : Node_Id;
+ Output : Node_Id;
+ State_Id : Entity_Id;
+
+ begin
+ Clause := First (Clauses);
+ while Present (Clause) loop
+ Next_Clause := Next (Clause);
+
+ Input := Expression (Clause);
+ Output := First (Choices (Clause));
+
+ -- Recognize a clause of the form
+
+ -- null => Input
+
+ -- where Input is a constituent of a state which was already
+ -- successfully matched. This clause must be removed because it
+ -- simply indicates that some of the constituents of the state
+ -- are not used.
+
+ -- Refined_State => (State => (Constit_1, Constit_2))
+ -- Depends => (Output => State)
+ -- Refined_Depends => ((Output => Constit_1), -- State matched
+ -- (null => Constit_2)) -- OK
+
+ if Nkind (Output) = N_Null and then Is_Entity_Name (Input) then
+
+ -- Handle abstract views generated for limited with clauses
+
+ Input_Id := Available_View (Entity_Of (Input));
+
+ -- The input must be a constituent of a state
+
+ if Ekind_In (Input_Id, E_Abstract_State,
+ E_Constant,
+ E_Variable)
+ and then Present (Encapsulating_State (Input_Id))
+ then
+ State_Id := Encapsulating_State (Input_Id);
+
+ -- The state must have a non-null visible refinement and be
+ -- matched in a previous clause.
+
+ if Has_Non_Null_Visible_Refinement (State_Id)
+ and then Contains (Matched_Items, State_Id)
+ then
+ Remove (Clause);
+ end if;
+ end if;
+
+ -- Recognize a clause of the form
+
+ -- Output => null
+
+ -- where Output is an arbitrary item. This clause must be removed
+ -- because a null input legitimately matches anything.
+
+ elsif Nkind (Input) = N_Null then
+ Remove (Clause);
+ end if;
+
+ Clause := Next_Clause;
+ end loop;
+ end Remove_Extra_Clauses;
+
+ --------------------------
-- Report_Extra_Clauses --
--------------------------
- procedure Report_Extra_Clauses is
+ procedure Report_Extra_Clauses
+ (Spec_Id : Entity_Id;
+ Clauses : List_Id)
+ is
Clause : Node_Id;
begin
@@ -23977,23 +24711,12 @@ package body Sem_Prag is
if Is_Generic_Instance (Spec_Id) then
null;
- elsif Present (Refinements) then
- Clause := First (Refinements);
+ elsif Present (Clauses) then
+ Clause := First (Clauses);
while Present (Clause) loop
-
- -- Do not complain about a null input refinement, since a null
- -- input legitimately matches anything.
-
- if Nkind (Clause) = N_Component_Association
- and then Nkind (Expression (Clause)) = N_Null
- then
- null;
-
- else
- SPARK_Msg_N
- ("unmatched or extra clause in dependence refinement",
- Clause);
- end if;
+ SPARK_Msg_N
+ ("unmatched or extra clause in dependence refinement",
+ Clause);
Next (Clause);
end loop;
@@ -24005,10 +24728,39 @@ package body Sem_Prag is
Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
Body_Id : constant Entity_Id := Defining_Entity (Body_Decl);
Errors : constant Nat := Serious_Errors_Detected;
- Clause : Node_Id;
- Deps : Node_Id;
- Dummy : Boolean;
- Refs : Node_Id;
+
+ Clause : Node_Id;
+ Deps : Node_Id;
+ Dummy : Boolean;
+ Refs : Node_Id;
+
+ Body_Inputs : Elist_Id := No_Elist;
+ Body_Outputs : Elist_Id := No_Elist;
+ -- The inputs and outputs of the subprogram body synthesized from pragma
+ -- Refined_Depends.
+
+ Dependencies : List_Id := No_List;
+ Depends : Node_Id;
+ -- The corresponding Depends pragma along with its clauses
+
+ Matched_Items : Elist_Id := No_Elist;
+ -- A list containing the entities of all successfully matched items
+ -- found in pragma Depends.
+
+ Refinements : List_Id := No_List;
+ -- The clauses of pragma Refined_Depends
+
+ Spec_Id : Entity_Id;
+ -- The entity of the subprogram subject to pragma Refined_Depends
+
+ Spec_Inputs : Elist_Id := No_Elist;
+ Spec_Outputs : Elist_Id := No_Elist;
+ -- The inputs and outputs of the subprogram spec synthesized from pragma
+ -- Depends.
+
+ States : Elist_Id := No_Elist;
+ -- A list containing the entities of all states whose constituents
+ -- appear in pragma Depends.
-- Start of processing for Analyze_Refined_Depends_In_Decl_Part
@@ -24090,7 +24842,12 @@ package body Sem_Prag is
-- For an output state with a visible refinement, ensure that all
-- constituents appear as outputs in the dependency refinement.
- Check_Output_States;
+ Check_Output_States
+ (Spec_Id => Spec_Id,
+ Spec_Inputs => Spec_Inputs,
+ Spec_Outputs => Spec_Outputs,
+ Body_Inputs => Body_Inputs,
+ Body_Outputs => Body_Outputs);
end if;
-- Matching is disabled in ASIS because clauses are not normalized as
@@ -24108,6 +24865,10 @@ package body Sem_Prag is
Dependencies := New_Copy_List_Tree (Component_Associations (Deps));
Normalize_Clauses (Dependencies);
+ -- Gather all states which appear in Depends
+
+ States := Collect_States (Dependencies);
+
Refs := Expression (Get_Argument (N, Spec_Id));
if Nkind (Refs) = N_Null then
@@ -24129,12 +24890,31 @@ package body Sem_Prag is
Clause := First (Dependencies);
while Present (Clause) loop
- Check_Dependency_Clause (Clause);
+ Check_Dependency_Clause
+ (Spec_Id => Spec_Id,
+ Dep_Clause => Clause,
+ Dep_States => States,
+ Refinements => Refinements,
+ Matched_Items => Matched_Items);
+
Next (Clause);
end loop;
+ -- Pragma Refined_Depends may contain multiple clarification clauses
+ -- which indicate that certain constituents do not influence the data
+ -- flow in any way. Such clauses must be removed as long as the state
+ -- has been matched, otherwise they will be incorrectly flagged as
+ -- unmatched.
+
+ -- Refined_State => (State => (Constit_1, Constit_2))
+ -- Depends => (Output => State)
+ -- Refined_Depends => ((Output => Constit_1), -- State matched
+ -- (null => Constit_2)) -- must be removed
+
+ Remove_Extra_Clauses (Refinements, Matched_Items);
+
if Serious_Errors_Detected = Errors then
- Report_Extra_Clauses;
+ Report_Extra_Clauses (Spec_Id, Refinements);
end if;
end if;
@@ -24174,14 +24954,21 @@ package body Sem_Prag is
In_Out_Items : Elist_Id := No_Elist;
Out_Items : Elist_Id := No_Elist;
Proof_In_Items : Elist_Id := No_Elist;
- -- These list contain the entities of all Input, In_Out, Output and
+ -- These lists contain the entities of all Input, In_Out, Output and
-- Proof_In items defined in the corresponding Global pragma.
+ Repeat_Items : Elist_Id := No_Elist;
+ -- A list of all global items without full visible refinement found
+ -- in pragma Global. These states should be repeated in the global
+ -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible
+ -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)).
+
Spec_Id : Entity_Id;
-- The entity of the subprogram subject to pragma Refined_Global
States : Elist_Id := No_Elist;
- -- A list of all states with visible refinement found in pragma Global
+ -- A list of all states with full or partial visible refinement found in
+ -- pragma Global.
procedure Check_In_Out_States;
-- Determine whether the corresponding Global pragma mentions In_Out
@@ -24224,13 +25011,14 @@ package body Sem_Prag is
procedure Collect_Global_Items
(List : Node_Id;
Mode : Name_Id := Name_Input);
- -- Gather all input, in out, output and Proof_In items from node List
+ -- Gather all Input, In_Out, Output and Proof_In items from node List
-- and separate them in lists In_Items, In_Out_Items, Out_Items and
-- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
-- and Has_Proof_In_State are set when there is at least one abstract
- -- state with visible refinement available in the corresponding mode.
- -- Flag Has_Null_State is set when at least state has a null refinement.
- -- Mode enotes the current global mode in effect.
+ -- state with full or partial visible refinement available in the
+ -- corresponding mode. Flag Has_Null_State is set when at least state
+ -- has a null refinement. Mode denotes the current global mode in
+ -- effect.
function Present_Then_Remove
(List : Elist_Id;
@@ -24239,10 +25027,18 @@ package body Sem_Prag is
-- remove it from List. This routine is used to strip lists In_Constits,
-- In_Out_Constits and Out_Constits of valid constituents.
+ procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id);
+ -- Same as function Present_Then_Remove, but do not report the presence
+ -- of Item in List.
+
procedure Report_Extra_Constituents;
-- Emit an error for each constituent found in lists In_Constits,
-- In_Out_Constits and Out_Constits.
+ procedure Report_Missing_Items;
+ -- Emit an error for each global item not repeated found in list
+ -- Repeat_Items.
+
-------------------------
-- Check_In_Out_States --
-------------------------
@@ -24251,79 +25047,104 @@ package body Sem_Prag is
procedure Check_Constituent_Usage (State_Id : Entity_Id);
-- Determine whether one of the following coverage scenarios is in
-- effect:
- -- 1) there is at least one constituent of mode In_Out
- -- 2) there is at least one Input and one Output constituent
- -- 3) not all constituents are present and one of them is of mode
- -- Output.
- -- If this is not the case, emit an error.
+ -- 1) there is at least one constituent of mode In_Out or Output
+ -- 2) there is at least one pair of constituents with modes Input
+ -- and Output, or Proof_In and Output.
+ -- 3) there is at least one constituent of mode Output and not all
+ -- constituents are present.
+ -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
-----------------------------
-- Check_Constituent_Usage --
-----------------------------
procedure Check_Constituent_Usage (State_Id : Entity_Id) is
- Constit_Elmt : Elmt_Id;
- Constit_Id : Entity_Id;
- Has_Missing : Boolean := False;
- In_Out_Seen : Boolean := False;
- In_Seen : Boolean := False;
- Out_Seen : Boolean := False;
+ Constits : constant Elist_Id :=
+ Partial_Refinement_Constituents (State_Id);
+ Constit_Elmt : Elmt_Id;
+ Constit_Id : Entity_Id;
+ Has_Missing : Boolean := False;
+ In_Out_Seen : Boolean := False;
+ Input_Seen : Boolean := False;
+ Output_Seen : Boolean := False;
+ Proof_In_Seen : Boolean := False;
begin
-- Process all the constituents of the state and note their modes
-- within the global refinement.
- Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id));
- while Present (Constit_Elmt) loop
- Constit_Id := Node (Constit_Elmt);
-
- if Present_Then_Remove (In_Constits, Constit_Id) then
- In_Seen := True;
+ if Present (Constits) then
+ Constit_Elmt := First_Elmt (Constits);
+ while Present (Constit_Elmt) loop
+ Constit_Id := Node (Constit_Elmt);
- elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then
- In_Out_Seen := True;
+ if Present_Then_Remove (In_Constits, Constit_Id) then
+ Input_Seen := True;
- elsif Present_Then_Remove (Out_Constits, Constit_Id) then
- Out_Seen := True;
+ elsif Present_Then_Remove (In_Out_Constits, Constit_Id) then
+ In_Out_Seen := True;
- -- A Proof_In constituent cannot participate in the completion
- -- of an Output state (SPARK RM 7.2.4(5)).
+ elsif Present_Then_Remove (Out_Constits, Constit_Id) then
+ Output_Seen := True;
- elsif Present_Then_Remove (Proof_In_Constits, Constit_Id) then
- Error_Msg_Name_1 := Chars (State_Id);
- SPARK_Msg_NE
- ("constituent & of state % must have mode Input, In_Out "
- & "or Output in global refinement", N, Constit_Id);
+ elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
+ then
+ Proof_In_Seen := True;
- else
- Has_Missing := True;
- end if;
+ else
+ Has_Missing := True;
+ end if;
- Next_Elmt (Constit_Elmt);
- end loop;
+ Next_Elmt (Constit_Elmt);
+ end loop;
+ end if;
- -- A single In_Out constituent is a valid completion
+ -- An In_Out constituent is a valid completion
if In_Out_Seen then
null;
- -- A pair of one Input and one Output constituent is a valid
- -- completion.
+ -- A pair of one Input/Proof_In and one Output constituent is a
+ -- valid completion.
- elsif In_Seen and Out_Seen then
+ elsif (Input_Seen or Proof_In_Seen) and Output_Seen then
null;
- -- A single Output constituent is a valid completion only when
- -- some of the other constituents are missing (SPARK RM 7.2.4(5)).
+ elsif Output_Seen then
- elsif Out_Seen and Has_Missing then
- null;
+ -- A single Output constituent is a valid completion only when
+ -- some of the other constituents are missing.
- -- The state lacks a completion
+ if Has_Missing then
+ null;
- elsif not In_Seen and not In_Out_Seen and not Out_Seen then
- SPARK_Msg_NE
- ("missing global refinement of state &", N, State_Id);
+ -- Otherwise all constituents are of mode Output
+
+ else
+ SPARK_Msg_NE
+ ("global refinement of state & must include at least one "
+ & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
+ N, State_Id);
+ end if;
+
+ -- The state lacks a completion. When full refinement is visible,
+ -- always emit an error (SPARK RM 7.2.4(3a)). When only partial
+ -- refinement is visible, emit an error if the abstract state
+ -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where
+ -- both are utilized, Check_State_And_Constituent_Use. will issue
+ -- the error.
+
+ elsif not Input_Seen
+ and then not In_Out_Seen
+ and then not Output_Seen
+ and then not Proof_In_Seen
+ then
+ if Has_Visible_Refinement (State_Id)
+ or else Contains (Repeat_Items, State_Id)
+ then
+ SPARK_Msg_NE
+ ("missing global refinement of state &", N, State_Id);
+ end if;
-- Otherwise the state has a malformed completion where at least
-- one of the constituents has a different mode.
@@ -24377,51 +25198,70 @@ package body Sem_Prag is
procedure Check_Input_States is
procedure Check_Constituent_Usage (State_Id : Entity_Id);
-- Determine whether at least one constituent of state State_Id with
- -- visible refinement is used and has mode Input. Ensure that the
- -- remaining constituents do not have In_Out, Output or Proof_In
- -- modes.
+ -- full or partial visible refinement is used and has mode Input.
+ -- Ensure that the remaining constituents do not have In_Out or
+ -- Output modes. Emit an error if this is not the case
+ -- (SPARK RM 7.2.4(5)).
-----------------------------
-- Check_Constituent_Usage --
-----------------------------
procedure Check_Constituent_Usage (State_Id : Entity_Id) is
+ Constits : constant Elist_Id :=
+ Partial_Refinement_Constituents (State_Id);
Constit_Elmt : Elmt_Id;
Constit_Id : Entity_Id;
In_Seen : Boolean := False;
begin
- Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id));
- while Present (Constit_Elmt) loop
- Constit_Id := Node (Constit_Elmt);
+ if Present (Constits) then
+ Constit_Elmt := First_Elmt (Constits);
+ while Present (Constit_Elmt) loop
+ Constit_Id := Node (Constit_Elmt);
- -- At least one of the constituents appears as an Input
+ -- At least one of the constituents appears as an Input
- if Present_Then_Remove (In_Constits, Constit_Id) then
- In_Seen := True;
+ if Present_Then_Remove (In_Constits, Constit_Id) then
+ In_Seen := True;
- -- The constituent appears in the global refinement, but has
- -- mode In_Out, Output or Proof_In (SPARK RM 7.2.4(5)).
+ -- A Proof_In constituent can refine an Input state as long
+ -- as there is at least one Input constituent present.
- elsif Present_Then_Remove (In_Out_Constits, Constit_Id)
- or else Present_Then_Remove (Out_Constits, Constit_Id)
- or else Present_Then_Remove (Proof_In_Constits, Constit_Id)
- then
- Error_Msg_Name_1 := Chars (State_Id);
- SPARK_Msg_NE
- ("constituent & of state % must have mode Input in global "
- & "refinement", N, Constit_Id);
- end if;
+ elsif Present_Then_Remove (Proof_In_Constits, Constit_Id)
+ then
+ null;
- Next_Elmt (Constit_Elmt);
- end loop;
+ -- The constituent appears in the global refinement, but has
+ -- mode In_Out or Output (SPARK RM 7.2.4(5)).
- -- Not one of the constituents appeared as Input
+ elsif Present_Then_Remove (In_Out_Constits, Constit_Id)
+ or else Present_Then_Remove (Out_Constits, Constit_Id)
+ then
+ Error_Msg_Name_1 := Chars (State_Id);
+ SPARK_Msg_NE
+ ("constituent & of state % must have mode `Input` in "
+ & "global refinement", N, Constit_Id);
+ end if;
- if not In_Seen then
+ Next_Elmt (Constit_Elmt);
+ end loop;
+ end if;
+
+ -- Not one of the constituents appeared as Input. Always emit an
+ -- error when the full refinement is visible (SPARK RM 7.2.4(3a)).
+ -- When only partial refinement is visible, emit an error if the
+ -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
+ -- the case where both are utilized, an error will be issued in
+ -- Check_State_And_Constituent_Use.
+
+ if not In_Seen
+ and then (Has_Visible_Refinement (State_Id)
+ or else Contains (Repeat_Items, State_Id))
+ then
SPARK_Msg_NE
("global refinement of state & must include at least one "
- & "constituent of mode Input", N, State_Id);
+ & "constituent of mode `Input`", N, State_Id);
end if;
end Check_Constituent_Usage;
@@ -24447,8 +25287,11 @@ package body Sem_Prag is
while Present (Item_Elmt) loop
Item_Id := Node (Item_Elmt);
- -- Ensure that at least one of the constituents is utilized and
- -- is of mode Input.
+ -- When full refinement is visible, ensure that at least one of
+ -- the constituents is utilized and is of mode Input. When only
+ -- partial refinement is visible, ensure that either one of
+ -- the constituents is utilized and is of mode Input, or the
+ -- abstract state is repeated and no constituent is utilized.
if Ekind (Item_Id) = E_Abstract_State
and then Has_Non_Null_Visible_Refinement (Item_Id)
@@ -24467,56 +25310,82 @@ package body Sem_Prag is
procedure Check_Output_States is
procedure Check_Constituent_Usage (State_Id : Entity_Id);
- -- Determine whether all constituents of state State_Id with visible
- -- refinement are used and have mode Output. Emit an error if this is
- -- not the case.
+ -- Determine whether all constituents of state State_Id with full
+ -- visible refinement are used and have mode Output. Emit an error
+ -- if this is not the case (SPARK RM 7.2.4(5)).
-----------------------------
-- Check_Constituent_Usage --
-----------------------------
procedure Check_Constituent_Usage (State_Id : Entity_Id) is
+ Constits : constant Elist_Id :=
+ Partial_Refinement_Constituents (State_Id);
+ Only_Partial : constant Boolean :=
+ not Has_Visible_Refinement (State_Id);
Constit_Elmt : Elmt_Id;
Constit_Id : Entity_Id;
Posted : Boolean := False;
begin
- Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id));
- while Present (Constit_Elmt) loop
- Constit_Id := Node (Constit_Elmt);
+ if Present (Constits) then
+ Constit_Elmt := First_Elmt (Constits);
+ while Present (Constit_Elmt) loop
+ Constit_Id := Node (Constit_Elmt);
- if Present_Then_Remove (Out_Constits, Constit_Id) then
- null;
+ -- Issue an error when a constituent of State_Id is utilized
+ -- and State_Id has only partial visible refinement
+ -- (SPARK RM 7.2.4(3d)).
- -- The constituent appears in the global refinement, but has
- -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
+ if Only_Partial then
+ if Present_Then_Remove (Out_Constits, Constit_Id)
+ or else Present_Then_Remove (In_Constits, Constit_Id)
+ or else
+ Present_Then_Remove (In_Out_Constits, Constit_Id)
+ or else
+ Present_Then_Remove (Proof_In_Constits, Constit_Id)
+ then
+ Error_Msg_Name_1 := Chars (State_Id);
+ SPARK_Msg_NE
+ ("constituent & of state % cannot be used in global "
+ & "refinement", N, Constit_Id);
+ Error_Msg_Name_1 := Chars (State_Id);
+ SPARK_Msg_N ("\use state % instead", N);
+ end if;
- elsif Present_Then_Remove (In_Constits, Constit_Id)
- or else Present_Then_Remove (In_Out_Constits, Constit_Id)
- or else Present_Then_Remove (Proof_In_Constits, Constit_Id)
- then
- Error_Msg_Name_1 := Chars (State_Id);
- SPARK_Msg_NE
- ("constituent & of state % must have mode Output in "
- & "global refinement", N, Constit_Id);
+ elsif Present_Then_Remove (Out_Constits, Constit_Id) then
+ null;
- -- The constituent is altogether missing (SPARK RM 7.2.5(3))
+ -- The constituent appears in the global refinement, but has
+ -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
- else
- if not Posted then
- Posted := True;
+ elsif Present_Then_Remove (In_Constits, Constit_Id)
+ or else Present_Then_Remove (In_Out_Constits, Constit_Id)
+ or else Present_Then_Remove (Proof_In_Constits, Constit_Id)
+ then
+ Error_Msg_Name_1 := Chars (State_Id);
SPARK_Msg_NE
- ("output state & must be replaced by all its "
- & "constituents in global refinement", N, State_Id);
- end if;
+ ("constituent & of state % must have mode `Output` in "
+ & "global refinement", N, Constit_Id);
- SPARK_Msg_NE
- ("\constituent & is missing in output list",
- N, Constit_Id);
- end if;
+ -- The constituent is altogether missing (SPARK RM 7.2.5(3))
- Next_Elmt (Constit_Elmt);
- end loop;
+ else
+ if not Posted then
+ Posted := True;
+ SPARK_Msg_NE
+ ("`Output` state & must be replaced by all its "
+ & "constituents in global refinement", N, State_Id);
+ end if;
+
+ SPARK_Msg_NE
+ ("\constituent & is missing in output list",
+ N, Constit_Id);
+ end if;
+
+ Next_Elmt (Constit_Elmt);
+ end loop;
+ end if;
end Check_Constituent_Usage;
-- Local variables
@@ -24541,8 +25410,10 @@ package body Sem_Prag is
while Present (Item_Elmt) loop
Item_Id := Node (Item_Elmt);
- -- Ensure that all of the constituents are utilized and they
- -- have mode Output.
+ -- When full refinement is visible, ensure that all of the
+ -- constituents are utilized and they have mode Output. When
+ -- only partial refinement is visible, ensure that no
+ -- constituent is utilized.
if Ekind (Item_Id) = E_Abstract_State
and then Has_Non_Null_Visible_Refinement (Item_Id)
@@ -24562,50 +25433,64 @@ package body Sem_Prag is
procedure Check_Proof_In_States is
procedure Check_Constituent_Usage (State_Id : Entity_Id);
-- Determine whether at least one constituent of state State_Id with
- -- visible refinement is used and has mode Proof_In. Ensure that the
- -- remaining constituents do not have Input, In_Out or Output modes.
+ -- full or partial visible refinement is used and has mode Proof_In.
+ -- Ensure that the remaining constituents do not have Input, In_Out,
+ -- or Output modes. Emit an error if this is not the case
+ -- (SPARK RM 7.2.4(5)).
-----------------------------
-- Check_Constituent_Usage --
-----------------------------
procedure Check_Constituent_Usage (State_Id : Entity_Id) is
+ Constits : constant Elist_Id :=
+ Partial_Refinement_Constituents (State_Id);
Constit_Elmt : Elmt_Id;
Constit_Id : Entity_Id;
Proof_In_Seen : Boolean := False;
begin
- Constit_Elmt := First_Elmt (Refinement_Constituents (State_Id));
- while Present (Constit_Elmt) loop
- Constit_Id := Node (Constit_Elmt);
+ if Present (Constits) then
+ Constit_Elmt := First_Elmt (Constits);
+ while Present (Constit_Elmt) loop
+ Constit_Id := Node (Constit_Elmt);
- -- At least one of the constituents appears as Proof_In
+ -- At least one of the constituents appears as Proof_In
- if Present_Then_Remove (Proof_In_Constits, Constit_Id) then
- Proof_In_Seen := True;
+ if Present_Then_Remove (Proof_In_Constits, Constit_Id) then
+ Proof_In_Seen := True;
- -- The constituent appears in the global refinement, but has
- -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
+ -- The constituent appears in the global refinement, but has
+ -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
- elsif Present_Then_Remove (In_Constits, Constit_Id)
- or else Present_Then_Remove (In_Out_Constits, Constit_Id)
- or else Present_Then_Remove (Out_Constits, Constit_Id)
- then
- Error_Msg_Name_1 := Chars (State_Id);
- SPARK_Msg_NE
- ("constituent & of state % must have mode Proof_In in "
- & "global refinement", N, Constit_Id);
- end if;
+ elsif Present_Then_Remove (In_Constits, Constit_Id)
+ or else Present_Then_Remove (In_Out_Constits, Constit_Id)
+ or else Present_Then_Remove (Out_Constits, Constit_Id)
+ then
+ Error_Msg_Name_1 := Chars (State_Id);
+ SPARK_Msg_NE
+ ("constituent & of state % must have mode `Proof_In` "
+ & "in global refinement", N, Constit_Id);
+ end if;
- Next_Elmt (Constit_Elmt);
- end loop;
+ Next_Elmt (Constit_Elmt);
+ end loop;
+ end if;
- -- Not one of the constituents appeared as Proof_In
+ -- Not one of the constituents appeared as Proof_In. Always emit
+ -- an error when full refinement is visible (SPARK RM 7.2.4(3a)).
+ -- When only partial refinement is visible, emit an error if the
+ -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
+ -- the case where both are utilized, an error will be issued by
+ -- Check_State_And_Constituent_Use.
- if not Proof_In_Seen then
+ if not Proof_In_Seen
+ and then (Has_Visible_Refinement (State_Id)
+ or else Contains (Repeat_Items, State_Id))
+ then
SPARK_Msg_NE
("global refinement of state & must include at least one "
- & "constituent of mode Proof_In", N, State_Id);
+ & "constituent of mode `Proof_In`", N, State_Id);
end if;
end Check_Constituent_Usage;
@@ -24631,8 +25516,11 @@ package body Sem_Prag is
while Present (Item_Elmt) loop
Item_Id := Node (Item_Elmt);
- -- Ensure that at least one of the constituents is utilized and
- -- is of mode Proof_In
+ -- Ensure that at least one of the constituents is utilized
+ -- and is of mode Proof_In. When only partial refinement is
+ -- visible, ensure that either one of the constituents is
+ -- utilized and is of mode Proof_In, or the abstract state
+ -- is repeated and no constituent is utilized.
if Ekind (Item_Id) = E_Abstract_State
and then Has_Non_Null_Visible_Refinement (Item_Id)
@@ -24687,20 +25575,40 @@ package body Sem_Prag is
SPARK_Msg_N ("\expected mode %, found mode %", Item);
end Inconsistent_Mode_Error;
+ -- Local variables
+
+ Enc_State : Entity_Id := Empty;
+ -- Encapsulating state for constituent, Empty otherwise
+
-- Start of processing for Check_Refined_Global_Item
begin
+ if Ekind_In (Item_Id, E_Abstract_State,
+ E_Constant,
+ E_Variable)
+ then
+ Enc_State := Find_Encapsulating_State (States, Item_Id);
+ end if;
+
-- When the state or object acts as a constituent of another
-- state with a visible refinement, collect it for the state
-- completeness checks performed later on. Note that the item
-- acts as a constituent only when the encapsulating state is
-- present in pragma Global.
- if Ekind_In (Item_Id, E_Abstract_State, E_Constant, E_Variable)
- and then Present (Encapsulating_State (Item_Id))
- and then Has_Visible_Refinement (Encapsulating_State (Item_Id))
- and then Contains (States, Encapsulating_State (Item_Id))
+ if Present (Enc_State)
+ and then (Has_Visible_Refinement (Enc_State)
+ or else Has_Partial_Visible_Refinement (Enc_State))
+ and then Contains (States, Enc_State)
then
+ -- If the state has only partial visible refinement, remove it
+ -- from the list of items that should be repeated from pragma
+ -- Global.
+
+ if not Has_Visible_Refinement (Enc_State) then
+ Present_Then_Remove (Repeat_Items, Enc_State);
+ end if;
+
if Global_Mode = Name_Input then
Append_New_Elmt (Item_Id, In_Constits);
@@ -24715,31 +25623,37 @@ package body Sem_Prag is
end if;
-- When not a constituent, ensure that both occurrences of the
- -- item in pragmas Global and Refined_Global match.
+ -- item in pragmas Global and Refined_Global match. Also remove
+ -- it when present from the list of items that should be repeated
+ -- from pragma Global.
- elsif Contains (In_Items, Item_Id) then
- if Global_Mode /= Name_Input then
- Inconsistent_Mode_Error (Name_Input);
- end if;
+ else
+ Present_Then_Remove (Repeat_Items, Item_Id);
- elsif Contains (In_Out_Items, Item_Id) then
- if Global_Mode /= Name_In_Out then
- Inconsistent_Mode_Error (Name_In_Out);
- end if;
+ if Contains (In_Items, Item_Id) then
+ if Global_Mode /= Name_Input then
+ Inconsistent_Mode_Error (Name_Input);
+ end if;
- elsif Contains (Out_Items, Item_Id) then
- if Global_Mode /= Name_Output then
- Inconsistent_Mode_Error (Name_Output);
- end if;
+ elsif Contains (In_Out_Items, Item_Id) then
+ if Global_Mode /= Name_In_Out then
+ Inconsistent_Mode_Error (Name_In_Out);
+ end if;
- elsif Contains (Proof_In_Items, Item_Id) then
- null;
+ elsif Contains (Out_Items, Item_Id) then
+ if Global_Mode /= Name_Output then
+ Inconsistent_Mode_Error (Name_Output);
+ end if;
- -- The item does not appear in the corresponding Global pragma,
- -- it must be an extra (SPARK RM 7.2.4(3)).
+ elsif Contains (Proof_In_Items, Item_Id) then
+ null;
- else
- SPARK_Msg_NE ("extra global item &", Item, Item_Id);
+ -- The item does not appear in the corresponding Global pragma,
+ -- it must be an extra (SPARK RM 7.2.4(3)).
+
+ else
+ SPARK_Msg_NE ("extra global item &", Item, Item_Id);
+ end if;
end if;
end Check_Refined_Global_Item;
@@ -24858,6 +25772,16 @@ package body Sem_Prag is
end if;
end if;
+ -- Record global items without full visible refinement found in
+ -- pragma Global which should be repeated in the global refinement
+ -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)).
+
+ if Ekind (Item_Id) /= E_Abstract_State
+ or else not Has_Visible_Refinement (Item_Id)
+ then
+ Append_New_Elmt (Item_Id, Repeat_Items);
+ end if;
+
-- Add the item to the proper list
if Item_Mode = Name_Input then
@@ -24957,6 +25881,12 @@ package body Sem_Prag is
return False;
end Present_Then_Remove;
+ procedure Present_Then_Remove (List : Elist_Id; Item : Entity_Id) is
+ Ignore : Boolean;
+ begin
+ Ignore := Present_Then_Remove (List, Item);
+ end Present_Then_Remove;
+
-------------------------------
-- Report_Extra_Constituents --
-------------------------------
@@ -24999,11 +25929,39 @@ package body Sem_Prag is
end if;
end Report_Extra_Constituents;
+ --------------------------
+ -- Report_Missing_Items --
+ --------------------------
+
+ procedure Report_Missing_Items is
+ Item_Elmt : Elmt_Id;
+ Item_Id : Entity_Id;
+
+ begin
+ -- Do not perform this check in an instance because it was already
+ -- performed successfully in the generic template.
+
+ if Is_Generic_Instance (Spec_Id) then
+ null;
+
+ else
+ if Present (Repeat_Items) then
+ Item_Elmt := First_Elmt (Repeat_Items);
+ while Present (Item_Elmt) loop
+ Item_Id := Node (Item_Elmt);
+ SPARK_Msg_NE ("missing global item &", N, Item_Id);
+ Next_Elmt (Item_Elmt);
+ end loop;
+ end if;
+ end if;
+ end Report_Missing_Items;
+
-- Local variables
- Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
- Errors : constant Nat := Serious_Errors_Detected;
- Items : Node_Id;
+ Body_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
+ Errors : constant Nat := Serious_Errors_Detected;
+ Items : Node_Id;
+ No_Constit : Boolean;
-- Start of processing for Analyze_Refined_Global_In_Decl_Part
@@ -25053,10 +26011,10 @@ package body Sem_Prag is
-- Non-instance case
else
- -- The corresponding Global pragma must mention at least one state
- -- witha visible refinement at the point Refined_Global is processed.
- -- States with null refinements need Refined_Global pragma
- -- (SPARK RM 7.2.4(2)).
+ -- The corresponding Global pragma must mention at least one
+ -- state with a visible refinement at the point Refined_Global
+ -- is processed. States with null refinements need Refined_Global
+ -- pragma (SPARK RM 7.2.4(2)).
if not Has_In_State
and then not Has_In_Out_State
@@ -25102,6 +26060,16 @@ package body Sem_Prag is
Check_Refined_Global_List (Items);
end if;
+ -- Store the information that no constituent is used in the global
+ -- refinement, prior to calling checking procedures which remove items
+ -- from the list of constituents.
+
+ No_Constit :=
+ No (In_Constits)
+ and then No (In_Out_Constits)
+ and then No (Out_Constits)
+ and then No (Proof_In_Constits);
+
-- For Input states with visible refinement, at least one constituent
-- must be used as an Input in the global refinement.
@@ -25137,6 +26105,29 @@ package body Sem_Prag is
Report_Extra_Constituents;
end if;
+ -- Emit errors for all items in Global that are not repeated in the
+ -- global refinement and for which there is no full visible refinement
+ -- and, in the case of states with partial visible refinement, no
+ -- constituent is mentioned in the global refinement.
+
+ if Serious_Errors_Detected = Errors then
+ Report_Missing_Items;
+ end if;
+
+ -- Emit an error if no constituent is used in the global refinement
+ -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise
+ -- one may be issued by the checking procedures. Do not perform this
+ -- check in an instance because it was already performed successfully
+ -- in the generic template.
+
+ if Serious_Errors_Detected = Errors
+ and then not Is_Generic_Instance (Spec_Id)
+ and then not Has_Null_State
+ and then No_Constit
+ then
+ SPARK_Msg_N ("missing refinement", N);
+ end if;
+
<<Leave>>
Set_Is_Analyzed_Pragma (N);
end Analyze_Refined_Global_In_Decl_Part;
@@ -25218,9 +26209,10 @@ package body Sem_Prag is
Enabled : Boolean;
Constit : Entity_Id);
-- Determine whether a property denoted by name Prop_Nam is present
- -- in both the refined state and constituent Constit. Flag Enabled
- -- should be set when the property applies to the refined state. If
- -- this is not the case, emit an error message.
+ -- in the refined state. Emit an error if this is not the case. Flag
+ -- Enabled should be set when the property applies to the refined
+ -- state. Constit denotes the constituent (if any) which introduces
+ -- the property in the refinement.
procedure Match_State;
-- Determine whether the state being refined appears in list
@@ -25257,52 +26249,14 @@ package body Sem_Prag is
-------------------------
procedure Collect_Constituent is
- begin
- if Is_Ghost_Entity (State_Id) then
- if Is_Ghost_Entity (Constit_Id) then
-
- -- The Ghost policy in effect at the point of abstract
- -- state declaration and constituent must match
- -- (SPARK RM 6.9(16)).
-
- if Is_Checked_Ghost_Entity (State_Id)
- and then Is_Ignored_Ghost_Entity (Constit_Id)
- then
- Error_Msg_Sloc := Sloc (Constit);
-
- SPARK_Msg_N
- ("incompatible ghost policies in effect", State);
- SPARK_Msg_NE
- ("\abstract state & declared with ghost policy "
- & "Check", State, State_Id);
- SPARK_Msg_NE
- ("\constituent & declared # with ghost policy "
- & "Ignore", State, Constit_Id);
-
- elsif Is_Ignored_Ghost_Entity (State_Id)
- and then Is_Checked_Ghost_Entity (Constit_Id)
- then
- Error_Msg_Sloc := Sloc (Constit);
-
- SPARK_Msg_N
- ("incompatible ghost policies in effect", State);
- SPARK_Msg_NE
- ("\abstract state & declared with ghost policy "
- & "Ignore", State, State_Id);
- SPARK_Msg_NE
- ("\constituent & declared # with ghost policy "
- & "Check", State, Constit_Id);
- end if;
+ Constits : Elist_Id;
- -- A constituent of a Ghost abstract state must be a
- -- Ghost entity (SPARK RM 7.2.2(12)).
+ begin
+ -- The Ghost policy in effect at the point of abstract state
+ -- declaration and constituent must match (SPARK RM 6.9(15))
- else
- SPARK_Msg_NE
- ("constituent of ghost state & must be ghost",
- Constit, State_Id);
- end if;
- end if;
+ Check_Ghost_Refinement
+ (State, State_Id, Constit, Constit_Id);
-- A synchronized state must be refined by a synchronized
-- object or another synchronized state (SPARK RM 9.6).
@@ -25325,7 +26279,14 @@ package body Sem_Prag is
-- and establish a relation between the refined state and
-- the item.
- Append_Elmt (Constit_Id, Refinement_Constituents (State_Id));
+ Constits := Refinement_Constituents (State_Id);
+
+ if No (Constits) then
+ Constits := New_Elmt_List;
+ Set_Refinement_Constituents (State_Id, Constits);
+ end if;
+
+ Append_Elmt (Constit_Id, Constits);
Set_Encapsulating_State (Constit_Id, State_Id);
-- The state has at least one legal constituent, mark the
@@ -25421,7 +26382,7 @@ package body Sem_Prag is
-- a visible state or lacks a Part_Of indicator.
if Ekind (Constit_Id) = E_Constant then
- null;
+ Collect_Constituent;
-- If we get here, then the constituent is not a hidden
-- state of the related package and may not be used in a
@@ -25439,6 +26400,7 @@ package body Sem_Prag is
-- Local variables
Constit_Id : Entity_Id;
+ Constits : Elist_Id;
-- Start of processing for Analyze_Constituent
@@ -25460,7 +26422,14 @@ package body Sem_Prag is
-- Collect the constituent in the list of refinement items
- Append_Elmt (Constit, Refinement_Constituents (State_Id));
+ Constits := Refinement_Constituents (State_Id);
+
+ if No (Constits) then
+ Constits := New_Elmt_List;
+ Set_Refinement_Constituents (State_Id, Constits);
+ end if;
+
+ Append_Elmt (Constit, Constits);
-- The state has at least one legal constituent, mark the
-- start of the refinement region. The region ends when the
@@ -25581,27 +26550,21 @@ package body Sem_Prag is
Constit : Entity_Id)
is
begin
- Error_Msg_Name_1 := Prop_Nam;
-
- -- The property is enabled in the related Abstract_State pragma
- -- that defines the state (SPARK RM 7.2.8(3)).
-
- if Enabled then
- if No (Constit) then
- SPARK_Msg_NE
- ("external state & requires at least one constituent with "
- & "property %", State, State_Id);
- end if;
-
-- The property is missing in the declaration of the state, but
-- a constituent is introducing it in the state refinement
- -- (SPARK RM 7.2.8(3)).
+ -- (SPARK RM 7.2.8(2)).
- elsif Present (Constit) then
- Error_Msg_Name_2 := Chars (Constit);
+ if not Enabled and then Present (Constit) then
+ Error_Msg_Name_1 := Prop_Nam;
+ Error_Msg_Name_2 := Chars (State_Id);
SPARK_Msg_NE
- ("external state & lacks property % set by constituent %",
- State, State_Id);
+ ("constituent & introduces external property % in refinement "
+ & "of state %", State, Constit);
+
+ Error_Msg_Sloc := Sloc (State_Id);
+ SPARK_Msg_N
+ ("\property is missing in abstract state declaration #",
+ State);
end if;
end Check_External_Property;
@@ -25816,49 +26779,29 @@ package body Sem_Prag is
Analyze_Constituent (Constit);
end if;
- -- A refined external state is subject to special rules with respect
- -- to its properties and constituents.
+ -- Verify that external constituents do not introduce new external
+ -- property in the state refinement (SPARK RM 7.2.8(2)).
if Is_External_State (State_Id) then
-
- -- The set of properties that all external constituents yield must
- -- match that of the refined state. There are two cases to detect:
- -- the refined state lacks a property or has an extra property.
-
- if External_Constit_Seen then
- Check_External_Property
- (Prop_Nam => Name_Async_Readers,
- Enabled => Async_Readers_Enabled (State_Id),
- Constit => AR_Constit);
-
- Check_External_Property
- (Prop_Nam => Name_Async_Writers,
- Enabled => Async_Writers_Enabled (State_Id),
- Constit => AW_Constit);
-
- Check_External_Property
- (Prop_Nam => Name_Effective_Reads,
- Enabled => Effective_Reads_Enabled (State_Id),
- Constit => ER_Constit);
-
- Check_External_Property
- (Prop_Nam => Name_Effective_Writes,
- Enabled => Effective_Writes_Enabled (State_Id),
- Constit => EW_Constit);
-
- -- An external state may be refined to null (SPARK RM 7.2.8(2))
-
- elsif Null_Seen then
- null;
-
- -- The external state has constituents, but none of them are
- -- external (SPARK RM 7.2.8(2)).
-
- else
- SPARK_Msg_NE
- ("external state & requires at least one external "
- & "constituent or null refinement", State, State_Id);
- end if;
+ Check_External_Property
+ (Prop_Nam => Name_Async_Readers,
+ Enabled => Async_Readers_Enabled (State_Id),
+ Constit => AR_Constit);
+
+ Check_External_Property
+ (Prop_Nam => Name_Async_Writers,
+ Enabled => Async_Writers_Enabled (State_Id),
+ Constit => AW_Constit);
+
+ Check_External_Property
+ (Prop_Nam => Name_Effective_Reads,
+ Enabled => Effective_Reads_Enabled (State_Id),
+ Constit => ER_Constit);
+
+ Check_External_Property
+ (Prop_Nam => Name_Effective_Writes,
+ Enabled => Effective_Writes_Enabled (State_Id),
+ Constit => EW_Constit);
-- When a refined state is not external, it should not have external
-- constituents (SPARK RM 7.2.8(1)).
@@ -26064,6 +27007,157 @@ package body Sem_Prag is
return False;
end Appears_In;
+ -----------------------------------
+ -- Build_Pragma_Check_Equivalent --
+ -----------------------------------
+
+ function Build_Pragma_Check_Equivalent
+ (Prag : Node_Id;
+ Subp_Id : Entity_Id := Empty;
+ Inher_Id : Entity_Id := Empty;
+ Keep_Pragma_Id : Boolean := False) return Node_Id
+ is
+ function Suppress_Reference (N : Node_Id) return Traverse_Result;
+ -- Detect whether node N references a formal parameter subject to
+ -- pragma Unreferenced. If this is the case, set Comes_From_Source
+ -- to False to suppress the generation of a reference when analyzing
+ -- N later on.
+
+ ------------------------
+ -- Suppress_Reference --
+ ------------------------
+
+ function Suppress_Reference (N : Node_Id) return Traverse_Result is
+ Formal : Entity_Id;
+
+ begin
+ if Is_Entity_Name (N) and then Present (Entity (N)) then
+ Formal := Entity (N);
+
+ -- The formal parameter is subject to pragma Unreferenced. Prevent
+ -- the generation of references by resetting the Comes_From_Source
+ -- flag.
+
+ if Is_Formal (Formal)
+ and then Has_Pragma_Unreferenced (Formal)
+ then
+ Set_Comes_From_Source (N, False);
+ end if;
+ end if;
+
+ return OK;
+ end Suppress_Reference;
+
+ procedure Suppress_References is
+ new Traverse_Proc (Suppress_Reference);
+
+ -- Local variables
+
+ Loc : constant Source_Ptr := Sloc (Prag);
+ Prag_Nam : constant Name_Id := Pragma_Name (Prag);
+ Check_Prag : Node_Id;
+ Msg_Arg : Node_Id;
+ Nam : Name_Id;
+
+ -- Start of processing for Build_Pragma_Check_Equivalent
+
+ begin
+ -- When the pre- or postcondition is inherited, map the formals of the
+ -- inherited subprogram to those of the current subprogram. In addition,
+ -- map primitive operations of the parent type into the corresponding
+ -- primitive operations of the descendant.
+
+ if Present (Inher_Id) then
+ pragma Assert (Present (Subp_Id));
+
+ Update_Primitives_Mapping (Inher_Id, Subp_Id);
+
+ -- Use generic machinery to copy inherited pragma, as if it were an
+ -- instantiation, resetting source locations appropriately, so that
+ -- expressions inside the inherited pragma use chained locations.
+ -- This is used in particular in GNATprove to locate precisely
+ -- messages on a given inherited pragma.
+
+ Set_Copied_Sloc_For_Inherited_Pragma
+ (Unit_Declaration_Node (Subp_Id), Inher_Id);
+ Check_Prag := New_Copy_Tree (Source => Prag);
+
+ -- Build the inherited class-wide condition
+
+ Build_Class_Wide_Expression
+ (Check_Prag, Subp_Id, Inher_Id, Adjust_Sloc => True);
+
+ -- If not an inherited condition simply copy the original pragma
+
+ else
+ Check_Prag := New_Copy_Tree (Source => Prag);
+ end if;
+
+ -- Mark the pragma as being internally generated and reset the Analyzed
+ -- flag.
+
+ Set_Analyzed (Check_Prag, False);
+ Set_Comes_From_Source (Check_Prag, False);
+
+ -- The tree of the original pragma may contain references to the
+ -- formal parameters of the related subprogram. At the same time
+ -- the corresponding body may mark the formals as unreferenced:
+
+ -- procedure Proc (Formal : ...)
+ -- with Pre => Formal ...;
+
+ -- procedure Proc (Formal : ...) is
+ -- pragma Unreferenced (Formal);
+ -- ...
+
+ -- This creates problems because all pragma Check equivalents are
+ -- analyzed at the end of the body declarations. Since all source
+ -- references have already been accounted for, reset any references
+ -- to such formals in the generated pragma Check equivalent.
+
+ Suppress_References (Check_Prag);
+
+ if Present (Corresponding_Aspect (Prag)) then
+ Nam := Chars (Identifier (Corresponding_Aspect (Prag)));
+ else
+ Nam := Prag_Nam;
+ end if;
+
+ -- Unless Keep_Pragma_Id is True in order to keep the identifier of
+ -- the copied pragma in the newly created pragma, convert the copy into
+ -- pragma Check by correcting the name and adding a check_kind argument.
+
+ if not Keep_Pragma_Id then
+ Set_Class_Present (Check_Prag, False);
+
+ Set_Pragma_Identifier
+ (Check_Prag, Make_Identifier (Loc, Name_Check));
+
+ Prepend_To (Pragma_Argument_Associations (Check_Prag),
+ Make_Pragma_Argument_Association (Loc,
+ Expression => Make_Identifier (Loc, Nam)));
+ end if;
+
+ -- Update the error message when the pragma is inherited
+
+ if Present (Inher_Id) then
+ Msg_Arg := Last (Pragma_Argument_Associations (Check_Prag));
+
+ if Chars (Msg_Arg) = Name_Message then
+ String_To_Name_Buffer (Strval (Expression (Msg_Arg)));
+
+ -- Insert "inherited" to improve the error message
+
+ if Name_Buffer (1 .. 8) = "failed p" then
+ Insert_Str_In_Name_Buffer ("inherited ", 8);
+ Set_Strval (Expression (Msg_Arg), String_From_Name_Buffer);
+ end if;
+ end if;
+ end if;
+
+ return Check_Prag;
+ end Build_Pragma_Check_Equivalent;
+
-----------------------------
-- Check_Applicable_Policy --
-----------------------------
@@ -26102,11 +27196,15 @@ package body Sem_Prag is
Policy := Chars (Get_Pragma_Arg (Last (PPA)));
case Policy is
- when Name_Off | Name_Ignore =>
+ when Name_Ignore
+ | Name_Off
+ =>
Set_Is_Ignored (N, True);
Set_Is_Checked (N, False);
- when Name_On | Name_Check =>
+ when Name_Check
+ | Name_On
+ =>
Set_Is_Checked (N, True);
Set_Is_Ignored (N, False);
@@ -26222,12 +27320,19 @@ package body Sem_Prag is
Name_Loop_Variant))
then
case (Chars (Get_Pragma_Arg (Last (PPA)))) is
- when Name_On | Name_Check =>
+ when Name_Check
+ | Name_On
+ =>
return Name_Check;
- when Name_Off | Name_Ignore =>
+
+ when Name_Ignore
+ | Name_Off
+ =>
return Name_Ignore;
+
when Name_Disable =>
return Name_Disable;
+
when others =>
raise Program_Error;
end case;
@@ -26454,46 +27559,10 @@ package body Sem_Prag is
Constits : Elist_Id;
Context : Node_Id)
is
- function Find_Encapsulating_State
- (Constit_Id : Entity_Id) return Entity_Id;
- -- Given the entity of a constituent, try to find a corresponding
- -- encapsulating state that appears in the same context. The routine
- -- returns Empty is no such state is found.
-
- ------------------------------
- -- Find_Encapsulating_State --
- ------------------------------
-
- function Find_Encapsulating_State
- (Constit_Id : Entity_Id) return Entity_Id
- is
- State_Id : Entity_Id;
-
- begin
- -- Since a constituent may be part of a larger constituent set, climb
- -- the encapsulating state chain looking for a state that appears in
- -- the same context.
-
- State_Id := Encapsulating_State (Constit_Id);
- while Present (State_Id) loop
- if Contains (States, State_Id) then
- return State_Id;
- end if;
-
- State_Id := Encapsulating_State (State_Id);
- end loop;
-
- return Empty;
- end Find_Encapsulating_State;
-
- -- Local variables
-
Constit_Elmt : Elmt_Id;
Constit_Id : Entity_Id;
State_Id : Entity_Id;
- -- Start of processing for Check_State_And_Constituent_Use
-
begin
-- Nothing to do if there are no states or constituents
@@ -26512,7 +27581,7 @@ package body Sem_Prag is
-- state that appears in the same context and if this is the case,
-- emit an error (SPARK RM 7.2.6(7)).
- State_Id := Find_Encapsulating_State (Constit_Id);
+ State_Id := Find_Encapsulating_State (States, Constit_Id);
if Present (State_Id) then
Error_Msg_Name_1 := Chars (Constit_Id);
@@ -26526,6 +27595,69 @@ package body Sem_Prag is
end loop;
end Check_State_And_Constituent_Use;
+ ---------------------------------------------
+ -- Collect_Inherited_Class_Wide_Conditions --
+ ---------------------------------------------
+
+ procedure Collect_Inherited_Class_Wide_Conditions (Subp : Entity_Id) is
+ Parent_Subp : constant Entity_Id := Overridden_Operation (Subp);
+ Prags : constant Node_Id := Contract (Parent_Subp);
+ In_Spec_Expr : Boolean;
+ Installed : Boolean;
+ Prag : Node_Id;
+ New_Prag : Node_Id;
+
+ begin
+ Installed := False;
+
+ -- Iterate over the contract of the overridden subprogram to find all
+ -- inherited class-wide pre- and postconditions.
+
+ if Present (Prags) then
+ Prag := Pre_Post_Conditions (Prags);
+
+ while Present (Prag) loop
+ if Nam_In (Pragma_Name_Unmapped (Prag),
+ Name_Precondition, Name_Postcondition)
+ and then Class_Present (Prag)
+ then
+ -- The generated pragma must be analyzed in the context of
+ -- the subprogram, to make its formals visible. In addition,
+ -- we must inhibit freezing and full analysis because the
+ -- controlling type of the subprogram is not frozen yet, and
+ -- may have further primitives.
+
+ if not Installed then
+ Installed := True;
+ Push_Scope (Subp);
+ Install_Formals (Subp);
+ In_Spec_Expr := In_Spec_Expression;
+ In_Spec_Expression := True;
+ end if;
+
+ New_Prag :=
+ Build_Pragma_Check_Equivalent
+ (Prag, Subp, Parent_Subp, Keep_Pragma_Id => True);
+
+ Insert_After (Unit_Declaration_Node (Subp), New_Prag);
+ Preanalyze (New_Prag);
+
+ -- Prevent further analysis in subsequent processing of the
+ -- current list of declarations
+
+ Set_Analyzed (New_Prag);
+ end if;
+
+ Prag := Next_Pragma (Prag);
+ end loop;
+
+ if Installed then
+ In_Spec_Expression := In_Spec_Expr;
+ End_Scope;
+ end if;
+ end if;
+ end Collect_Inherited_Class_Wide_Conditions;
+
---------------------------------------
-- Collect_Subprogram_Inputs_Outputs --
---------------------------------------
@@ -26879,8 +28011,8 @@ package body Sem_Prag is
function Delay_Config_Pragma_Analyze (N : Node_Id) return Boolean is
begin
- return Nam_In (Pragma_Name (N), Name_Interrupt_State,
- Name_Priority_Specific_Dispatching);
+ return Nam_In (Pragma_Name_Unmapped (N),
+ Name_Interrupt_State, Name_Priority_Specific_Dispatching);
end Delay_Config_Pragma_Analyze;
-----------------------
@@ -26916,6 +28048,33 @@ package body Sem_Prag is
end if;
end Duplication_Error;
+ ------------------------------
+ -- Find_Encapsulating_State --
+ ------------------------------
+
+ function Find_Encapsulating_State
+ (States : Elist_Id;
+ Constit_Id : Entity_Id) return Entity_Id
+ is
+ State_Id : Entity_Id;
+
+ begin
+ -- Since a constituent may be part of a larger constituent set, climb
+ -- the encapsulating state chain looking for a state that appears in
+ -- States.
+
+ State_Id := Encapsulating_State (Constit_Id);
+ while Present (State_Id) loop
+ if Contains (States, State_Id) then
+ return State_Id;
+ end if;
+
+ State_Id := Encapsulating_State (State_Id);
+ end loop;
+
+ return Empty;
+ end Find_Encapsulating_State;
+
--------------------------
-- Find_Related_Context --
--------------------------
@@ -26933,7 +28092,9 @@ package body Sem_Prag is
-- Skip prior pragmas, but check for duplicates
if Nkind (Stmt) = N_Pragma then
- if Do_Checks and then Pragma_Name (Stmt) = Pragma_Name (Prag) then
+ if Do_Checks
+ and then Pragma_Name (Stmt) = Pragma_Name (Prag)
+ then
Duplication_Error
(Prag => Prag,
Prev => Stmt);
@@ -27293,30 +28454,45 @@ package body Sem_Prag is
end if;
end Get_SPARK_Mode_Type;
- --------------------------------
- -- Get_SPARK_Mode_From_Pragma --
- --------------------------------
+ ------------------------------------
+ -- Get_SPARK_Mode_From_Annotation --
+ ------------------------------------
- function Get_SPARK_Mode_From_Pragma (N : Node_Id) return SPARK_Mode_Type is
- Args : List_Id;
+ function Get_SPARK_Mode_From_Annotation
+ (N : Node_Id) return SPARK_Mode_Type
+ is
Mode : Node_Id;
begin
- pragma Assert (Nkind (N) = N_Pragma);
- Args := Pragma_Argument_Associations (N);
-
- -- Extract the mode from the argument list
+ if Nkind (N) = N_Aspect_Specification then
+ Mode := Expression (N);
- if Present (Args) then
+ else pragma Assert (Nkind (N) = N_Pragma);
Mode := First (Pragma_Argument_Associations (N));
- return Get_SPARK_Mode_Type (Chars (Get_Pragma_Arg (Mode)));
- -- If SPARK_Mode pragma has no argument, default is ON
+ if Present (Mode) then
+ Mode := Get_Pragma_Arg (Mode);
+ end if;
+ end if;
+
+ -- Aspect or pragma SPARK_Mode specifies an explicit mode
+
+ if Present (Mode) then
+ if Nkind (Mode) = N_Identifier then
+ return Get_SPARK_Mode_Type (Chars (Mode));
+
+ -- In case of a malformed aspect or pragma, return the default None
+
+ else
+ return None;
+ end if;
+
+ -- Otherwise the lack of an expression defaults SPARK_Mode to On
else
return On;
end if;
- end Get_SPARK_Mode_From_Pragma;
+ end Get_SPARK_Mode_From_Annotation;
---------------------------
-- Has_Extra_Parentheses --
@@ -27451,23 +28627,55 @@ package body Sem_Prag is
-- Is_CCT_Instance --
---------------------
- function Is_CCT_Instance (Ref : Node_Id) return Boolean is
- Ref_Id : constant Entity_Id := Entity (Ref);
- S : Entity_Id;
+ function Is_CCT_Instance
+ (Ref_Id : Entity_Id;
+ Context_Id : Entity_Id) return Boolean
+ is
+ S : Entity_Id;
+ Typ : Entity_Id;
begin
- -- Climb the scope chain looking for an enclosing concurrent type that
- -- matches the referenced entity.
+ -- When the reference denotes a single protected type, the context is
+ -- either a protected subprogram or its body.
- S := Current_Scope;
- while Present (S) and then S /= Standard_Standard loop
- if Ekind_In (S, E_Protected_Type, E_Task_Type) and then S = Ref_Id
- then
- return True;
+ if Is_Single_Protected_Object (Ref_Id) then
+ Typ := Scope (Context_Id);
+
+ return
+ Ekind (Typ) = E_Protected_Type
+ and then Present (Anonymous_Object (Typ))
+ and then Anonymous_Object (Typ) = Ref_Id;
+
+ -- When the reference denotes a single task type, the context is either
+ -- the same type or if inside the body, the anonymous task type.
+
+ elsif Is_Single_Task_Object (Ref_Id) then
+ if Ekind (Context_Id) = E_Task_Type then
+ return
+ Present (Anonymous_Object (Context_Id))
+ and then Anonymous_Object (Context_Id) = Ref_Id;
+ else
+ return Ref_Id = Context_Id;
end if;
- S := Scope (S);
- end loop;
+ -- Otherwise the reference denotes a protected or a task type. Climb the
+ -- scope chain looking for an enclosing concurrent type that matches the
+ -- referenced entity.
+
+ else
+ pragma Assert (Ekind_In (Ref_Id, E_Protected_Type, E_Task_Type));
+
+ S := Current_Scope;
+ while Present (S) and then S /= Standard_Standard loop
+ if Ekind_In (S, E_Protected_Type, E_Task_Type)
+ and then S = Ref_Id
+ then
+ return True;
+ end if;
+
+ S := Scope (S);
+ end loop;
+ end if;
return False;
end Is_CCT_Instance;
@@ -27659,6 +28867,7 @@ package body Sem_Prag is
Pragma_Machine_Attribute => -1,
Pragma_Main => -1,
Pragma_Main_Storage => -1,
+ Pragma_Max_Queue_Length => 0,
Pragma_Memory_Size => 0,
Pragma_No_Return => 0,
Pragma_No_Body => 0,
@@ -27709,6 +28918,7 @@ package body Sem_Prag is
Pragma_Refined_Post => -1,
Pragma_Refined_State => -1,
Pragma_Relative_Deadline => 0,
+ Pragma_Rename_Pragma => 0,
Pragma_Remote_Access_Type => -1,
Pragma_Remote_Call_Interface => -1,
Pragma_Remote_Types => -1,
@@ -27716,6 +28926,7 @@ package body Sem_Prag is
Pragma_Restriction_Warnings => 0,
Pragma_Restrictions => 0,
Pragma_Reviewable => -1,
+ Pragma_Secondary_Stack_Size => -1,
Pragma_Short_Circuit_And_Or => 0,
Pragma_Share_Generic => 0,
Pragma_Shared => 0,
@@ -27749,6 +28960,7 @@ package body Sem_Prag is
Pragma_Type_Invariant => -1,
Pragma_Type_Invariant_Class => -1,
Pragma_Unchecked_Union => 0,
+ Pragma_Unevaluated_Use_Of_Old => 0,
Pragma_Unimplemented_Unit => 0,
Pragma_Universal_Aliasing => 0,
Pragma_Universal_Data => 0,
@@ -27757,7 +28969,7 @@ package body Sem_Prag is
Pragma_Unreferenced_Objects => 0,
Pragma_Unreserve_All_Interrupts => 0,
Pragma_Unsuppress => 0,
- Pragma_Unevaluated_Use_Of_Old => 0,
+ Pragma_Unused => 0,
Pragma_Use_VADS_Size => 0,
Pragma_Validity_Checks => 0,
Pragma_Volatile => 0,
@@ -27992,36 +29204,40 @@ package body Sem_Prag is
when
-- RM defined
- Name_Assert |
- Name_Static_Predicate |
- Name_Dynamic_Predicate |
- Name_Pre |
- Name_uPre |
- Name_Post |
- Name_uPost |
- Name_Type_Invariant |
- Name_uType_Invariant |
+ Name_Assert
+ | Name_Assertion_Policy
+ | Name_Static_Predicate
+ | Name_Dynamic_Predicate
+ | Name_Pre
+ | Name_uPre
+ | Name_Post
+ | Name_uPost
+ | Name_Type_Invariant
+ | Name_uType_Invariant
-- Impl defined
- Name_Assert_And_Cut |
- Name_Assume |
- Name_Contract_Cases |
- Name_Debug |
- Name_Default_Initial_Condition |
- Name_Ghost |
- Name_Initial_Condition |
- Name_Invariant |
- Name_uInvariant |
- Name_Loop_Invariant |
- Name_Loop_Variant |
- Name_Postcondition |
- Name_Precondition |
- Name_Predicate |
- Name_Refined_Post |
- Name_Statement_Assertions => return True;
-
- when others => return False;
+ | Name_Assert_And_Cut
+ | Name_Assume
+ | Name_Contract_Cases
+ | Name_Debug
+ | Name_Default_Initial_Condition
+ | Name_Ghost
+ | Name_Initial_Condition
+ | Name_Invariant
+ | Name_uInvariant
+ | Name_Loop_Invariant
+ | Name_Loop_Variant
+ | Name_Postcondition
+ | Name_Precondition
+ | Name_Predicate
+ | Name_Refined_Post
+ | Name_Statement_Assertions
+ =>
+ return True;
+
+ when others =>
+ return False;
end case;
end Is_Valid_Assertion_Kind;
@@ -28052,6 +29268,113 @@ package body Sem_Prag is
end Process_Compilation_Unit_Pragmas;
+ -------------------------------------------
+ -- Process_Compile_Time_Warning_Or_Error --
+ -------------------------------------------
+
+ procedure Process_Compile_Time_Warning_Or_Error
+ (N : Node_Id;
+ Eloc : Source_Ptr)
+ is
+ Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N));
+ Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
+ Arg2 : constant Node_Id := Next (Arg1);
+
+ begin
+ Analyze_And_Resolve (Arg1x, Standard_Boolean);
+
+ if Compile_Time_Known_Value (Arg1x) then
+ if Is_True (Expr_Value (Arg1x)) then
+ declare
+ Cent : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
+ Pname : constant Name_Id := Pragma_Name_Unmapped (N);
+ Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
+ Str : constant String_Id := Strval (Get_Pragma_Arg (Arg2));
+ Str_Len : constant Nat := String_Length (Str);
+
+ Force : constant Boolean :=
+ Prag_Id = Pragma_Compile_Time_Warning
+ and then Is_Spec_Name (Unit_Name (Current_Sem_Unit))
+ and then (Ekind (Cent) /= E_Package
+ or else not In_Private_Part (Cent));
+ -- Set True if this is the warning case, and we are in the
+ -- visible part of a package spec, or in a subprogram spec,
+ -- in which case we want to force the client to see the
+ -- warning, even though it is not in the main unit.
+
+ C : Character;
+ CC : Char_Code;
+ Cont : Boolean;
+ Ptr : Nat;
+
+ begin
+ -- Loop through segments of message separated by line feeds.
+ -- We output these segments as separate messages with
+ -- continuation marks for all but the first.
+
+ Cont := False;
+ Ptr := 1;
+ loop
+ Error_Msg_Strlen := 0;
+
+ -- Loop to copy characters from argument to error message
+ -- string buffer.
+
+ loop
+ exit when Ptr > Str_Len;
+ CC := Get_String_Char (Str, Ptr);
+ Ptr := Ptr + 1;
+
+ -- Ignore wide chars ??? else store character
+
+ if In_Character_Range (CC) then
+ C := Get_Character (CC);
+ exit when C = ASCII.LF;
+ Error_Msg_Strlen := Error_Msg_Strlen + 1;
+ Error_Msg_String (Error_Msg_Strlen) := C;
+ end if;
+ end loop;
+
+ -- Here with one line ready to go
+
+ Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
+
+ -- If this is a warning in a spec, then we want clients
+ -- to see the warning, so mark the message with the
+ -- special sequence !! to force the warning. In the case
+ -- of a package spec, we do not force this if we are in
+ -- the private part of the spec.
+
+ if Force then
+ if Cont = False then
+ Error_Msg ("<<~!!", Eloc);
+ Cont := True;
+ else
+ Error_Msg ("\<<~!!", Eloc);
+ end if;
+
+ -- Error, rather than warning, or in a body, so we do not
+ -- need to force visibility for client (error will be
+ -- output in any case, and this is the situation in which
+ -- we do not want a client to get a warning, since the
+ -- warning is in the body or the spec private part).
+
+ else
+ if Cont = False then
+ Error_Msg ("<<~", Eloc);
+ Cont := True;
+ else
+ Error_Msg ("\<<~", Eloc);
+ end if;
+ end if;
+
+ exit when Ptr > Str_Len;
+ end loop;
+ end;
+ end if;
+ end if;
+ end Process_Compile_Time_Warning_Or_Error;
+
------------------------------------
-- Record_Possible_Body_Reference --
------------------------------------
@@ -28305,10 +29628,14 @@ package body Sem_Prag is
-- Rewrite_Assertion_Kind --
----------------------------
- procedure Rewrite_Assertion_Kind (N : Node_Id) is
+ procedure Rewrite_Assertion_Kind
+ (N : Node_Id;
+ From_Policy : Boolean := False)
+ is
Nam : Name_Id;
begin
+ Nam := No_Name;
if Nkind (N) = N_Attribute_Reference
and then Attribute_Name (N) = Name_Class
and then Nkind (Prefix (N)) = N_Identifier
@@ -28316,16 +29643,40 @@ package body Sem_Prag is
case Chars (Prefix (N)) is
when Name_Pre =>
Nam := Name_uPre;
+
when Name_Post =>
Nam := Name_uPost;
+
when Name_Type_Invariant =>
Nam := Name_uType_Invariant;
+
when Name_Invariant =>
Nam := Name_uInvariant;
+
when others =>
return;
end case;
+ -- Recommend standard use of aspect names Pre/Post
+
+ elsif Nkind (N) = N_Identifier
+ and then From_Policy
+ and then Serious_Errors_Detected = 0
+ and then not ASIS_Mode
+ then
+ if Chars (N) = Name_Precondition
+ or else Chars (N) = Name_Postcondition
+ then
+ Error_Msg_N ("Check_Policy is a non-standard pragma??", N);
+ Error_Msg_N
+ ("\use Assertion_Policy and aspect names Pre/Post for "
+ & "Ada2012 conformance?", N);
+ end if;
+
+ return;
+ end if;
+
+ if Nam /= No_Name then
Rewrite (N, Make_Identifier (Sloc (N), Chars => Nam));
end if;
end Rewrite_Assertion_Kind;
@@ -28345,10 +29696,10 @@ package body Sem_Prag is
procedure Set_Encoded_Interface_Name (E : Entity_Id; S : Node_Id) is
Str : constant String_Id := Strval (S);
- Len : constant Int := String_Length (Str);
+ Len : constant Nat := String_Length (Str);
CC : Char_Code;
C : Character;
- J : Int;
+ J : Pos;
Hex : constant array (0 .. 15) of Character := "0123456789abcdef";
@@ -28378,12 +29729,10 @@ package body Sem_Prag is
begin
-- If first character is asterisk, this is a link name, and we leave it
-- completely unmodified. We also ignore null strings (the latter case
- -- happens only in error cases) and no encoding should occur for AAMP
- -- interface names.
+ -- happens only in error cases).
if Len = 0
or else Get_String_Char (Str, 1) = Get_Char_Code ('*')
- or else AAMP_On_Target
then
Set_Interface_Name (E, S);
diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads
index ce05bfd432..049c5c4c19 100644
--- a/gcc/ada/sem_prag.ads
+++ b/gcc/ada/sem_prag.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -100,6 +100,7 @@ package Sem_Prag is
Pragma_Remote_Access_Type => True,
Pragma_Remote_Call_Interface => True,
Pragma_Remote_Types => True,
+ Pragma_Secondary_Stack_Size => True,
Pragma_Shared => True,
Pragma_Shared_Passive => True,
Pragma_Simple_Storage_Pool_Type => True,
@@ -244,6 +245,20 @@ package Sem_Prag is
procedure Analyze_Test_Case_In_Decl_Part (N : Node_Id);
-- Perform preanalysis of pragma Test_Case
+ function Build_Pragma_Check_Equivalent
+ (Prag : Node_Id;
+ Subp_Id : Entity_Id := Empty;
+ Inher_Id : Entity_Id := Empty;
+ Keep_Pragma_Id : Boolean := False) return Node_Id;
+ -- Transform a pre- or [refined] postcondition denoted by Prag into an
+ -- equivalent pragma Check. When the pre- or postcondition is inherited,
+ -- the routine replaces the references of all formals of Inher_Id
+ -- and primitive operations of its controlling type by references
+ -- to the corresponding entities of Subp_Id and the descendant type.
+ -- Keep_Pragma_Id is True when the newly created pragma should be
+ -- in fact of the same kind as the source pragma Prag. This is used
+ -- in GNATprove_Mode to generate the inherited pre- and postconditions.
+
procedure Check_Applicable_Policy (N : Node_Id);
-- N is either an N_Aspect or an N_Pragma node. There are two cases. If
-- the name of the aspect or pragma is not one of those recognized as
@@ -301,6 +316,13 @@ package Sem_Prag is
-- state, variable or package instantiation denoted by Item_Id requires the
-- use of indicator/option Part_Of. If this is the case, emit an error.
+ procedure Collect_Inherited_Class_Wide_Conditions (Subp : Entity_Id);
+ -- In GNATprove mode, when analyzing an overriding subprogram, check
+ -- whether the overridden operations have class-wide pre/postconditions,
+ -- and generate the corresponding pragmas. The pragmas are inserted after
+ -- the subprogram declaration, together with those generated for other
+ -- aspects of the subprogram.
+
procedure Collect_Subprogram_Inputs_Outputs
(Subp_Id : Entity_Id;
Synthesize : Boolean := False;
@@ -380,8 +402,9 @@ package Sem_Prag is
-- Context denotes the entity of the function, package or procedure where
-- Prag resides.
- function Get_SPARK_Mode_From_Pragma (N : Node_Id) return SPARK_Mode_Type;
- -- Given a pragma SPARK_Mode node, return corresponding mode id
+ function Get_SPARK_Mode_From_Annotation
+ (N : Node_Id) return SPARK_Mode_Type;
+ -- Given an aspect or pragma SPARK_Mode node, return corresponding mode id
procedure Initialize;
-- Initializes data structures used for pragma processing. Must be called
@@ -445,6 +468,14 @@ package Sem_Prag is
-- Name_uInvariant, and Name_uType_Invariant (_Pre, _Post, _Invariant,
-- and _Type_Invariant).
+ procedure Process_Compile_Time_Warning_Or_Error
+ (N : Node_Id;
+ Eloc : Source_Ptr);
+ -- Common processing for Compile_Time_Error and Compile_Time_Warning of
+ -- pragma N. Called when the pragma is processed as part of its regular
+ -- analysis but also called after calling the back end to validate these
+ -- pragmas for size and alignment appropriateness.
+
procedure Process_Compilation_Unit_Pragmas (N : Node_Id);
-- Called at the start of processing compilation unit N to deal with any
-- special issues regarding pragmas. In particular, we have to deal with
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index f551c5e71c..3d6c39583c 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -203,6 +203,7 @@ package body Sem_Res is
procedure Resolve_Short_Circuit (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Slice (N : Node_Id; Typ : Entity_Id);
procedure Resolve_String_Literal (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve_Target_Name (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Type_Conversion (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Unary_Op (N : Node_Id; Typ : Entity_Id);
procedure Resolve_Unchecked_Expression (N : Node_Id; Typ : Entity_Id);
@@ -1410,7 +1411,7 @@ package body Sem_Res is
Opnd_Type := Base_Type (Typ);
elsif (Scope (Opnd_Type) = Standard_Standard
- and then Is_Binary)
+ and then Is_Binary)
or else (Nkind (Right_Opnd (Op_Node)) = N_Attribute_Reference
and then Is_Binary
and then not Comes_From_Source (Opnd_Type))
@@ -1424,7 +1425,6 @@ package body Sem_Res is
-- the given literal. Optimize the case where Pack is Standard.
if Pack /= Standard_Standard then
-
if Opnd_Type = Universal_Integer then
Orig_Type := Type_In_P (Is_Integer_Type'Access);
@@ -1576,11 +1576,20 @@ package body Sem_Res is
if Is_Private_Type (Typ) then
case Nkind (N) is
- when N_Op_Add | N_Op_Subtract | N_Op_Multiply | N_Op_Divide |
- N_Op_Expon | N_Op_Mod | N_Op_Rem =>
+ when N_Op_Add
+ | N_Op_Divide
+ | N_Op_Expon
+ | N_Op_Mod
+ | N_Op_Multiply
+ | N_Op_Rem
+ | N_Op_Subtract
+ =>
Resolve_Intrinsic_Operator (N, Typ);
- when N_Op_Plus | N_Op_Minus | N_Op_Abs =>
+ when N_Op_Abs
+ | N_Op_Minus
+ | N_Op_Plus
+ =>
Resolve_Intrinsic_Unary_Operator (N, Typ);
when others =>
@@ -1974,7 +1983,12 @@ package body Sem_Res is
procedure Resolution_Failed is
begin
Patch_Up_Value (N, Typ);
+
+ -- Set the type to the desired one to minimize cascaded errors. Note
+ -- that this is an approximation and does not work in all cases.
+
Set_Etype (N, Typ);
+
Debug_A_Exit ("resolving ", N, " (done, resolution failed)");
Set_Is_Overloaded (N, False);
@@ -1991,10 +2005,6 @@ package body Sem_Res is
return;
end Resolution_Failed;
- -- Local variables
-
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
-
-- Start of processing for Resolve
begin
@@ -2002,14 +2012,6 @@ package body Sem_Res is
return;
end if;
- -- A declaration may be subject to pragma Ghost. Set the mode now to
- -- ensure that any nodes generated during analysis and expansion are
- -- marked as Ghost.
-
- if Is_Declaration (N) then
- Set_Ghost_Mode (N);
- end if;
-
-- Access attribute on remote subprogram cannot be used for a non-remote
-- access-to-subprogram type.
@@ -2125,7 +2127,6 @@ package body Sem_Res is
if Analyzed (N) then
Debug_A_Exit ("resolving ", N, " (done, already analyzed)");
Analyze_Dimension (N);
- Ghost_Mode := Save_Ghost_Mode;
return;
-- Any case of Any_Type as the Etype value means that we had a
@@ -2133,7 +2134,6 @@ package body Sem_Res is
elsif Etype (N) = Any_Type then
Debug_A_Exit ("resolving ", N, " (done, Etype = Any_Type)");
- Ghost_Mode := Save_Ghost_Mode;
return;
end if;
@@ -2248,17 +2248,25 @@ package body Sem_Res is
end loop;
else
- -- Before we issue an ambiguity complaint, check for
- -- the case of a subprogram call where at least one
- -- of the arguments is Any_Type, and if so, suppress
- -- the message, since it is a cascaded error.
-
- if Nkind (N) in N_Subprogram_Call then
+ -- Before we issue an ambiguity complaint, check for the
+ -- case of a subprogram call where at least one of the
+ -- arguments is Any_Type, and if so suppress the message,
+ -- since it is a cascaded error. This can also happen for
+ -- a generalized indexing operation.
+
+ if Nkind (N) in N_Subprogram_Call
+ or else (Nkind (N) = N_Indexed_Component
+ and then Present (Generalized_Indexing (N)))
+ then
declare
A : Node_Id;
E : Node_Id;
begin
+ if Nkind (N) = N_Indexed_Component then
+ Rewrite (N, Generalized_Indexing (N));
+ end if;
+
A := First_Actual (N);
while Present (A) loop
E := A;
@@ -2292,17 +2300,17 @@ package body Sem_Res is
exit Interp_Loop;
end if;
- -- Not that special case, so issue message using the
- -- flag Ambiguous to control printing of the header
- -- message only at the start of an ambiguous set.
+ -- Not that special case, so issue message using the flag
+ -- Ambiguous to control printing of the header message
+ -- only at the start of an ambiguous set.
if not Ambiguous then
if Nkind (N) = N_Function_Call
and then Nkind (Name (N)) = N_Explicit_Dereference
then
Error_Msg_N
- ("ambiguous expression "
- & "(cannot resolve indirect call)!", N);
+ ("ambiguous expression (cannot resolve indirect "
+ & "call)!", N);
else
Error_Msg_NE -- CODEFIX
("ambiguous expression (cannot resolve&)!",
@@ -2458,9 +2466,10 @@ package body Sem_Res is
-- with a name that is an explicit dereference, there is
-- nothing to be done at this point.
- elsif Nkind_In (N, N_Explicit_Dereference,
- N_Attribute_Reference,
+ elsif Nkind_In (N, N_Attribute_Reference,
N_And_Then,
+ N_Explicit_Dereference,
+ N_Identifier,
N_Indexed_Component,
N_Or_Else,
N_Range,
@@ -2565,7 +2574,6 @@ package body Sem_Res is
then
Resolve (N, Full_View (Typ));
Set_Etype (N, Typ);
- Ghost_Mode := Save_Ghost_Mode;
return;
-- Check for an aggregate. Sometimes we can get bogus aggregates
@@ -2620,7 +2628,9 @@ package body Sem_Res is
-- replaced by the appropriate call during late
-- expansion.
- if not Box_Present (Elmt) then
+ if Nkind (Elmt) /= N_Iterated_Component_Association
+ and then not Box_Present (Elmt)
+ then
Check_Elmt (Expression (Elmt));
end if;
@@ -2674,11 +2684,18 @@ package body Sem_Res is
if Address_Integer_Convert_OK (Typ, Etype (N)) then
Rewrite (N, Unchecked_Convert_To (Typ, Relocate_Node (N)));
Analyze_And_Resolve (N, Typ);
- Ghost_Mode := Save_Ghost_Mode;
+ return;
+
+ -- Under relaxed RM semantics silently replace occurrences of null
+ -- by System.Address_Null.
+
+ elsif Null_To_Null_Address_Convert_OK (N, Typ) then
+ Replace_Null_By_Null_Address (N);
+ Analyze_And_Resolve (N, Typ);
return;
end if;
- -- That special Allow_Integer_Address check did not appply, so we
+ -- That special Allow_Integer_Address check did not apply, so we
-- have a real type error. If an error message was issued already,
-- Found got reset to True, so if it's still False, issue standard
-- Wrong_Type message.
@@ -2704,8 +2721,8 @@ package body Sem_Res is
Error_Msg_Node_2 := Typ;
Error_Msg_NE
- ("no visible interpretation of& "
- & "matches expected type&", N, Subp_Name);
+ ("no visible interpretation of& matches expected type&",
+ N, Subp_Name);
end;
if All_Errors_Mode then
@@ -2737,14 +2754,12 @@ package body Sem_Res is
end if;
Resolution_Failed;
- Ghost_Mode := Save_Ghost_Mode;
return;
-- Test if we have more than one interpretation for the context
elsif Ambiguous then
Resolution_Failed;
- Ghost_Mode := Save_Ghost_Mode;
return;
-- Only one intepretation
@@ -2817,7 +2832,6 @@ package body Sem_Res is
and then Present (Entity (N))
and then Ekind (Entity (N)) /= E_Operator
then
-
if not Is_Predefined_Op (Entity (N)) then
Rewrite_Operator_As_Call (N, Entity (N));
@@ -2832,130 +2846,160 @@ package body Sem_Res is
-- Rewrite_Renamed_Operator.
if Analyzed (N) then
- Ghost_Mode := Save_Ghost_Mode;
return;
end if;
end if;
end if;
case N_Subexpr'(Nkind (N)) is
+ when N_Aggregate =>
+ Resolve_Aggregate (N, Ctx_Type);
- when N_Aggregate => Resolve_Aggregate (N, Ctx_Type);
+ when N_Allocator =>
+ Resolve_Allocator (N, Ctx_Type);
- when N_Allocator => Resolve_Allocator (N, Ctx_Type);
+ when N_Short_Circuit =>
+ Resolve_Short_Circuit (N, Ctx_Type);
- when N_Short_Circuit
- => Resolve_Short_Circuit (N, Ctx_Type);
+ when N_Attribute_Reference =>
+ Resolve_Attribute (N, Ctx_Type);
- when N_Attribute_Reference
- => Resolve_Attribute (N, Ctx_Type);
+ when N_Case_Expression =>
+ Resolve_Case_Expression (N, Ctx_Type);
- when N_Case_Expression
- => Resolve_Case_Expression (N, Ctx_Type);
+ when N_Character_Literal =>
+ Resolve_Character_Literal (N, Ctx_Type);
- when N_Character_Literal
- => Resolve_Character_Literal (N, Ctx_Type);
+ when N_Delta_Aggregate =>
+ Resolve_Delta_Aggregate (N, Ctx_Type);
- when N_Expanded_Name
- => Resolve_Entity_Name (N, Ctx_Type);
+ when N_Expanded_Name =>
+ Resolve_Entity_Name (N, Ctx_Type);
- when N_Explicit_Dereference
- => Resolve_Explicit_Dereference (N, Ctx_Type);
+ when N_Explicit_Dereference =>
+ Resolve_Explicit_Dereference (N, Ctx_Type);
- when N_Expression_With_Actions
- => Resolve_Expression_With_Actions (N, Ctx_Type);
+ when N_Expression_With_Actions =>
+ Resolve_Expression_With_Actions (N, Ctx_Type);
- when N_Extension_Aggregate
- => Resolve_Extension_Aggregate (N, Ctx_Type);
+ when N_Extension_Aggregate =>
+ Resolve_Extension_Aggregate (N, Ctx_Type);
- when N_Function_Call
- => Resolve_Call (N, Ctx_Type);
+ when N_Function_Call =>
+ Resolve_Call (N, Ctx_Type);
- when N_Identifier
- => Resolve_Entity_Name (N, Ctx_Type);
+ when N_Identifier =>
+ Resolve_Entity_Name (N, Ctx_Type);
- when N_If_Expression
- => Resolve_If_Expression (N, Ctx_Type);
+ when N_If_Expression =>
+ Resolve_If_Expression (N, Ctx_Type);
- when N_Indexed_Component
- => Resolve_Indexed_Component (N, Ctx_Type);
+ when N_Indexed_Component =>
+ Resolve_Indexed_Component (N, Ctx_Type);
- when N_Integer_Literal
- => Resolve_Integer_Literal (N, Ctx_Type);
+ when N_Integer_Literal =>
+ Resolve_Integer_Literal (N, Ctx_Type);
- when N_Membership_Test
- => Resolve_Membership_Op (N, Ctx_Type);
+ when N_Membership_Test =>
+ Resolve_Membership_Op (N, Ctx_Type);
- when N_Null => Resolve_Null (N, Ctx_Type);
+ when N_Null =>
+ Resolve_Null (N, Ctx_Type);
- when N_Op_And | N_Op_Or | N_Op_Xor
- => Resolve_Logical_Op (N, Ctx_Type);
+ when N_Op_And
+ | N_Op_Or
+ | N_Op_Xor
+ =>
+ Resolve_Logical_Op (N, Ctx_Type);
- when N_Op_Eq | N_Op_Ne
- => Resolve_Equality_Op (N, Ctx_Type);
+ when N_Op_Eq
+ | N_Op_Ne
+ =>
+ Resolve_Equality_Op (N, Ctx_Type);
- when N_Op_Lt | N_Op_Le | N_Op_Gt | N_Op_Ge
- => Resolve_Comparison_Op (N, Ctx_Type);
+ when N_Op_Ge
+ | N_Op_Gt
+ | N_Op_Le
+ | N_Op_Lt
+ =>
+ Resolve_Comparison_Op (N, Ctx_Type);
- when N_Op_Not => Resolve_Op_Not (N, Ctx_Type);
+ when N_Op_Not =>
+ Resolve_Op_Not (N, Ctx_Type);
- when N_Op_Add | N_Op_Subtract | N_Op_Multiply |
- N_Op_Divide | N_Op_Mod | N_Op_Rem
+ when N_Op_Add
+ | N_Op_Divide
+ | N_Op_Mod
+ | N_Op_Multiply
+ | N_Op_Rem
+ | N_Op_Subtract
+ =>
+ Resolve_Arithmetic_Op (N, Ctx_Type);
- => Resolve_Arithmetic_Op (N, Ctx_Type);
-
- when N_Op_Concat => Resolve_Op_Concat (N, Ctx_Type);
+ when N_Op_Concat =>
+ Resolve_Op_Concat (N, Ctx_Type);
- when N_Op_Expon => Resolve_Op_Expon (N, Ctx_Type);
+ when N_Op_Expon =>
+ Resolve_Op_Expon (N, Ctx_Type);
- when N_Op_Plus | N_Op_Minus | N_Op_Abs
- => Resolve_Unary_Op (N, Ctx_Type);
+ when N_Op_Abs
+ | N_Op_Minus
+ | N_Op_Plus
+ =>
+ Resolve_Unary_Op (N, Ctx_Type);
- when N_Op_Shift => Resolve_Shift (N, Ctx_Type);
+ when N_Op_Shift =>
+ Resolve_Shift (N, Ctx_Type);
- when N_Procedure_Call_Statement
- => Resolve_Call (N, Ctx_Type);
+ when N_Procedure_Call_Statement =>
+ Resolve_Call (N, Ctx_Type);
- when N_Operator_Symbol
- => Resolve_Operator_Symbol (N, Ctx_Type);
+ when N_Operator_Symbol =>
+ Resolve_Operator_Symbol (N, Ctx_Type);
- when N_Qualified_Expression
- => Resolve_Qualified_Expression (N, Ctx_Type);
+ when N_Qualified_Expression =>
+ Resolve_Qualified_Expression (N, Ctx_Type);
-- Why is the following null, needs a comment ???
- when N_Quantified_Expression
- => null;
+ when N_Quantified_Expression =>
+ null;
+
+ when N_Raise_Expression =>
+ Resolve_Raise_Expression (N, Ctx_Type);
- when N_Raise_Expression
- => Resolve_Raise_Expression (N, Ctx_Type);
+ when N_Raise_xxx_Error =>
+ Set_Etype (N, Ctx_Type);
- when N_Raise_xxx_Error
- => Set_Etype (N, Ctx_Type);
+ when N_Range =>
+ Resolve_Range (N, Ctx_Type);
- when N_Range => Resolve_Range (N, Ctx_Type);
+ when N_Real_Literal =>
+ Resolve_Real_Literal (N, Ctx_Type);
- when N_Real_Literal
- => Resolve_Real_Literal (N, Ctx_Type);
+ when N_Reference =>
+ Resolve_Reference (N, Ctx_Type);
- when N_Reference => Resolve_Reference (N, Ctx_Type);
+ when N_Selected_Component =>
+ Resolve_Selected_Component (N, Ctx_Type);
- when N_Selected_Component
- => Resolve_Selected_Component (N, Ctx_Type);
+ when N_Slice =>
+ Resolve_Slice (N, Ctx_Type);
- when N_Slice => Resolve_Slice (N, Ctx_Type);
+ when N_String_Literal =>
+ Resolve_String_Literal (N, Ctx_Type);
- when N_String_Literal
- => Resolve_String_Literal (N, Ctx_Type);
+ when N_Target_Name =>
+ Resolve_Target_Name (N, Ctx_Type);
- when N_Type_Conversion
- => Resolve_Type_Conversion (N, Ctx_Type);
+ when N_Type_Conversion =>
+ Resolve_Type_Conversion (N, Ctx_Type);
when N_Unchecked_Expression =>
- Resolve_Unchecked_Expression (N, Ctx_Type);
+ Resolve_Unchecked_Expression (N, Ctx_Type);
when N_Unchecked_Type_Conversion =>
- Resolve_Unchecked_Type_Conversion (N, Ctx_Type);
+ Resolve_Unchecked_Type_Conversion (N, Ctx_Type);
end case;
-- Ada 2012 (AI05-0149): Apply an (implicit) conversion to an
@@ -2982,7 +3026,6 @@ package body Sem_Res is
if Nkind (N) not in N_Subexpr then
Debug_A_Exit ("resolving ", N, " (done)");
Expand (N);
- Ghost_Mode := Save_Ghost_Mode;
return;
end if;
@@ -3017,8 +3060,6 @@ package body Sem_Res is
Expand (N);
end if;
-
- Ghost_Mode := Save_Ghost_Mode;
end Resolve;
-------------
@@ -3099,6 +3140,10 @@ package body Sem_Res is
-- interpretation, but the form of the actual can only be determined
-- once the primitive operation is identified.
+ procedure Flag_Effectively_Volatile_Objects (Expr : Node_Id);
+ -- Emit an error concerning the illegal usage of an effectively volatile
+ -- object in interfering context (SPARK RM 7.13(12)).
+
procedure Insert_Default;
-- If the actual is missing in a call, insert in the actuals list
-- an instance of the default expression. The insertion is always
@@ -3352,6 +3397,55 @@ package body Sem_Res is
end if;
end Check_Prefixed_Call;
+ ---------------------------------------
+ -- Flag_Effectively_Volatile_Objects --
+ ---------------------------------------
+
+ procedure Flag_Effectively_Volatile_Objects (Expr : Node_Id) is
+ function Flag_Object (N : Node_Id) return Traverse_Result;
+ -- Determine whether arbitrary node N denotes an effectively volatile
+ -- object and if it does, emit an error.
+
+ -----------------
+ -- Flag_Object --
+ -----------------
+
+ function Flag_Object (N : Node_Id) return Traverse_Result is
+ Id : Entity_Id;
+
+ begin
+ -- Do not consider nested function calls because they have already
+ -- been processed during their own resolution.
+
+ if Nkind (N) = N_Function_Call then
+ return Skip;
+
+ elsif Is_Entity_Name (N) and then Present (Entity (N)) then
+ Id := Entity (N);
+
+ if Is_Object (Id)
+ and then Is_Effectively_Volatile (Id)
+ and then (Async_Writers_Enabled (Id)
+ or else Effective_Reads_Enabled (Id))
+ then
+ Error_Msg_N
+ ("volatile object cannot appear in this context (SPARK "
+ & "RM 7.1.3(11))", N);
+ return Skip;
+ end if;
+ end if;
+
+ return OK;
+ end Flag_Object;
+
+ procedure Flag_Objects is new Traverse_Proc (Flag_Object);
+
+ -- Start of processing for Flag_Effectively_Volatile_Objects
+
+ begin
+ Flag_Objects (Expr);
+ end Flag_Effectively_Volatile_Objects;
+
--------------------
-- Insert_Default --
--------------------
@@ -3379,6 +3473,10 @@ package body Sem_Res is
New_Scope => Current_Scope,
New_Sloc => Loc);
+ -- Propagate dimension information, if any.
+
+ Copy_Dimensions (Default_Value (F), Actval);
+
if Is_Concurrent_Type (Scope (Nam))
and then Has_Discriminants (Scope (Nam))
then
@@ -3449,7 +3547,6 @@ package body Sem_Res is
then
Set_Is_Controlling_Actual (Actval);
end if;
-
end if;
-- If the default expression raises constraint error, then just
@@ -3520,7 +3617,7 @@ package body Sem_Res is
Error_Msg_Name_1 := Prop_Nam;
Error_Msg_NE
("external variable & with enabled property % cannot appear as "
- & "actual in procedure call (SPARK RM 7.1.3(11))", Var, Var_Id);
+ & "actual in procedure call (SPARK RM 7.1.3(10))", Var, Var_Id);
Error_Msg_N ("\\corresponding formal parameter has mode In", Var);
end Property_Error;
@@ -3640,7 +3737,7 @@ package body Sem_Res is
if Present (A)
and then Is_Entity_Name (A)
- and then Comes_From_Source (N)
+ and then Comes_From_Source (A)
then
Orig_A := Entity (A);
@@ -4151,14 +4248,19 @@ package body Sem_Res is
then
Error_Msg_NE ("actual for& must be a variable", A, F);
- if Is_Subprogram (Current_Scope)
- and then
- (Is_Invariant_Procedure (Current_Scope)
- or else Is_Predicate_Function (Current_Scope))
- then
- Error_Msg_N
- ("function used in predicate cannot "
- & "modify its argument", F);
+ if Is_Subprogram (Current_Scope) then
+ if Is_Invariant_Procedure (Current_Scope)
+ or else Is_Partial_Invariant_Procedure (Current_Scope)
+ then
+ Error_Msg_N
+ ("function used in invariant cannot modify its "
+ & "argument", F);
+
+ elsif Is_Predicate_Function (Current_Scope) then
+ Error_Msg_N
+ ("function used in predicate cannot modify its "
+ & "argument", F);
+ end if;
end if;
end if;
@@ -4183,10 +4285,12 @@ package body Sem_Res is
-- Apply predicate tests except in certain special cases. Note
-- that it might be more consistent to apply these only when
-- expansion is active (in Exp_Ch6.Expand_Actuals), as we do
- -- for the outbound predicate tests ???
+ -- for the outbound predicate tests ??? In any case indicate
+ -- the function being called, for better warnings if the call
+ -- leads to an infinite recursion.
if Predicate_Tests_On_Arguments (Nam) then
- Apply_Predicate_Check (A, F_Typ);
+ Apply_Predicate_Check (A, F_Typ, Nam);
end if;
-- Apply required constraint checks
@@ -4268,24 +4372,36 @@ package body Sem_Res is
if Ekind_In (F, E_Out_Parameter, E_In_Out_Parameter) then
- -- If there is a type conversion, to make sure the return value
+ -- If there is a type conversion, make sure the return value
-- meets the constraints of the variable before the conversion.
if Nkind (A) = N_Type_Conversion then
if Is_Scalar_Type (A_Typ) then
Apply_Scalar_Range_Check
(Expression (A), Etype (Expression (A)), A_Typ);
+
+ -- In addition, the returned value of the parameter must
+ -- satisfy the bounds of the object type (see comment
+ -- below).
+
+ Apply_Scalar_Range_Check (A, A_Typ, F_Typ);
+
else
Apply_Range_Check
(Expression (A), Etype (Expression (A)), A_Typ);
end if;
- -- If no conversion apply scalar range checks and length checks
- -- base on the subtype of the actual (NOT that of the formal).
+ -- If no conversion, apply scalar range checks and length check
+ -- based on the subtype of the actual (NOT that of the formal).
+ -- This indicates that the check takes place on return from the
+ -- call. During expansion the required constraint checks are
+ -- inserted. In GNATprove mode, in the absence of expansion,
+ -- the flag indicates that the returned value is valid.
else
if Is_Scalar_Type (F_Typ) then
Apply_Scalar_Range_Check (A, A_Typ, F_Typ);
+
elsif Is_Array_Type (F_Typ)
and then Ekind (F) = E_Out_Parameter
then
@@ -4461,13 +4577,11 @@ package body Sem_Res is
-- they are not standard Ada legality rule. Internally generated
-- temporaries are ignored.
- if SPARK_Mode = On
- and then Comes_From_Source (A)
- and then Is_Effectively_Volatile_Object (A)
- then
+ if SPARK_Mode = On and then Comes_From_Source (A) then
+
-- An effectively volatile object may act as an actual when the
-- corresponding formal is of a non-scalar effectively volatile
- -- type (SPARK RM 7.1.3(12)).
+ -- type (SPARK RM 7.1.3(11)).
if not Is_Scalar_Type (Etype (F))
and then Is_Effectively_Volatile (Etype (F))
@@ -4476,15 +4590,28 @@ package body Sem_Res is
-- An effectively volatile object may act as an actual in a
-- call to an instance of Unchecked_Conversion.
- -- (SPARK RM 7.1.3(12)).
+ -- (SPARK RM 7.1.3(11)).
elsif Is_Unchecked_Conversion_Instance (Nam) then
null;
- else
+ -- The actual denotes an object
+
+ elsif Is_Effectively_Volatile_Object (A) then
Error_Msg_N
("volatile object cannot act as actual in a call (SPARK "
- & "RM 7.1.3(12))", A);
+ & "RM 7.1.3(11))", A);
+
+ -- Otherwise the actual denotes an expression. Inspect the
+ -- expression and flag each effectively volatile object with
+ -- enabled property Async_Writers or Effective_Reads as illegal
+ -- because it apprears within an interfering context. Note that
+ -- this is usually done in Resolve_Entity_Name, but when the
+ -- effectively volatile object appears as an actual in a call,
+ -- the call must be resolved first.
+
+ else
+ Flag_Effectively_Volatile_Objects (A);
end if;
-- Detect an external variable with an enabled property that
@@ -4521,14 +4648,14 @@ package body Sem_Res is
Extensions_Visible_True
then
Error_Msg_N
- ("formal parameter with Extensions_Visible False cannot act "
- & "as actual parameter", A);
+ ("formal parameter cannot act as actual parameter when "
+ & "Extensions_Visible is False", A);
Error_Msg_NE
("\subprogram & has Extensions_Visible True", A, Nam);
end if;
-- The actual parameter of a Ghost subprogram whose formal is of
- -- mode IN OUT or OUT must be a Ghost variable (SPARK RM 6.9(13)).
+ -- mode IN OUT or OUT must be a Ghost variable (SPARK RM 6.9(12)).
if Comes_From_Source (Nam)
and then Is_Ghost_Entity (Nam)
@@ -4692,13 +4819,21 @@ package body Sem_Res is
and then not In_Instance_Body
then
if not OK_For_Limited_Init (Etype (E), Expression (E)) then
- Error_Msg_N ("initialization not allowed for limited types", N);
+ if Nkind (Parent (N)) = N_Assignment_Statement then
+ Error_Msg_N
+ ("illegal expression for initialized allocator of a "
+ & "limited type (RM 7.5 (2.7/2))", N);
+ else
+ Error_Msg_N
+ ("initialization not allowed for limited types", N);
+ end if;
+
Explain_Limited_Type (Etype (E), N);
end if;
end if;
- -- A qualified expression requires an exact match of the type.
- -- Class-wide matching is not allowed.
+ -- A qualified expression requires an exact match of the type. Class-
+ -- wide matching is not allowed.
if (Is_Class_Wide_Type (Etype (Expression (E)))
or else Is_Class_Wide_Type (Etype (E)))
@@ -5440,7 +5575,9 @@ package body Sem_Res is
and then Expr_Value_R (Rop) = Ureal_0))
then
-- Specialize the warning message according to the operation.
- -- The following warnings are for the case
+ -- When SPARK_Mode is On, force a warning instead of an error
+ -- in that case, as this likely corresponds to deactivated
+ -- code. The following warnings are for the case
case Nkind (N) is
when N_Op_Divide =>
@@ -5459,23 +5596,26 @@ package body Sem_Res is
("float division by zero, may generate "
& "'+'/'- infinity??", Right_Opnd (N));
- -- For all other cases, we get a Constraint_Error
+ -- For all other cases, we get a Constraint_Error
else
Apply_Compile_Time_Constraint_Error
(N, "division by zero??", CE_Divide_By_Zero,
- Loc => Sloc (Right_Opnd (N)));
+ Loc => Sloc (Right_Opnd (N)),
+ Warn => SPARK_Mode = On);
end if;
when N_Op_Rem =>
Apply_Compile_Time_Constraint_Error
(N, "rem with zero divisor??", CE_Divide_By_Zero,
- Loc => Sloc (Right_Opnd (N)));
+ Loc => Sloc (Right_Opnd (N)),
+ Warn => SPARK_Mode = On);
when N_Op_Mod =>
Apply_Compile_Time_Constraint_Error
(N, "mod with zero divisor??", CE_Divide_By_Zero,
- Loc => Sloc (Right_Opnd (N)));
+ Loc => Sloc (Right_Opnd (N)),
+ Warn => SPARK_Mode = On);
-- Division by zero can only happen with division, rem,
-- and mod operations.
@@ -5484,6 +5624,13 @@ package body Sem_Res is
raise Program_Error;
end case;
+ -- In GNATprove mode, we enable the division check so that
+ -- GNATprove will issue a message if it cannot be proved.
+
+ if GNATprove_Mode then
+ Activate_Division_Check (N);
+ end if;
+
-- Otherwise just set the flag to check at run time
else
@@ -5834,7 +5981,12 @@ package body Sem_Res is
-- component type of that array type, the node is really an indexing of
-- the parameterless call. Resolve as such. A pathological case occurs
-- when the type of the component is an access to the array type. In
- -- this case the call is truly ambiguous.
+ -- this case the call is truly ambiguous. If the call is to an intrinsic
+ -- subprogram, it can't be an indexed component. This check is necessary
+ -- because if it's Unchecked_Conversion, and we have "type T_Ptr is
+ -- access T;" and "type T is array (...) of T_Ptr;" (i.e. an array of
+ -- pointers to the same array), the compiler gets confused and does an
+ -- infinite recursion.
elsif (Needs_No_Actuals (Nam) or else Needs_One_Actual (Nam))
and then
@@ -5844,7 +5996,8 @@ package body Sem_Res is
(Is_Access_Type (Etype (Nam))
and then Is_Array_Type (Designated_Type (Etype (Nam)))
and then
- Covers (Typ, Component_Type (Designated_Type (Etype (Nam))))))
+ Covers (Typ, Component_Type (Designated_Type (Etype (Nam))))
+ and then not Is_Intrinsic_Subprogram (Entity (Subp))))
then
declare
Index_Node : Node_Id;
@@ -5921,6 +6074,19 @@ package body Sem_Res is
end;
else
+ -- If the called function is not declared in the main unit and it
+ -- returns the limited view of type then use the available view (as
+ -- is done in Try_Object_Operation) to prevent back-end confusion;
+ -- the call must appear in a context where the nonlimited view is
+ -- available. If the called function is in the extended main unit
+ -- then no action is needed, because the back end handles this case.
+
+ if not In_Extended_Main_Code_Unit (Nam)
+ and then From_Limited_With (Etype (Nam))
+ then
+ Set_Etype (Nam, Available_View (Etype (Nam)));
+ end if;
+
Set_Etype (N, Etype (Nam));
end if;
@@ -6114,7 +6280,10 @@ package body Sem_Res is
-- within the specialized Exp_Ch6 procedures for expanding those
-- build-in-place calls.
- -- e) If the subprogram is marked Inline_Always, then even if it returns
+ -- e) Calls to inlinable expression functions do not use the secondary
+ -- stack (since the call will be replaced by its returned object).
+
+ -- f) If the subprogram is marked Inline_Always, then even if it returns
-- an unconstrained type the call does not require use of the secondary
-- stack. However, inlining will only take place if the body to inline
-- is already present. It may not be available if e.g. the subprogram is
@@ -6135,6 +6304,7 @@ package body Sem_Res is
elsif Ekind (Nam) = E_Enumeration_Literal
or else Is_Build_In_Place_Function (Nam)
or else Is_Intrinsic_Subprogram (Nam)
+ or else Is_Inlinable_Expression_Function (Nam)
then
null;
@@ -6163,12 +6333,14 @@ package body Sem_Res is
-- A protected function cannot be called within the definition of the
-- enclosing protected type, unless it is part of a pre/postcondition
- -- on another protected operation.
+ -- on another protected operation. This may appear in the entry wrapper
+ -- created for an entry with preconditions.
if Is_Protected_Type (Scope (Nam))
and then In_Open_Scopes (Scope (Nam))
and then not Has_Completion (Scope (Nam))
and then not In_Spec_Expression
+ and then not Is_Entry_Wrapper (Current_Scope)
then
Error_Msg_NE
("& cannot be called before end of protected definition", N, Nam);
@@ -6428,16 +6600,14 @@ package body Sem_Res is
-- assertions as logic expressions.
elsif In_Assertion_Expr /= 0 then
- Error_Msg_NE ("info: no contextual analysis of &?", N, Nam);
- Error_Msg_N ("\call appears in assertion expression", N);
- Set_Is_Inlined_Always (Nam_UA, False);
+ Cannot_Inline
+ ("cannot inline & (in assertion expression)?", N, Nam_UA);
-- Calls cannot be inlined inside default expressions
elsif In_Default_Expr then
- Error_Msg_NE ("info: no contextual analysis of &?", N, Nam);
- Error_Msg_N ("\call appears in default expression", N);
- Set_Is_Inlined_Always (Nam_UA, False);
+ Cannot_Inline
+ ("cannot inline & (in default expression)?", N, Nam_UA);
-- Inlining should not be performed during pre-analysis
@@ -6447,10 +6617,8 @@ package body Sem_Res is
-- inlined if the corresponding body has not been seen yet.
if No (Body_Id) then
- Error_Msg_NE
- ("info: no contextual analysis of & (body not seen yet)?",
- N, Nam);
- Set_Is_Inlined_Always (Nam_UA, False);
+ Cannot_Inline
+ ("cannot inline & (body not seen yet)?", N, Nam_UA);
-- Nothing to do if there is no body to inline, indicating that
-- the subprogram is not suitable for inlining in GNATprove
@@ -6459,15 +6627,34 @@ package body Sem_Res is
elsif No (Body_To_Inline (Nam_Decl)) then
null;
+ -- Do not inline calls inside expression functions, as this
+ -- would prevent interpreting them as logical formulas in
+ -- GNATprove.
+
+ elsif Present (Current_Subprogram)
+ and then
+ Is_Expression_Function_Or_Completion (Current_Subprogram)
+ then
+ Cannot_Inline
+ ("cannot inline & (inside expression function)?",
+ N, Nam_UA);
+
-- Calls cannot be inlined inside potentially unevaluated
-- expressions, as this would create complex actions inside
-- expressions, that are not handled by GNATprove.
elsif Is_Potentially_Unevaluated (N) then
- Error_Msg_NE ("info: no contextual analysis of &?", N, Nam);
- Error_Msg_N
- ("\call appears in potentially unevaluated context", N);
- Set_Is_Inlined_Always (Nam_UA, False);
+ Cannot_Inline
+ ("cannot inline & (in potentially unevaluated context)?",
+ N, Nam_UA);
+
+ -- Do not inline calls which would possibly lead to missing a
+ -- type conversion check on an input parameter.
+
+ elsif not Call_Can_Be_Inlined_In_GNATprove_Mode (N, Nam) then
+ Cannot_Inline
+ ("cannot inline & (possible check on input parameters)?",
+ N, Nam_UA);
-- Otherwise, inline the call
@@ -6486,13 +6673,27 @@ package body Sem_Res is
-----------------------------
procedure Resolve_Case_Expression (N : Node_Id; Typ : Entity_Id) is
- Alt : Node_Id;
- Is_Dyn : Boolean;
+ Alt : Node_Id;
+ Alt_Expr : Node_Id;
+ Alt_Typ : Entity_Id;
+ Is_Dyn : Boolean;
begin
Alt := First (Alternatives (N));
while Present (Alt) loop
- Resolve (Expression (Alt), Typ);
+ Alt_Expr := Expression (Alt);
+ Resolve (Alt_Expr, Typ);
+ Alt_Typ := Etype (Alt_Expr);
+
+ -- When the expression is of a scalar subtype different from the
+ -- result subtype, then insert a conversion to ensure the generation
+ -- of a constraint check.
+
+ if Is_Scalar_Type (Alt_Typ) and then Alt_Typ /= Typ then
+ Rewrite (Alt_Expr, Convert_To (Typ, Alt_Expr));
+ Analyze_And_Resolve (Alt_Expr, Typ);
+ end if;
+
Next (Alt);
end loop;
@@ -6500,13 +6701,14 @@ package body Sem_Res is
-- dynamically tagged must be known statically.
if Is_Tagged_Type (Typ) and then not Is_Class_Wide_Type (Typ) then
- Alt := First (Alternatives (N));
+ Alt := First (Alternatives (N));
Is_Dyn := Is_Dynamically_Tagged (Expression (Alt));
while Present (Alt) loop
if Is_Dynamically_Tagged (Expression (Alt)) /= Is_Dyn then
- Error_Msg_N ("all or none of the dependent expressions "
- & "can be dynamically tagged", N);
+ Error_Msg_N
+ ("all or none of the dependent expressions can be "
+ & "dynamically tagged", N);
end if;
Next (Alt);
@@ -6797,13 +6999,6 @@ package body Sem_Res is
-- Determine whether node Context denotes an assignment statement or an
-- object declaration whose expression is node Expr.
- function Is_OK_Volatile_Context
- (Context : Node_Id;
- Obj_Ref : Node_Id) return Boolean;
- -- Determine whether node Context denotes a "non-interfering context"
- -- (as defined in SPARK RM 7.1.3(12)) where volatile reference Obj_Ref
- -- can safely reside.
-
----------------------------------------
-- Is_Assignment_Or_Object_Expression --
----------------------------------------
@@ -6846,251 +7041,6 @@ package body Sem_Res is
end if;
end Is_Assignment_Or_Object_Expression;
- ----------------------------
- -- Is_OK_Volatile_Context --
- ----------------------------
-
- function Is_OK_Volatile_Context
- (Context : Node_Id;
- Obj_Ref : Node_Id) return Boolean
- is
- function Is_Protected_Operation_Call (Nod : Node_Id) return Boolean;
- -- Determine whether an arbitrary node denotes a call to a protected
- -- entry, function or procedure in prefixed form where the prefix is
- -- Obj_Ref.
-
- function Within_Check (Nod : Node_Id) return Boolean;
- -- Determine whether an arbitrary node appears in a check node
-
- function Within_Subprogram_Call (Nod : Node_Id) return Boolean;
- -- Determine whether an arbitrary node appears in a procedure call
-
- function Within_Volatile_Function (Id : Entity_Id) return Boolean;
- -- Determine whether an arbitrary entity appears in a volatile
- -- function.
-
- ---------------------------------
- -- Is_Protected_Operation_Call --
- ---------------------------------
-
- function Is_Protected_Operation_Call (Nod : Node_Id) return Boolean is
- Pref : Node_Id;
- Subp : Node_Id;
-
- begin
- -- A call to a protected operations retains its selected component
- -- form as opposed to other prefixed calls that are transformed in
- -- expanded names.
-
- if Nkind (Nod) = N_Selected_Component then
- Pref := Prefix (Nod);
- Subp := Selector_Name (Nod);
-
- return
- Pref = Obj_Ref
- and then Is_Protected_Type (Etype (Pref))
- and then Is_Entity_Name (Subp)
- and then Ekind_In (Entity (Subp), E_Entry,
- E_Entry_Family,
- E_Function,
- E_Procedure);
- else
- return False;
- end if;
- end Is_Protected_Operation_Call;
-
- ------------------
- -- Within_Check --
- ------------------
-
- function Within_Check (Nod : Node_Id) return Boolean is
- Par : Node_Id;
-
- begin
- -- Climb the parent chain looking for a check node
-
- Par := Nod;
- while Present (Par) loop
- if Nkind (Par) in N_Raise_xxx_Error then
- return True;
-
- -- Prevent the search from going too far
-
- elsif Is_Body_Or_Package_Declaration (Par) then
- exit;
- end if;
-
- Par := Parent (Par);
- end loop;
-
- return False;
- end Within_Check;
-
- ----------------------------
- -- Within_Subprogram_Call --
- ----------------------------
-
- function Within_Subprogram_Call (Nod : Node_Id) return Boolean is
- Par : Node_Id;
-
- begin
- -- Climb the parent chain looking for a function or procedure call
-
- Par := Nod;
- while Present (Par) loop
- if Nkind_In (Par, N_Function_Call,
- N_Procedure_Call_Statement)
- then
- return True;
-
- -- Prevent the search from going too far
-
- elsif Is_Body_Or_Package_Declaration (Par) then
- exit;
- end if;
-
- Par := Parent (Par);
- end loop;
-
- return False;
- end Within_Subprogram_Call;
-
- ------------------------------
- -- Within_Volatile_Function --
- ------------------------------
-
- function Within_Volatile_Function (Id : Entity_Id) return Boolean is
- Func_Id : Entity_Id;
-
- begin
- -- Traverse the scope stack looking for a [generic] function
-
- Func_Id := Id;
- while Present (Func_Id) and then Func_Id /= Standard_Standard loop
- if Ekind_In (Func_Id, E_Function, E_Generic_Function) then
- return Is_Volatile_Function (Func_Id);
- end if;
-
- Func_Id := Scope (Func_Id);
- end loop;
-
- return False;
- end Within_Volatile_Function;
-
- -- Local variables
-
- Obj_Id : Entity_Id;
-
- -- Start of processing for Is_OK_Volatile_Context
-
- begin
- -- The volatile object appears on either side of an assignment
-
- if Nkind (Context) = N_Assignment_Statement then
- return True;
-
- -- The volatile object is part of the initialization expression of
- -- another object.
-
- elsif Nkind (Context) = N_Object_Declaration
- and then Present (Expression (Context))
- and then Expression (Context) = Obj_Ref
- then
- Obj_Id := Defining_Entity (Context);
-
- -- The volatile object acts as the initialization expression of an
- -- extended return statement. This is valid context as long as the
- -- function is volatile.
-
- if Is_Return_Object (Obj_Id) then
- return Within_Volatile_Function (Obj_Id);
-
- -- Otherwise this is a normal object initialization
-
- else
- return True;
- end if;
-
- -- The volatile object acts as the name of a renaming declaration
-
- elsif Nkind (Context) = N_Object_Renaming_Declaration
- and then Name (Context) = Obj_Ref
- then
- return True;
-
- -- The volatile object appears as an actual parameter in a call to an
- -- instance of Unchecked_Conversion whose result is renamed.
-
- elsif Nkind (Context) = N_Function_Call
- and then Is_Entity_Name (Name (Context))
- and then Is_Unchecked_Conversion_Instance (Entity (Name (Context)))
- and then Nkind (Parent (Context)) = N_Object_Renaming_Declaration
- then
- return True;
-
- -- The volatile object is actually the prefix in a protected entry,
- -- function, or procedure call.
-
- elsif Is_Protected_Operation_Call (Context) then
- return True;
-
- -- The volatile object appears as the expression of a simple return
- -- statement that applies to a volatile function.
-
- elsif Nkind (Context) = N_Simple_Return_Statement
- and then Expression (Context) = Obj_Ref
- then
- return
- Within_Volatile_Function (Return_Statement_Entity (Context));
-
- -- The volatile object appears as the prefix of a name occurring
- -- in a non-interfering context.
-
- elsif Nkind_In (Context, N_Attribute_Reference,
- N_Explicit_Dereference,
- N_Indexed_Component,
- N_Selected_Component,
- N_Slice)
- and then Prefix (Context) = Obj_Ref
- and then Is_OK_Volatile_Context
- (Context => Parent (Context),
- Obj_Ref => Context)
- then
- return True;
-
- -- The volatile object appears as the expression of a type conversion
- -- occurring in a non-interfering context.
-
- elsif Nkind_In (Context, N_Type_Conversion,
- N_Unchecked_Type_Conversion)
- and then Expression (Context) = Obj_Ref
- and then Is_OK_Volatile_Context
- (Context => Parent (Context),
- Obj_Ref => Context)
- then
- return True;
-
- -- Allow references to volatile objects in various checks. This is
- -- not a direct SPARK 2014 requirement.
-
- elsif Within_Check (Context) then
- return True;
-
- -- Assume that references to effectively volatile objects that appear
- -- as actual parameters in a subprogram call are always legal. A full
- -- legality check is done when the actuals are resolved.
-
- elsif Within_Subprogram_Call (Context) then
- return True;
-
- -- Otherwise the context is not suitable for an effectively volatile
- -- object.
-
- else
- return False;
- end if;
- end Is_OK_Volatile_Context;
-
-- Local variables
E : constant Entity_Id := Entity (N);
@@ -7192,8 +7142,8 @@ package body Sem_Res is
then
null;
else
- Error_Msg_N (
- "deferred constant is frozen before completion", N);
+ Error_Msg_N
+ ("deferred constant is frozen before completion", N);
end if;
end if;
@@ -7236,6 +7186,7 @@ package body Sem_Res is
-- read as it simply establishes an alias.
if Ekind (E) = E_Variable
+ and then Dynamic_Elaboration_Checks
and then Nkind (Par) /= N_Object_Renaming_Declaration
then
Check_Elab_Call (N);
@@ -7593,6 +7544,12 @@ package body Sem_Res is
and then Present (Contract_Wrapper (Nam))
and then Current_Scope /= Contract_Wrapper (Nam)
then
+
+ -- Note the entity being called before rewriting the call, so that
+ -- it appears used at this point.
+
+ Generate_Reference (Nam, Entry_Name, 'r');
+
-- Rewrite as call to the precondition wrapper, adding the task
-- object to the list of actuals. If the call is to a member of an
-- entry family, include the index as well.
@@ -7633,6 +7590,19 @@ package body Sem_Res is
Normalize_Actuals (N, Nam, False, Norm_OK);
pragma Assert (Norm_OK);
Set_Etype (N, Etype (Nam));
+
+ -- Reset the Is_Overloaded flag, since resolution is now completed
+
+ -- Simple entry call
+
+ if Nkind (Entry_Name) = N_Selected_Component then
+ Set_Is_Overloaded (Selector_Name (Entry_Name), False);
+
+ -- Call to a member of an entry family
+
+ else pragma Assert (Nkind (Entry_Name) = N_Indexed_Component);
+ Set_Is_Overloaded (Selector_Name (Prefix (Entry_Name)), False);
+ end if;
end if;
Resolve_Actuals (N, Nam);
@@ -8208,7 +8178,7 @@ package body Sem_Res is
end loop;
if Nkind (Call) = N_Function_Call then
- Indexes := Parameter_Associations (Call);
+ Indexes := New_Copy_List (Parameter_Associations (Call));
Pref := Remove_Head (Indexes);
Set_Expressions (N, Indexes);
@@ -8258,9 +8228,19 @@ package body Sem_Res is
end if;
-- If ELSE expression present, just resolve using the determined type
+ -- If type is universal, resolve to any member of the class.
if Present (Else_Expr) then
- Resolve (Else_Expr, Typ);
+ if Typ = Universal_Integer then
+ Resolve (Else_Expr, Any_Integer);
+
+ elsif Typ = Universal_Real then
+ Resolve (Else_Expr, Any_Real);
+
+ else
+ Resolve (Else_Expr, Typ);
+ end if;
+
Else_Typ := Etype (Else_Expr);
if Is_Scalar_Type (Else_Typ) and then Else_Typ /= Typ then
@@ -9389,20 +9369,20 @@ package body Sem_Res is
else
case Nkind (Parent (N)) is
- when N_Op_And |
- N_Op_Eq |
- N_Op_Ge |
- N_Op_Gt |
- N_Op_Le |
- N_Op_Lt |
- N_Op_Ne |
- N_Op_Or |
- N_Op_Xor |
- N_In |
- N_Not_In |
- N_And_Then |
- N_Or_Else =>
-
+ when N_And_Then
+ | N_In
+ | N_Not_In
+ | N_Op_And
+ | N_Op_Eq
+ | N_Op_Ge
+ | N_Op_Gt
+ | N_Op_Le
+ | N_Op_Lt
+ | N_Op_Ne
+ | N_Op_Or
+ | N_Op_Xor
+ | N_Or_Else
+ =>
return Left_Opnd (Parent (N)) = N;
when others =>
@@ -9559,6 +9539,29 @@ package body Sem_Res is
if Nkind (N) = N_Qualified_Expression and then Is_Scalar_Type (Typ) then
Apply_Scalar_Range_Check (Expr, Typ);
end if;
+
+ -- Finally, check whether a predicate applies to the target type. This
+ -- comes from AI12-0100. As for type conversions, check the enclosing
+ -- context to prevent an infinite expansion.
+
+ if Has_Predicates (Target_Typ) then
+ if Nkind (Parent (N)) = N_Function_Call
+ and then Present (Name (Parent (N)))
+ and then (Is_Predicate_Function (Entity (Name (Parent (N))))
+ or else
+ Is_Predicate_Function_M (Entity (Name (Parent (N)))))
+ then
+ null;
+
+ -- In the case of a qualified expression in an allocator, the check
+ -- is applied when expanding the allocator, so avoid redundant check.
+
+ elsif Nkind (N) = N_Qualified_Expression
+ and then Nkind (Parent (N)) /= N_Allocator
+ then
+ Apply_Predicate_Check (N, Target_Typ);
+ end if;
+ end if;
end Resolve_Qualified_Expression;
------------------------------
@@ -9621,8 +9624,14 @@ package body Sem_Res is
begin
Set_Etype (N, Typ);
+
+ -- The lower bound should be in Typ. The higher bound can be in Typ's
+ -- base type if the range is null. It may still be invalid if it is
+ -- higher than the lower bound. This is checked later in the context in
+ -- which the range appears.
+
Resolve (L, Typ);
- Resolve (H, Typ);
+ Resolve (H, Base_Type (Typ));
-- Check for inappropriate range on unordered enumeration type
@@ -10020,12 +10029,12 @@ package body Sem_Res is
begin
-- Ensure all actions associated with the left operand (e.g.
- -- finalization of transient controlled objects) are fully evaluated
- -- locally within an expression with actions. This is particularly
- -- helpful for coverage analysis. However this should not happen in
- -- generics.
+ -- finalization of transient objects) are fully evaluated locally within
+ -- an expression with actions. This is particularly helpful for coverage
+ -- analysis. However this should not happen in generics or if option
+ -- Minimize_Expression_With_Actions is set.
- if Expander_Active then
+ if Expander_Active and not Minimize_Expression_With_Actions then
declare
Reloc_L : constant Node_Id := Relocate_Node (L);
begin
@@ -10636,6 +10645,15 @@ package body Sem_Res is
end;
end Resolve_String_Literal;
+ -------------------------
+ -- Resolve_Target_Name --
+ -------------------------
+
+ procedure Resolve_Target_Name (N : Node_Id; Typ : Entity_Id) is
+ begin
+ Set_Etype (N, Typ);
+ end Resolve_Target_Name;
+
-----------------------------
-- Resolve_Type_Conversion --
-----------------------------
@@ -11032,6 +11050,23 @@ package body Sem_Res is
then
Set_Do_Range_Check (Operand);
end if;
+
+ -- Generating C code a type conversion of an access to constrained
+ -- array type to access to unconstrained array type involves building
+ -- a fat pointer which in general cannot be generated on the fly. We
+ -- remove side effects in order to store the result of the conversion
+ -- into a temporary.
+
+ if Modify_Tree_For_C
+ and then Nkind (N) = N_Type_Conversion
+ and then Nkind (Parent (N)) /= N_Object_Declaration
+ and then Is_Access_Type (Etype (N))
+ and then Is_Array_Type (Designated_Type (Etype (N)))
+ and then not Is_Constrained (Designated_Type (Etype (N)))
+ and then Is_Constrained (Designated_Type (Etype (Expression (N))))
+ then
+ Remove_Side_Effects (N);
+ end if;
end Resolve_Type_Conversion;
----------------------
@@ -11322,8 +11357,10 @@ package body Sem_Res is
-- Do not perform this transformation within a pre/postcondition,
-- because the expression will be re-analyzed, and the transformation
-- might affect the visibility of the operator, e.g. in an instance.
+ -- Note that fully analyzed and expanded pre/postconditions appear as
+ -- pragma Check equivalents.
- if In_Assertion_Expr > 0 then
+ if In_Pre_Post_Condition (N) then
return;
end if;
@@ -11345,7 +11382,7 @@ package body Sem_Res is
Generate_Reference (Op, N);
if Is_Binary then
- Set_Left_Opnd (Op_Node, Left_Opnd (N));
+ Set_Left_Opnd (Op_Node, Left_Opnd (N));
end if;
Rewrite (N, Op_Node);
@@ -11354,15 +11391,22 @@ package body Sem_Res is
-- that the operator is applied to the full view. This is done in the
-- routines that resolve intrinsic operators.
- if Is_Intrinsic_Subprogram (Op)
- and then Is_Private_Type (Typ)
- then
+ if Is_Intrinsic_Subprogram (Op) and then Is_Private_Type (Typ) then
case Nkind (N) is
- when N_Op_Add | N_Op_Subtract | N_Op_Multiply | N_Op_Divide |
- N_Op_Expon | N_Op_Mod | N_Op_Rem =>
+ when N_Op_Add
+ | N_Op_Divide
+ | N_Op_Expon
+ | N_Op_Mod
+ | N_Op_Multiply
+ | N_Op_Rem
+ | N_Op_Subtract
+ =>
Resolve_Intrinsic_Operator (N, Typ);
- when N_Op_Plus | N_Op_Minus | N_Op_Abs =>
+ when N_Op_Abs
+ | N_Op_Minus
+ | N_Op_Plus
+ =>
Resolve_Intrinsic_Unary_Operator (N, Typ);
when others =>
@@ -11844,8 +11888,7 @@ package body Sem_Res is
-- Valid_Array_Conversion --
----------------------------
- function Valid_Array_Conversion return Boolean
- is
+ function Valid_Array_Conversion return Boolean is
Opnd_Comp_Type : constant Entity_Id := Component_Type (Opnd_Type);
Opnd_Comp_Base : constant Entity_Id := Base_Type (Opnd_Comp_Type);
@@ -12004,9 +12047,11 @@ package body Sem_Res is
"downward conversion of tagged objects not allowed");
-- Ada 2005 (AI-251): The conversion to/from interface types is
- -- always valid
+ -- always valid. The types involved may be class-wide (sub)types.
- elsif Is_Interface (Target_Type) or else Is_Interface (Opnd_Type) then
+ elsif Is_Interface (Etype (Base_Type (Target_Type)))
+ or else Is_Interface (Etype (Base_Type (Opnd_Type)))
+ then
return True;
-- If the operand is a class-wide type obtained through a limited_
@@ -12080,7 +12125,7 @@ package body Sem_Res is
-- operations must be done explicitly here.
if not Address_Is_Private
- and then Is_Descendent_Of_Address (It.Typ)
+ and then Is_Descendant_Of_Address (It.Typ)
then
Remove_Interp (I);
end if;
diff --git a/gcc/ada/sem_res.ads b/gcc/ada/sem_res.ads
index e94c36bbb1..0fd9f8d1d0 100644
--- a/gcc/ada/sem_res.ads
+++ b/gcc/ada/sem_res.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -47,34 +47,12 @@ package Sem_Res is
-- Resolve routines also complete the semantic analysis, and call the
-- expander for possible expansion of the completely type resolved node.
- procedure Resolve (N : Node_Id; Typ : Entity_Id);
- procedure Resolve (N : Node_Id; Typ : Entity_Id; Suppress : Check_Id);
- -- Top level type-checking procedure, called in a complete context. The
- -- construct N, which is a subexpression, has already been analyzed, and
- -- is required to be of type Typ given the analysis of the context (which
- -- uses the information gathered on the bottom up phase in Analyze). The
- -- resolve routines do various other processing, e.g. static evaluation.
- -- If a Suppress argument is present, then the resolution is done with the
- -- specified check suppressed (can be All_Checks to suppress all checks).
-
- procedure Resolve (N : Node_Id);
- -- A version of Resolve where the type to be used for resolution is
- -- taken from the Etype (N). This is commonly used in cases where the
- -- context does not add anything and the first pass of analysis found
- -- the correct expected type.
-
- procedure Resolve_Discrete_Subtype_Indication
- (N : Node_Id;
- Typ : Entity_Id);
- -- Resolve subtype indications in choices (case statements and
- -- aggregates) and in index constraints. Note that the resulting Etype
- -- of the subtype indication node is set to the Etype of the contained
- -- range (i.e. an Itype is not constructed for the actual subtype).
-
- procedure Resolve_Entry (Entry_Name : Node_Id);
- -- Find name of entry being called, and resolve prefix of name with its
- -- own type. For now we assume that the prefix cannot be overloaded and
- -- the name of the entry plays no role in the resolution.
+ procedure Ambiguous_Character (C : Node_Id);
+ -- Give list of candidate interpretations when a character literal cannot
+ -- be resolved, for example in a (useless) comparison such as 'A' = 'B'.
+ -- In Ada 95 the literals in question can be of type Character or Wide_
+ -- Character. In Ada 2005 Wide_Wide_Character is also a candidate. The
+ -- node may also be overloaded with user-defined character types.
procedure Analyze_And_Resolve (N : Node_Id);
procedure Analyze_And_Resolve (N : Node_Id; Typ : Entity_Id);
@@ -92,36 +70,58 @@ package Sem_Res is
-- is not present, then the Etype of the expression after the Analyze
-- call is used for the Resolve.
- procedure Ambiguous_Character (C : Node_Id);
- -- Give list of candidate interpretations when a character literal cannot
- -- be resolved, for example in a (useless) comparison such as 'A' = 'B'.
- -- In Ada 95 the literals in question can be of type Character or Wide_
- -- Character. In Ada 2005 Wide_Wide_Character is also a candidate. The
- -- node may also be overloaded with user-defined character types.
-
procedure Check_Parameterless_Call (N : Node_Id);
- -- Several forms of names can denote calls to entities without para-
- -- meters. The context determines whether the name denotes the entity
- -- or a call to it. When it is a call, the node must be rebuilt
- -- accordingly and reanalyzed to obtain possible interpretations.
+ -- Several forms of names can denote calls to entities without parameters.
+ -- The context determines whether the name denotes the entity or a call to
+ -- it. When it is a call, the node must be rebuilt accordingly and
+ -- reanalyzed to obtain possible interpretations.
--
-- The name may be that of an overloadable construct, or it can be an
-- explicit dereference of a prefix that denotes an access to subprogram.
-- In that case, we want to convert the name into a call only if the
- -- context requires the return type of the subprogram. Finally, a
+ -- context requires the return type of the subprogram. Finally, a
-- parameterless protected subprogram appears as a selected component.
--
-- The parameter T is the Typ for the corresponding resolve call.
procedure Preanalyze_And_Resolve (N : Node_Id; T : Entity_Id);
- -- Performs a pre-analysis of expression node N. During pre-analysis,
- -- N is analyzed and then resolved against type T, but no expansion
- -- is carried out for N or its children. For more info on pre-analysis
- -- read the spec of Sem.
+ -- Performs a pre-analysis of expression node N. During pre-analysis, N is
+ -- analyzed and then resolved against type T, but no expansion is carried
+ -- out for N or its children. For more info on pre-analysis read the spec
+ -- of Sem.
procedure Preanalyze_And_Resolve (N : Node_Id);
-- Same, but use type of node because context does not impose a single type
+ procedure Resolve (N : Node_Id; Typ : Entity_Id);
+ procedure Resolve (N : Node_Id; Typ : Entity_Id; Suppress : Check_Id);
+ -- Top-level type-checking procedure, called in a complete context. The
+ -- construct N, which is a subexpression, has already been analyzed, and
+ -- is required to be of type Typ given the analysis of the context (which
+ -- uses the information gathered on the bottom-up phase in Analyze). The
+ -- resolve routines do various other processing, e.g. static evaluation.
+ -- If a Suppress argument is present, then the resolution is done with the
+ -- specified check suppressed (can be All_Checks to suppress all checks).
+
+ procedure Resolve (N : Node_Id);
+ -- A version of Resolve where the type to be used for resolution is taken
+ -- from the Etype (N). This is commonly used in cases where the context
+ -- does not add anything and the first pass of analysis found the correct
+ -- expected type.
+
+ procedure Resolve_Discrete_Subtype_Indication
+ (N : Node_Id;
+ Typ : Entity_Id);
+ -- Resolve subtype indications in choices (case statements and aggregates)
+ -- and in index constraints. Note that the resulting Etype of the subtype_
+ -- indication node is set to the Etype of the contained range (i.e. an
+ -- Itype is not constructed for the actual subtype).
+
+ procedure Resolve_Entry (Entry_Name : Node_Id);
+ -- Find name of entry being called, and resolve prefix of name with its
+ -- own type. For now we assume that the prefix cannot be overloaded and
+ -- the name of the entry plays no role in the resolution.
+
function Valid_Conversion
(N : Node_Id;
Target : Entity_Id;
@@ -137,7 +137,7 @@ package Sem_Res is
private
procedure Resolve_Implicit_Type (N : Node_Id) renames Resolve;
pragma Inline (Resolve_Implicit_Type);
- -- We use this renaming to make the application of Inline very explicit
- -- to this version, since other versions of Resolve are not inlined.
+ -- We use this renaming to make the application of Inline very explicit to
+ -- this version, since other versions of Resolve are not inlined.
end Sem_Res;
diff --git a/gcc/ada/sem_type.adb b/gcc/ada/sem_type.adb
index f00639e0c4..26415ae47d 100644
--- a/gcc/ada/sem_type.adb
+++ b/gcc/ada/sem_type.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -307,7 +307,6 @@ package body Sem_Type is
else
Get_Next_Interp (I, It);
end if;
-
end loop;
All_Interp.Table (All_Interp.Last) := (Name, Typ, Abstr_Op);
@@ -638,8 +637,9 @@ package body Sem_Type is
H := Current_Entity (Ent);
while Present (H) loop
- exit when (not Is_Overloadable (H))
- and then Is_Immediately_Visible (H);
+ exit when
+ not Is_Overloadable (H)
+ and then Is_Immediately_Visible (H);
if Is_Immediately_Visible (H) and then H /= Ent then
@@ -1316,13 +1316,13 @@ package body Sem_Type is
-- the generic. Within the instance the actual is represented by a
-- constructed subprogram renaming.
- function Matches (Actual, Formal : Node_Id) return Boolean;
- -- Look for exact type match in an instance, to remove spurious
- -- ambiguities when two formal types have the same actual.
+ function Matches (Op : Node_Id; Func_Id : Entity_Id) return Boolean;
+ -- Determine whether function Func_Id is an exact match for binary or
+ -- unary operator Op.
function Operand_Type return Entity_Id;
- -- Determine type of operand for an equality operation, to apply
- -- Ada 2005 rules to equality on anonymous access types.
+ -- Determine type of operand for an equality operation, to apply Ada
+ -- 2005 rules to equality on anonymous access types.
function Standard_Operator return Boolean;
-- Check whether subprogram is predefined operator declared in Standard.
@@ -1412,14 +1412,82 @@ package body Sem_Type is
-- Matches --
-------------
- function Matches (Actual, Formal : Node_Id) return Boolean is
- T1 : constant Entity_Id := Etype (Actual);
- T2 : constant Entity_Id := Etype (Formal);
+ function Matches (Op : Node_Id; Func_Id : Entity_Id) return Boolean is
+ function Matching_Types
+ (Opnd_Typ : Entity_Id;
+ Formal_Typ : Entity_Id) return Boolean;
+ -- Determine whether operand type Opnd_Typ and formal parameter type
+ -- Formal_Typ are either the same or compatible.
+
+ --------------------
+ -- Matching_Types --
+ --------------------
+
+ function Matching_Types
+ (Opnd_Typ : Entity_Id;
+ Formal_Typ : Entity_Id) return Boolean
+ is
+ begin
+ -- A direct match
+
+ if Opnd_Typ = Formal_Typ then
+ return True;
+
+ -- Any integer type matches universal integer
+
+ elsif Opnd_Typ = Universal_Integer
+ and then Is_Integer_Type (Formal_Typ)
+ then
+ return True;
+
+ -- Any floating point type matches universal real
+
+ elsif Opnd_Typ = Universal_Real
+ and then Is_Floating_Point_Type (Formal_Typ)
+ then
+ return True;
+
+ -- The type of the formal parameter maps a generic actual type to
+ -- a generic formal type. If the operand type is the type being
+ -- mapped in an instance, then this is a match.
+
+ elsif Is_Generic_Actual_Type (Formal_Typ)
+ and then Etype (Formal_Typ) = Opnd_Typ
+ then
+ return True;
+
+ -- ??? There are possibly other cases to consider
+
+ else
+ return False;
+ end if;
+ end Matching_Types;
+
+ -- Local variables
+
+ F1 : constant Entity_Id := First_Formal (Func_Id);
+ F1_Typ : constant Entity_Id := Etype (F1);
+ F2 : constant Entity_Id := Next_Formal (F1);
+ F2_Typ : constant Entity_Id := Etype (F2);
+ Lop_Typ : constant Entity_Id := Etype (Left_Opnd (Op));
+ Rop_Typ : constant Entity_Id := Etype (Right_Opnd (Op));
+
+ -- Start of processing for Matches
+
begin
- return T1 = T2
- or else
- (Is_Numeric_Type (T2)
- and then (T1 = Universal_Real or else T1 = Universal_Integer));
+ if Lop_Typ = F1_Typ then
+ return Matching_Types (Rop_Typ, F2_Typ);
+
+ elsif Rop_Typ = F2_Typ then
+ return Matching_Types (Lop_Typ, F1_Typ);
+
+ -- Otherwise this is not a good match because each operand-formal
+ -- pair is compatible only on base-type basis, which is not specific
+ -- enough.
+
+ else
+ return False;
+ end if;
end Matches;
------------------
@@ -1538,9 +1606,9 @@ package body Sem_Type is
Act1 := Left_Opnd (N);
Act2 := Right_Opnd (N);
- -- Use type of second formal, so as to include
- -- exponentiation, where the exponent may be
- -- ambiguous and the result non-universal.
+ -- Use the type of the second formal, so as to include
+ -- exponentiation, where the exponent may be ambiguous and
+ -- the result non-universal.
Next_Formal (F1);
@@ -1550,8 +1618,10 @@ package body Sem_Type is
if Nkind (Act1) in N_Op
and then Is_Overloaded (Act1)
- and then Nkind_In (Left_Opnd (Act1), N_Integer_Literal,
- N_Real_Literal)
+ and then
+ (Nkind (Act1) in N_Unary_Op
+ or else Nkind_In (Left_Opnd (Act1), N_Integer_Literal,
+ N_Real_Literal))
and then Nkind_In (Right_Opnd (Act1), N_Integer_Literal,
N_Real_Literal)
and then Has_Compatible_Type (Act1, Standard_Boolean)
@@ -1697,6 +1767,7 @@ package body Sem_Type is
It1 := It;
Nam1 := It.Nam;
+
while I /= I2 loop
Get_Next_Interp (I, It);
end loop;
@@ -1751,17 +1822,16 @@ package body Sem_Type is
begin
Get_First_Interp (N, I, It);
while Present (It.Typ) loop
- if (Covers (Typ, It.Typ) or else Typ = Any_Type)
- and then
- (It.Typ = Universal_Integer
+ if (It.Typ = Universal_Integer
or else It.Typ = Universal_Real)
+ and then (Typ = Any_Type or else Covers (Typ, It.Typ))
then
return It;
- elsif Covers (Typ, It.Typ)
+ elsif Is_Numeric_Type (It.Typ)
and then Scope (It.Typ) = Standard_Standard
and then Scope (It.Nam) = Standard_Standard
- and then Is_Numeric_Type (It.Typ)
+ and then Covers (Typ, It.Typ)
then
Candidate := It;
end if;
@@ -1968,10 +2038,7 @@ package body Sem_Type is
end;
elsif Nkind (N) in N_Binary_Op then
- if Matches (Left_Opnd (N), First_Formal (Nam1))
- and then
- Matches (Right_Opnd (N), Next_Formal (First_Formal (Nam1)))
- then
+ if Matches (N, Nam1) then
return It1;
else
return It2;
@@ -2511,7 +2578,6 @@ package body Sem_Type is
loop
if Present (Interfaces (E))
- and then Present (Interfaces (E))
and then not Is_Empty_Elmt_List (Interfaces (E))
then
Elmt := First_Elmt (Interfaces (E));
@@ -2976,7 +3042,7 @@ package body Sem_Type is
-- New_Interps --
-----------------
- procedure New_Interps (N : Node_Id) is
+ procedure New_Interps (N : Node_Id) is
Map_Ptr : Int;
begin
@@ -3026,20 +3092,21 @@ package body Sem_Type is
---------------------------
function Operator_Matches_Spec (Op, New_S : Entity_Id) return Boolean is
- Op_Name : constant Name_Id := Chars (Op);
- T : constant Entity_Id := Etype (New_S);
- New_F : Entity_Id;
- Old_F : Entity_Id;
- Num : Int;
- T1 : Entity_Id;
- T2 : Entity_Id;
+ New_First_F : constant Entity_Id := First_Formal (New_S);
+ Op_Name : constant Name_Id := Chars (Op);
+ T : constant Entity_Id := Etype (New_S);
+ New_F : Entity_Id;
+ Num : Nat;
+ Old_F : Entity_Id;
+ T1 : Entity_Id;
+ T2 : Entity_Id;
begin
- -- To verify that a predefined operator matches a given signature,
- -- do a case analysis of the operator classes. Function can have one
- -- or two formals and must have the proper result type.
+ -- To verify that a predefined operator matches a given signature, do a
+ -- case analysis of the operator classes. Function can have one or two
+ -- formals and must have the proper result type.
- New_F := First_Formal (New_S);
+ New_F := New_First_F;
Old_F := First_Formal (Op);
Num := 0;
while Present (New_F) and then Present (Old_F) loop
@@ -3056,7 +3123,7 @@ package body Sem_Type is
-- Unary operators
elsif Num = 1 then
- T1 := Etype (First_Formal (New_S));
+ T1 := Etype (New_First_F);
if Nam_In (Op_Name, Name_Op_Subtract, Name_Op_Add, Name_Op_Abs) then
return Base_Type (T1) = Base_Type (T)
@@ -3073,8 +3140,8 @@ package body Sem_Type is
-- Binary operators
else
- T1 := Etype (First_Formal (New_S));
- T2 := Etype (Next_Formal (First_Formal (New_S)));
+ T1 := Etype (New_First_F);
+ T2 := Etype (Next_Formal (New_First_F));
if Nam_In (Op_Name, Name_Op_And, Name_Op_Or, Name_Op_Xor) then
return Base_Type (T1) = Base_Type (T2)
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index cc4a4fcded..93d8bd58d8 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -37,7 +37,6 @@ with Exp_Disp; use Exp_Disp;
with Exp_Util; use Exp_Util;
with Fname; use Fname;
with Freeze; use Freeze;
-with Ghost; use Ghost;
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
with Namet.Sp; use Namet.Sp;
@@ -52,7 +51,6 @@ with Sem_Aux; use Sem_Aux;
with Sem_Attr; use Sem_Attr;
with Sem_Ch6; use Sem_Ch6;
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_Prag; use Sem_Prag;
@@ -73,35 +71,6 @@ with GNAT.HTable; use GNAT.HTable;
package body Sem_Util is
- ----------------------------------------
- -- Global Variables for New_Copy_Tree --
- ----------------------------------------
-
- -- These global variables are used by New_Copy_Tree. See description of the
- -- body of this subprogram for details. Global variables can be safely used
- -- by New_Copy_Tree, since there is no case of a recursive call from the
- -- processing inside New_Copy_Tree.
-
- NCT_Hash_Threshold : constant := 20;
- -- If there are more than this number of pairs of entries in the map, then
- -- Hash_Tables_Used will be set, and the hash tables will be initialized
- -- and used for the searches.
-
- NCT_Hash_Tables_Used : Boolean := False;
- -- Set to True if hash tables are in use
-
- NCT_Table_Entries : Nat := 0;
- -- Count entries in table to see if threshold is reached
-
- NCT_Hash_Table_Setup : Boolean := False;
- -- Set to True if hash table contains data. We set this True if we setup
- -- the hash table with data, and leave it set permanently from then on,
- -- this is a signal that second and subsequent users of the hash table
- -- must clear the old entries before reuse.
-
- subtype NCT_Header_Num is Int range 0 .. 511;
- -- Defines range of headers in hash tables (512 headers)
-
-----------------------
-- Local Subprograms --
-----------------------
@@ -131,6 +100,24 @@ package body Sem_Util is
-- components in the selected variant to determine whether all of them
-- have a default.
+ function Old_Requires_Transient_Scope (Id : Entity_Id) return Boolean;
+ function New_Requires_Transient_Scope (Id : Entity_Id) return Boolean;
+ -- ???We retain the old and new algorithms for Requires_Transient_Scope for
+ -- the time being. New_Requires_Transient_Scope is used by default; the
+ -- debug switch -gnatdQ can be used to do Old_Requires_Transient_Scope
+ -- instead. The intent is to use this temporarily to measure before/after
+ -- efficiency. Note: when this temporary code is removed, the documentation
+ -- of dQ in debug.adb should be removed.
+
+ procedure Results_Differ
+ (Id : Entity_Id;
+ Old_Val : Boolean;
+ New_Val : Boolean);
+ -- ???Debugging code. Called when the Old_Val and New_Val differ. This
+ -- routine will be removed eventially when New_Requires_Transient_Scope
+ -- becomes Requires_Transient_Scope and Old_Requires_Transient_Scope is
+ -- eliminated.
+
------------------------------
-- Abstract_Interface_List --
------------------------------
@@ -272,11 +259,11 @@ package body Sem_Util is
function Address_Integer_Convert_OK (T1, T2 : Entity_Id) return Boolean is
begin
if Allow_Integer_Address
- and then ((Is_Descendent_Of_Address (T1)
+ and then ((Is_Descendant_Of_Address (T1)
and then Is_Private_Type (T1)
and then Is_Integer_Type (T2))
or else
- (Is_Descendent_Of_Address (T2)
+ (Is_Descendant_Of_Address (T2)
and then Is_Private_Type (T2)
and then Is_Integer_Type (T1)))
then
@@ -286,11 +273,54 @@ package body Sem_Util is
end if;
end Address_Integer_Convert_OK;
+ -------------------
+ -- Address_Value --
+ -------------------
+
+ function Address_Value (N : Node_Id) return Node_Id is
+ Expr : Node_Id := N;
+
+ begin
+ loop
+ -- For constant, get constant expression
+
+ if Is_Entity_Name (Expr)
+ and then Ekind (Entity (Expr)) = E_Constant
+ then
+ Expr := Constant_Value (Entity (Expr));
+
+ -- For unchecked conversion, get result to convert
+
+ elsif Nkind (Expr) = N_Unchecked_Type_Conversion then
+ Expr := Expression (Expr);
+
+ -- For (common case) of To_Address call, get argument
+
+ elsif Nkind (Expr) = N_Function_Call
+ and then Is_Entity_Name (Name (Expr))
+ and then Is_RTE (Entity (Name (Expr)), RE_To_Address)
+ then
+ Expr := First (Parameter_Associations (Expr));
+
+ if Nkind (Expr) = N_Parameter_Association then
+ Expr := Explicit_Actual_Parameter (Expr);
+ end if;
+
+ -- We finally have the real expression
+
+ else
+ exit;
+ end if;
+ end loop;
+
+ return Expr;
+ end Address_Value;
+
-----------------
-- Addressable --
-----------------
- -- For now, just 8/16/32/64. but analyze later if AAMP is special???
+ -- For now, just 8/16/32/64
function Addressable (V : Uint) return Boolean is
begin
@@ -326,21 +356,19 @@ package body Sem_Util is
-- Ada 2005 (AI-230): Generate a conversion to an anonymous access
-- component's type to force the appropriate accessibility checks.
- -- Ada 2005 (AI-231): Generate conversion to the null-excluding
- -- type to force the corresponding run-time check
+ -- Ada 2005 (AI-231): Generate conversion to the null-excluding type to
+ -- force the corresponding run-time check
if Is_Access_Type (Check_Typ)
- and then ((Is_Local_Anonymous_Access (Check_Typ))
- or else (Can_Never_Be_Null (Check_Typ)
- and then not Can_Never_Be_Null (Exp_Typ)))
+ and then Is_Local_Anonymous_Access (Check_Typ)
then
Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp)));
Analyze_And_Resolve (Exp, Check_Typ);
Check_Unset_Reference (Exp);
end if;
- -- This is really expansion activity, so make sure that expansion is
- -- on and is allowed. In GNATprove mode, we also want check flags to
+ -- What follows is really expansion activity, so check that expansion
+ -- is on and is allowed. In GNATprove mode, we also want check flags to
-- be added in the tree, so that the formal verification can rely on
-- those to be present. In GNATprove mode for formal verification, some
-- treatment typically only done during expansion needs to be performed
@@ -353,6 +381,13 @@ package body Sem_Util is
return;
end if;
+ if Is_Access_Type (Check_Typ)
+ and then Can_Never_Be_Null (Check_Typ)
+ and then not Can_Never_Be_Null (Exp_Typ)
+ then
+ Install_Null_Excluding_Check (Exp);
+ end if;
+
-- First check if we have to insert discriminant checks
if Has_Discriminants (Exp_Typ) then
@@ -599,7 +634,13 @@ package body Sem_Util is
Discard_Node
(Compile_Time_Constraint_Error (N, Msg, Ent, Loc, Warn => Warn));
- if not Rep then
+ -- In GNATprove mode, do not replace the node with an exception raised.
+ -- In such a case, either the call to Compile_Time_Constraint_Error
+ -- issues an error which stops analysis, or it issues a warning in
+ -- a few cases where a suitable check flag is set for GNATprove to
+ -- generate a check message.
+
+ if not Rep or GNATprove_Mode then
return;
end if;
@@ -1140,273 +1181,6 @@ package body Sem_Util is
return Decl;
end Build_Component_Subtype;
- ----------------------------------
- -- Build_Default_Init_Cond_Call --
- ----------------------------------
-
- function Build_Default_Init_Cond_Call
- (Loc : Source_Ptr;
- Obj_Id : Entity_Id;
- Typ : Entity_Id) return Node_Id
- is
- Proc_Id : constant Entity_Id := Default_Init_Cond_Procedure (Typ);
- Formal_Typ : constant Entity_Id := Etype (First_Formal (Proc_Id));
-
- begin
- return
- Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (Proc_Id, Loc),
- Parameter_Associations => New_List (
- Make_Unchecked_Type_Conversion (Loc,
- Subtype_Mark => New_Occurrence_Of (Formal_Typ, Loc),
- Expression => New_Occurrence_Of (Obj_Id, Loc))));
- end Build_Default_Init_Cond_Call;
-
- ----------------------------------------------
- -- Build_Default_Init_Cond_Procedure_Bodies --
- ----------------------------------------------
-
- procedure Build_Default_Init_Cond_Procedure_Bodies (Priv_Decls : List_Id) is
- procedure Build_Default_Init_Cond_Procedure_Body (Typ : Entity_Id);
- -- If type Typ is subject to pragma Default_Initial_Condition, build the
- -- body of the procedure which verifies the assumption of the pragma at
- -- run time. The generated body is added after the type declaration.
-
- --------------------------------------------
- -- Build_Default_Init_Cond_Procedure_Body --
- --------------------------------------------
-
- procedure Build_Default_Init_Cond_Procedure_Body (Typ : Entity_Id) is
- Param_Id : Entity_Id;
- -- The entity of the sole formal parameter of the default initial
- -- condition procedure.
-
- procedure Replace_Type_Reference (N : Node_Id);
- -- Replace a single reference to type Typ with a reference to formal
- -- parameter Param_Id.
-
- ----------------------------
- -- Replace_Type_Reference --
- ----------------------------
-
- procedure Replace_Type_Reference (N : Node_Id) is
- begin
- Rewrite (N, New_Occurrence_Of (Param_Id, Sloc (N)));
- end Replace_Type_Reference;
-
- procedure Replace_Type_References is
- new Replace_Type_References_Generic (Replace_Type_Reference);
-
- -- Local variables
-
- Loc : constant Source_Ptr := Sloc (Typ);
- Prag : constant Node_Id :=
- Get_Pragma (Typ, Pragma_Default_Initial_Condition);
- Proc_Id : constant Entity_Id := Default_Init_Cond_Procedure (Typ);
- Spec_Decl : constant Node_Id := Unit_Declaration_Node (Proc_Id);
- Body_Decl : Node_Id;
- Expr : Node_Id;
- Stmt : Node_Id;
-
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
-
- -- Start of processing for Build_Default_Init_Cond_Procedure_Body
-
- begin
- -- The procedure should be generated only for [sub]types subject to
- -- pragma Default_Initial_Condition. Types that inherit the pragma do
- -- not get this specialized procedure.
-
- pragma Assert (Has_Default_Init_Cond (Typ));
- pragma Assert (Present (Prag));
- pragma Assert (Present (Proc_Id));
-
- -- Nothing to do if the body was already built
-
- if Present (Corresponding_Body (Spec_Decl)) then
- return;
- end if;
-
- -- The related type may be subject to pragma Ghost. Set the mode now
- -- to ensure that the analysis and expansion produce Ghost nodes.
-
- Set_Ghost_Mode_From_Entity (Typ);
-
- Param_Id := First_Formal (Proc_Id);
-
- -- The pragma has an argument. Note that the argument is analyzed
- -- after all references to the current instance of the type are
- -- replaced.
-
- if Present (Pragma_Argument_Associations (Prag)) then
- Expr :=
- Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
-
- if Nkind (Expr) = N_Null then
- Stmt := Make_Null_Statement (Loc);
-
- -- Preserve the original argument of the pragma by replicating it.
- -- Replace all references to the current instance of the type with
- -- references to the formal parameter.
-
- else
- Expr := New_Copy_Tree (Expr);
- Replace_Type_References (Expr, Typ);
-
- -- Generate:
- -- pragma Check (Default_Initial_Condition, <Expr>);
-
- Stmt :=
- Make_Pragma (Loc,
- Pragma_Identifier =>
- Make_Identifier (Loc, Name_Check),
-
- Pragma_Argument_Associations => New_List (
- Make_Pragma_Argument_Association (Loc,
- Expression =>
- Make_Identifier (Loc,
- Chars => Name_Default_Initial_Condition)),
- Make_Pragma_Argument_Association (Loc,
- Expression => Expr)));
- end if;
-
- -- Otherwise the pragma appears without an argument
-
- else
- Stmt := Make_Null_Statement (Loc);
- end if;
-
- -- Generate:
- -- procedure <Typ>Default_Init_Cond (I : <Typ>) is
- -- begin
- -- <Stmt>;
- -- end <Typ>Default_Init_Cond;
-
- Body_Decl :=
- Make_Subprogram_Body (Loc,
- Specification =>
- Copy_Separate_Tree (Specification (Spec_Decl)),
- Declarations => Empty_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Stmt)));
-
- -- Link the spec and body of the default initial condition procedure
- -- to prevent the generation of a duplicate body.
-
- Set_Corresponding_Body (Spec_Decl, Defining_Entity (Body_Decl));
- Set_Corresponding_Spec (Body_Decl, Proc_Id);
-
- Insert_After_And_Analyze (Declaration_Node (Typ), Body_Decl);
- Ghost_Mode := Save_Ghost_Mode;
- end Build_Default_Init_Cond_Procedure_Body;
-
- -- Local variables
-
- Decl : Node_Id;
- Typ : Entity_Id;
-
- -- Start of processing for Build_Default_Init_Cond_Procedure_Bodies
-
- begin
- -- Inspect the private declarations looking for [sub]type declarations
-
- Decl := First (Priv_Decls);
- while Present (Decl) loop
- if Nkind_In (Decl, N_Full_Type_Declaration,
- N_Subtype_Declaration)
- then
- Typ := Defining_Entity (Decl);
-
- -- Guard against partially decorate types due to previous errors
-
- if Is_Type (Typ) then
-
- -- If the type is subject to pragma Default_Initial_Condition,
- -- generate the body of the internal procedure which verifies
- -- the assertion of the pragma at run time.
-
- if Has_Default_Init_Cond (Typ) then
- Build_Default_Init_Cond_Procedure_Body (Typ);
-
- -- A derived type inherits the default initial condition
- -- procedure from its parent type.
-
- elsif Has_Inherited_Default_Init_Cond (Typ) then
- Inherit_Default_Init_Cond_Procedure (Typ);
- end if;
- end if;
- end if;
-
- Next (Decl);
- end loop;
- end Build_Default_Init_Cond_Procedure_Bodies;
-
- ---------------------------------------------------
- -- Build_Default_Init_Cond_Procedure_Declaration --
- ---------------------------------------------------
-
- procedure Build_Default_Init_Cond_Procedure_Declaration (Typ : Entity_Id) is
- Loc : constant Source_Ptr := Sloc (Typ);
- Prag : constant Node_Id :=
- Get_Pragma (Typ, Pragma_Default_Initial_Condition);
-
- Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
-
- Proc_Id : Entity_Id;
-
- begin
- -- The procedure should be generated only for types subject to pragma
- -- Default_Initial_Condition. Types that inherit the pragma do not get
- -- this specialized procedure.
-
- pragma Assert (Has_Default_Init_Cond (Typ));
- pragma Assert (Present (Prag));
-
- -- Nothing to do if default initial condition procedure already built
-
- if Present (Default_Init_Cond_Procedure (Typ)) then
- return;
- end if;
-
- -- The related type may be subject to pragma Ghost. Set the mode now to
- -- ensure that the analysis and expansion produce Ghost nodes.
-
- Set_Ghost_Mode_From_Entity (Typ);
-
- Proc_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_External_Name (Chars (Typ), "Default_Init_Cond"));
-
- -- Associate default initial condition procedure with the private type
-
- Set_Ekind (Proc_Id, E_Procedure);
- Set_Is_Default_Init_Cond_Procedure (Proc_Id);
- Set_Default_Init_Cond_Procedure (Typ, Proc_Id);
-
- -- Mark the default initial condition procedure explicitly as Ghost
- -- because it does not come from source.
-
- if Ghost_Mode > None then
- Set_Is_Ghost_Entity (Proc_Id);
- end if;
-
- -- Generate:
- -- procedure <Typ>Default_Init_Cond (Inn : <Typ>);
-
- Insert_After_And_Analyze (Prag,
- Make_Subprogram_Declaration (Loc,
- Specification =>
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Proc_Id,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Make_Temporary (Loc, 'I'),
- Parameter_Type => New_Occurrence_Of (Typ, Loc))))));
-
- Ghost_Mode := Save_Ghost_Mode;
- end Build_Default_Init_Cond_Procedure_Declaration;
-
---------------------------
-- Build_Default_Subtype --
---------------------------
@@ -1656,9 +1430,17 @@ package body Sem_Util is
elsif ASIS_Mode then
return;
- -- See if we need elaboration entity. We always need it for the dynamic
- -- elaboration model, since it is needed to properly generate the PE
- -- exception for access before elaboration.
+ -- See if we need elaboration entity.
+
+ -- We always need an elaboration entity when preserving control flow, as
+ -- we want to remain explicit about the unit's elaboration order.
+
+ elsif Opt.Suppress_Control_Flow_Optimizations then
+ null;
+
+ -- We always need an elaboration entity for the dynamic elaboration
+ -- model, since it is needed to properly generate the PE exception for
+ -- access before elaboration.
elsif Dynamic_Elaboration_Checks then
null;
@@ -1745,6 +1527,11 @@ package body Sem_Util is
if Is_Entity_Name (Expr) then
Set_Etype (Expr, Etype (Entity (Expr)));
+ -- The designated entity will not be examined again when resolving
+ -- the dereference, so generate a reference to it now.
+
+ Generate_Reference (Entity (Expr), Expr);
+
elsif Nkind (Expr) = N_Function_Call then
-- If the name of the indexing function is overloaded, locate the one
@@ -1865,9 +1652,9 @@ package body Sem_Util is
return Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
end if;
- when N_Op_Divide |
- N_Op_Mod |
- N_Op_Rem
+ when N_Op_Divide
+ | N_Op_Mod
+ | N_Op_Rem
=>
if Do_Division_Check (Expr)
or else
@@ -1881,25 +1668,25 @@ package body Sem_Util is
Cannot_Raise_Constraint_Error (Right_Opnd (Expr));
end if;
- when N_Op_Add |
- N_Op_And |
- N_Op_Concat |
- N_Op_Eq |
- N_Op_Expon |
- N_Op_Ge |
- N_Op_Gt |
- N_Op_Le |
- N_Op_Lt |
- N_Op_Multiply |
- N_Op_Ne |
- N_Op_Or |
- N_Op_Rotate_Left |
- N_Op_Rotate_Right |
- N_Op_Shift_Left |
- N_Op_Shift_Right |
- N_Op_Shift_Right_Arithmetic |
- N_Op_Subtract |
- N_Op_Xor
+ when N_Op_Add
+ | N_Op_And
+ | N_Op_Concat
+ | N_Op_Eq
+ | N_Op_Expon
+ | N_Op_Ge
+ | N_Op_Gt
+ | N_Op_Le
+ | N_Op_Lt
+ | N_Op_Multiply
+ | N_Op_Ne
+ | N_Op_Or
+ | N_Op_Rotate_Left
+ | N_Op_Rotate_Right
+ | N_Op_Shift_Left
+ | N_Op_Shift_Right
+ | N_Op_Shift_Right_Arithmetic
+ | N_Op_Subtract
+ | N_Op_Xor
=>
if Do_Overflow_Check (Expr) then
return False;
@@ -2128,7 +1915,7 @@ package body Sem_Util is
T := Full_View (T);
end if;
- if Is_Descendent_Of_Address (T) or else Is_Limited_Type (T) then
+ if Is_Descendant_Of_Address (T) or else Is_Limited_Type (T) then
Set_Is_Pure (Subp_Id, False);
exit;
end if;
@@ -2177,9 +1964,9 @@ package body Sem_Util is
function Contains (List : Elist_Id; N : Node_Id) return Boolean;
-- Returns True if List has a node whose Entity is Entity (N)
- -------------------------
- -- Check_Function_Call --
- -------------------------
+ ----------------
+ -- Check_Node --
+ ----------------
function Check_Node (N : Node_Id) return Traverse_Result is
Is_Writable_Actual : Boolean := False;
@@ -2474,7 +2261,9 @@ package body Sem_Util is
Collect_Identifiers (Low_Bound (N));
Collect_Identifiers (High_Bound (N));
- when N_Op | N_Membership_Test =>
+ when N_Membership_Test
+ | N_Op
+ =>
declare
Expr : Node_Id;
@@ -2551,8 +2340,9 @@ package body Sem_Util is
end loop;
end;
- when N_Subprogram_Call |
- N_Entry_Call_Statement =>
+ when N_Entry_Call_Statement
+ | N_Subprogram_Call
+ =>
declare
Id : constant Entity_Id := Get_Function_Id (N);
Formal : Node_Id;
@@ -2573,8 +2363,9 @@ package body Sem_Util is
end loop;
end;
- when N_Aggregate |
- N_Extension_Aggregate =>
+ when N_Aggregate
+ | N_Extension_Aggregate
+ =>
declare
Assoc : Node_Id;
Choice : Node_Id;
@@ -2883,16 +2674,19 @@ package body Sem_Util is
while Present (Elmt_2) loop
if Entity (Node (Elmt_1)) = Entity (Node (Elmt_2)) then
case Nkind (Parent (Node (Elmt_2))) is
- when N_Aggregate |
- N_Component_Association |
- N_Component_Declaration =>
+ when N_Aggregate
+ | N_Component_Association
+ | N_Component_Declaration
+ =>
Error_Msg_N
("value may be affected by call in other "
& "component because they are evaluated "
& "in unspecified order",
Node (Elmt_2));
- when N_In | N_Not_In =>
+ when N_In
+ | N_Not_In
+ =>
Error_Msg_N
("value may be affected by call in other "
& "alternative because they are evaluated "
@@ -3537,8 +3331,8 @@ package body Sem_Util is
Prag := Pre_Post_Conditions (Items);
while Present (Prag) loop
- if Nam_In (Pragma_Name (Prag), Name_Postcondition,
- Name_Refined_Post)
+ if Nam_In (Pragma_Name_Unmapped (Prag),
+ Name_Postcondition, Name_Refined_Post)
and then not Error_Posted (Prag)
then
Post_Prag := Prag;
@@ -3602,6 +3396,172 @@ package body Sem_Util is
end if;
end Check_Result_And_Post_State;
+ -----------------------------
+ -- Check_State_Refinements --
+ -----------------------------
+
+ procedure Check_State_Refinements
+ (Context : Node_Id;
+ Is_Main_Unit : Boolean := False)
+ is
+ procedure Check_Package (Pack : Node_Id);
+ -- Verify that all abstract states of a [generic] package denoted by its
+ -- declarative node Pack have proper refinement. Recursively verify the
+ -- visible and private declarations of the [generic] package for other
+ -- nested packages.
+
+ procedure Check_Packages_In (Decls : List_Id);
+ -- Seek out [generic] package declarations within declarative list Decls
+ -- and verify the status of their abstract state refinement.
+
+ function SPARK_Mode_Is_Off (N : Node_Id) return Boolean;
+ -- Determine whether construct N is subject to pragma SPARK_Mode Off
+
+ -------------------
+ -- Check_Package --
+ -------------------
+
+ procedure Check_Package (Pack : Node_Id) is
+ Body_Id : constant Entity_Id := Corresponding_Body (Pack);
+ Spec : constant Node_Id := Specification (Pack);
+ States : constant Elist_Id :=
+ Abstract_States (Defining_Entity (Pack));
+
+ State_Elmt : Elmt_Id;
+ State_Id : Entity_Id;
+
+ begin
+ -- Do not verify proper state refinement when the package is subject
+ -- to pragma SPARK_Mode Off because this disables the requirement for
+ -- state refinement.
+
+ if SPARK_Mode_Is_Off (Pack) then
+ null;
+
+ -- State refinement can only occur in a completing packge body. Do
+ -- not verify proper state refinement when the body is subject to
+ -- pragma SPARK_Mode Off because this disables the requirement for
+ -- state refinement.
+
+ elsif Present (Body_Id)
+ and then SPARK_Mode_Is_Off (Unit_Declaration_Node (Body_Id))
+ then
+ null;
+
+ -- Do not verify proper state refinement when the package is an
+ -- instance as this check was already performed in the generic.
+
+ elsif Present (Generic_Parent (Spec)) then
+ null;
+
+ -- Otherwise examine the contents of the package
+
+ else
+ if Present (States) then
+ State_Elmt := First_Elmt (States);
+ while Present (State_Elmt) loop
+ State_Id := Node (State_Elmt);
+
+ -- Emit an error when a non-null state lacks any form of
+ -- refinement.
+
+ if not Is_Null_State (State_Id)
+ and then not Has_Null_Refinement (State_Id)
+ and then not Has_Non_Null_Refinement (State_Id)
+ then
+ Error_Msg_N ("state & requires refinement", State_Id);
+ end if;
+
+ Next_Elmt (State_Elmt);
+ end loop;
+ end if;
+
+ Check_Packages_In (Visible_Declarations (Spec));
+ Check_Packages_In (Private_Declarations (Spec));
+ end if;
+ end Check_Package;
+
+ -----------------------
+ -- Check_Packages_In --
+ -----------------------
+
+ procedure Check_Packages_In (Decls : List_Id) is
+ Decl : Node_Id;
+
+ begin
+ if Present (Decls) then
+ Decl := First (Decls);
+ while Present (Decl) loop
+ if Nkind_In (Decl, N_Generic_Package_Declaration,
+ N_Package_Declaration)
+ then
+ Check_Package (Decl);
+ end if;
+
+ Next (Decl);
+ end loop;
+ end if;
+ end Check_Packages_In;
+
+ -----------------------
+ -- SPARK_Mode_Is_Off --
+ -----------------------
+
+ function SPARK_Mode_Is_Off (N : Node_Id) return Boolean is
+ Prag : constant Node_Id := SPARK_Pragma (Defining_Entity (N));
+
+ begin
+ return
+ Present (Prag) and then Get_SPARK_Mode_From_Annotation (Prag) = Off;
+ end SPARK_Mode_Is_Off;
+
+ -- Start of processing for Check_State_Refinements
+
+ begin
+ -- A block may declare a nested package
+
+ if Nkind (Context) = N_Block_Statement then
+ Check_Packages_In (Declarations (Context));
+
+ -- An entry, protected, subprogram, or task body may declare a nested
+ -- package.
+
+ elsif Nkind_In (Context, N_Entry_Body,
+ N_Protected_Body,
+ N_Subprogram_Body,
+ N_Task_Body)
+ then
+ -- Do not verify proper state refinement when the body is subject to
+ -- pragma SPARK_Mode Off because this disables the requirement for
+ -- state refinement.
+
+ if not SPARK_Mode_Is_Off (Context) then
+ Check_Packages_In (Declarations (Context));
+ end if;
+
+ -- A package body may declare a nested package
+
+ elsif Nkind (Context) = N_Package_Body then
+ Check_Package (Unit_Declaration_Node (Corresponding_Spec (Context)));
+
+ -- Do not verify proper state refinement when the body is subject to
+ -- pragma SPARK_Mode Off because this disables the requirement for
+ -- state refinement.
+
+ if not SPARK_Mode_Is_Off (Context) then
+ Check_Packages_In (Declarations (Context));
+ end if;
+
+ -- A library level [generic] package may declare a nested package
+
+ elsif Nkind_In (Context, N_Generic_Package_Declaration,
+ N_Package_Declaration)
+ and then Is_Main_Unit
+ then
+ Check_Package (Context);
+ end if;
+ end Check_State_Refinements;
+
------------------------------
-- Check_Unprotected_Access --
------------------------------
@@ -3882,6 +3842,19 @@ package body Sem_Util is
end if;
end Check_Unused_Body_States;
+ -----------------
+ -- Choice_List --
+ -----------------
+
+ function Choice_List (N : Node_Id) return List_Id is
+ begin
+ if Nkind (N) = N_Iterated_Component_Association then
+ return Discrete_Choices (N);
+ else
+ return Choices (N);
+ end if;
+ end Choice_List;
+
-------------------------
-- Collect_Body_States --
-------------------------
@@ -4049,7 +4022,11 @@ package body Sem_Util is
Full_T := Full_View (Typ);
if Ekind (Full_T) = E_Record_Subtype then
- Full_T := Full_View (Etype (Typ));
+ Full_T := Etype (Typ);
+
+ if Present (Full_View (Full_T)) then
+ Full_T := Full_View (Full_T);
+ end if;
end if;
end if;
@@ -4574,9 +4551,16 @@ package body Sem_Util is
begin
-- If this is a warning, convert it into an error if we are in code
- -- subject to SPARK_Mode being set ON.
+ -- subject to SPARK_Mode being set On, unless Warn is True to force a
+ -- warning. The rationale is that a compile-time constraint error should
+ -- lead to an error instead of a warning when SPARK_Mode is On, but in
+ -- a few cases we prefer to issue a warning and generate both a suitable
+ -- run-time error in GNAT and a suitable check message in GNATprove.
+ -- Those cases are those that likely correspond to deactivated SPARK
+ -- code, so that this kind of code can be compiled and analyzed instead
+ -- of being rejected.
- Error_Msg_Warn := SPARK_Mode /= On;
+ Error_Msg_Warn := Warn or SPARK_Mode /= On;
-- A static constraint error in an instance body is not a fatal error.
-- we choose to inhibit the message altogether, because there is no
@@ -4598,7 +4582,7 @@ package body Sem_Util is
Msgl := Msg'Length;
for J in 1 .. Msgl loop
- if Msg (J) = '?' and then (J = 1 or else Msg (J) /= ''') then
+ if Msg (J) = '?' and then (J = 1 or else Msg (J - 1) /= ''') then
Msgc (J) := '<';
else
Msgc (J) := Msg (J);
@@ -4648,8 +4632,6 @@ package body Sem_Util is
-- evaluated.
if not Is_Statically_Unevaluated (N) then
- Error_Msg_Warn := SPARK_Mode /= On;
-
if Present (Ent) then
Error_Msg_NEL (Msgc (1 .. Msgl), N, Ent, Eloc);
else
@@ -4988,6 +4970,25 @@ package body Sem_Util is
return Plist;
end Copy_Parameter_List;
+ ----------------------------
+ -- Copy_SPARK_Mode_Aspect --
+ ----------------------------
+
+ procedure Copy_SPARK_Mode_Aspect (From : Node_Id; To : Node_Id) is
+ pragma Assert (not Has_Aspects (To));
+ Asp : Node_Id;
+
+ begin
+ if Has_Aspects (From) then
+ Asp := Find_Aspect (Defining_Entity (From), Aspect_SPARK_Mode);
+
+ if Present (Asp) then
+ Set_Aspect_Specifications (To, New_List (New_Copy_Tree (Asp)));
+ Set_Has_Aspects (To, True);
+ end if;
+ end if;
+ end Copy_SPARK_Mode_Aspect;
+
--------------------------
-- Copy_Subprogram_Spec --
--------------------------
@@ -5132,6 +5133,29 @@ package body Sem_Util is
end if;
end Current_Scope;
+ ----------------------------
+ -- Current_Scope_No_Loops --
+ ----------------------------
+
+ function Current_Scope_No_Loops return Entity_Id is
+ S : Entity_Id;
+
+ begin
+ -- Examine the scope stack starting from the current scope and skip any
+ -- internally generated loops.
+
+ S := Current_Scope;
+ while Present (S) and then S /= Standard_Standard loop
+ if Ekind (S) = E_Loop and then not Comes_From_Source (S) then
+ S := Scope (S);
+ else
+ exit;
+ end if;
+ end loop;
+
+ return S;
+ end Current_Scope_No_Loops;
+
------------------------
-- Current_Subprogram --
------------------------
@@ -5187,67 +5211,68 @@ package body Sem_Util is
begin
case Nkind (N) is
- when N_Abstract_Subprogram_Declaration |
- N_Expression_Function |
- N_Formal_Subprogram_Declaration |
- N_Generic_Package_Declaration |
- N_Generic_Subprogram_Declaration |
- N_Package_Declaration |
- N_Subprogram_Body |
- N_Subprogram_Body_Stub |
- N_Subprogram_Declaration |
- N_Subprogram_Renaming_Declaration
+ when N_Abstract_Subprogram_Declaration
+ | N_Expression_Function
+ | N_Formal_Subprogram_Declaration
+ | N_Generic_Package_Declaration
+ | N_Generic_Subprogram_Declaration
+ | N_Package_Declaration
+ | N_Subprogram_Body
+ | N_Subprogram_Body_Stub
+ | N_Subprogram_Declaration
+ | N_Subprogram_Renaming_Declaration
=>
return Defining_Entity (Specification (N));
- when N_Component_Declaration |
- N_Defining_Program_Unit_Name |
- N_Discriminant_Specification |
- N_Entry_Body |
- N_Entry_Declaration |
- N_Entry_Index_Specification |
- N_Exception_Declaration |
- N_Exception_Renaming_Declaration |
- N_Formal_Object_Declaration |
- N_Formal_Package_Declaration |
- N_Formal_Type_Declaration |
- N_Full_Type_Declaration |
- N_Implicit_Label_Declaration |
- N_Incomplete_Type_Declaration |
- N_Loop_Parameter_Specification |
- N_Number_Declaration |
- N_Object_Declaration |
- N_Object_Renaming_Declaration |
- N_Package_Body_Stub |
- N_Parameter_Specification |
- N_Private_Extension_Declaration |
- N_Private_Type_Declaration |
- N_Protected_Body |
- N_Protected_Body_Stub |
- N_Protected_Type_Declaration |
- N_Single_Protected_Declaration |
- N_Single_Task_Declaration |
- N_Subtype_Declaration |
- N_Task_Body |
- N_Task_Body_Stub |
- N_Task_Type_Declaration
+ when N_Component_Declaration
+ | N_Defining_Program_Unit_Name
+ | N_Discriminant_Specification
+ | N_Entry_Body
+ | N_Entry_Declaration
+ | N_Entry_Index_Specification
+ | N_Exception_Declaration
+ | N_Exception_Renaming_Declaration
+ | N_Formal_Object_Declaration
+ | N_Formal_Package_Declaration
+ | N_Formal_Type_Declaration
+ | N_Full_Type_Declaration
+ | N_Implicit_Label_Declaration
+ | N_Incomplete_Type_Declaration
+ | N_Iterator_Specification
+ | N_Loop_Parameter_Specification
+ | N_Number_Declaration
+ | N_Object_Declaration
+ | N_Object_Renaming_Declaration
+ | N_Package_Body_Stub
+ | N_Parameter_Specification
+ | N_Private_Extension_Declaration
+ | N_Private_Type_Declaration
+ | N_Protected_Body
+ | N_Protected_Body_Stub
+ | N_Protected_Type_Declaration
+ | N_Single_Protected_Declaration
+ | N_Single_Task_Declaration
+ | N_Subtype_Declaration
+ | N_Task_Body
+ | N_Task_Body_Stub
+ | N_Task_Type_Declaration
=>
return Defining_Identifier (N);
when N_Subunit =>
return Defining_Entity (Proper_Body (N));
- when N_Function_Instantiation |
- N_Function_Specification |
- N_Generic_Function_Renaming_Declaration |
- N_Generic_Package_Renaming_Declaration |
- N_Generic_Procedure_Renaming_Declaration |
- N_Package_Body |
- N_Package_Instantiation |
- N_Package_Renaming_Declaration |
- N_Package_Specification |
- N_Procedure_Instantiation |
- N_Procedure_Specification
+ when N_Function_Instantiation
+ | N_Function_Specification
+ | N_Generic_Function_Renaming_Declaration
+ | N_Generic_Package_Renaming_Declaration
+ | N_Generic_Procedure_Renaming_Declaration
+ | N_Package_Body
+ | N_Package_Instantiation
+ | N_Package_Renaming_Declaration
+ | N_Package_Specification
+ | N_Procedure_Instantiation
+ | N_Procedure_Specification
=>
declare
Nam : constant Node_Id := Defining_Unit_Name (N);
@@ -5276,8 +5301,9 @@ package body Sem_Util is
end if;
end;
- when N_Block_Statement |
- N_Loop_Statement =>
+ when N_Block_Statement
+ | N_Loop_Statement
+ =>
return Entity (Identifier (N));
when others =>
@@ -5286,7 +5312,6 @@ package body Sem_Util is
else
raise Program_Error;
end if;
-
end case;
end Defining_Entity;
@@ -5604,7 +5629,7 @@ package body Sem_Util is
then
declare
Root1, Root2 : Node_Id;
- Depth1, Depth2 : Int := 0;
+ Depth1, Depth2 : Nat := 0;
begin
Root1 := Prefix (A1);
@@ -5822,8 +5847,9 @@ package body Sem_Util is
-- Treat the unchecked attributes as library-level
- when Attribute_Unchecked_Access |
- Attribute_Unrestricted_Access =>
+ when Attribute_Unchecked_Access
+ | Attribute_Unrestricted_Access
+ =>
return Make_Level_Literal (Scope_Depth (Standard_Standard));
-- No other access-valued attributes
@@ -6069,6 +6095,7 @@ package body Sem_Util is
Encl_Unit := Library_Unit (Encl_Unit);
end loop;
+ pragma Assert (Nkind (Encl_Unit) = N_Compilation_Unit);
return Encl_Unit;
end Enclosing_Lib_Unit_Node;
@@ -6247,9 +6274,9 @@ package body Sem_Util is
or else Is_Internal (E)
then
declare
+ Decl : constant Node_Id := Parent (E);
Prev : Entity_Id;
Prev_Vis : Entity_Id;
- Decl : constant Node_Id := Parent (E);
begin
-- If E is an implicit declaration, it cannot be the first
@@ -6290,7 +6317,7 @@ package body Sem_Util is
end loop;
end if;
- if Present (Prev_Vis) then
+ if Present (Prev_Vis) then
-- Skip E in the visibility chain
@@ -6655,6 +6682,36 @@ package body Sem_Util is
end if;
end Explain_Limited_Type;
+ ---------------------------------------
+ -- Expression_Of_Expression_Function --
+ ---------------------------------------
+
+ function Expression_Of_Expression_Function
+ (Subp : Entity_Id) return Node_Id
+ is
+ Expr_Func : Node_Id;
+
+ begin
+ pragma Assert (Is_Expression_Function_Or_Completion (Subp));
+
+ if Nkind (Original_Node (Subprogram_Spec (Subp))) =
+ N_Expression_Function
+ then
+ Expr_Func := Original_Node (Subprogram_Spec (Subp));
+
+ elsif Nkind (Original_Node (Subprogram_Body (Subp))) =
+ N_Expression_Function
+ then
+ Expr_Func := Original_Node (Subprogram_Body (Subp));
+
+ else
+ pragma Assert (False);
+ null;
+ end if;
+
+ return Original_Node (Expression (Expr_Func));
+ end Expression_Of_Expression_Function;
+
-------------------------------
-- Extensions_Visible_Status --
-------------------------------
@@ -6940,7 +6997,7 @@ package body Sem_Util is
end if;
while Present (Old_Disc) and then Present (New_Disc) loop
- if Old_Disc = Par_Disc then
+ if Old_Disc = Par_Disc then
return New_Disc;
end if;
@@ -7293,11 +7350,10 @@ package body Sem_Util is
pragma Assert (Present (Alt));
end loop Search;
- -- The above loop *must* terminate by finding a match, since
- -- we know the case statement is valid, and the value of the
- -- expression is known at compile time. When we fall out of
- -- the loop, Alt points to the alternative that we know will
- -- be selected at run time.
+ -- The above loop *must* terminate by finding a match, since we know the
+ -- case statement is valid, and the value of the expression is known at
+ -- compile time. When we fall out of the loop, Alt points to the
+ -- alternative that we know will be selected at run time.
return Alt;
end Find_Static_Alternative;
@@ -7575,7 +7631,14 @@ package body Sem_Util is
end loop Find_Discrete_Value;
end Search_For_Discriminant_Value;
- if No (Variant) then
+ -- The case statement must include a variant that corresponds to the
+ -- value of the discriminant, unless the discriminant type has a
+ -- static predicate. In that case the absence of an others_choice that
+ -- would cover this value becomes a run-time error (3.8,1 (21.1/2)).
+
+ if No (Variant)
+ and then not Has_Static_Predicate (Etype (Discrim_Name))
+ then
Error_Msg_NE
("value of discriminant & is out of range", Discrim_Value, Discrim);
Report_Errors := True;
@@ -7586,8 +7649,10 @@ package body Sem_Util is
-- components to the Into list. The nested components are part of
-- the same record type.
- Gather_Components
- (Typ, Component_List (Variant), Governed_By, Into, Report_Errors);
+ if Present (Variant) then
+ Gather_Components
+ (Typ, Component_List (Variant), Governed_By, Into, Report_Errors);
+ end if;
end Gather_Components;
------------------------
@@ -7841,10 +7906,10 @@ package body Sem_Util is
return Entity (N);
else
case Nkind (N) is
- when N_Indexed_Component |
- N_Slice |
- N_Selected_Component =>
-
+ when N_Indexed_Component
+ | N_Selected_Component
+ | N_Slice
+ =>
-- If not generating code, a dereference may be left implicit.
-- In thoses cases, return Empty.
@@ -7874,6 +7939,7 @@ package body Sem_Util is
is
Btyp : Entity_Id := Base_Type (T);
Lit : Node_Id;
+ LLoc : Source_Ptr;
begin
-- In the case where the literal is of type Character, Wide_Character
@@ -7884,6 +7950,7 @@ package body Sem_Util is
if Is_Standard_Character_Type (T) then
Set_Character_Literal_Name (UI_To_CC (Pos));
+
return
Make_Character_Literal (Loc,
Chars => Name_Find,
@@ -7901,9 +7968,26 @@ package body Sem_Util is
Lit := First_Literal (Btyp);
for J in 1 .. UI_To_Int (Pos) loop
Next_Literal (Lit);
+
+ -- If Lit is Empty, Pos is not in range, so raise Constraint_Error
+ -- inside the loop to avoid calling Next_Literal on Empty.
+
+ if No (Lit) then
+ raise Constraint_Error;
+ end if;
end loop;
- return New_Occurrence_Of (Lit, Loc);
+ -- Create a new node from Lit, with source location provided by Loc
+ -- if not equal to No_Location, or by copying the source location of
+ -- Lit otherwise.
+
+ LLoc := Loc;
+
+ if LLoc = No_Location then
+ LLoc := Sloc (Lit);
+ end if;
+
+ return New_Occurrence_Of (Lit, LLoc);
end if;
end Get_Enum_Lit_From_Pos;
@@ -7974,9 +8058,38 @@ package body Sem_Util is
-- Get_Index_Bounds --
----------------------
- procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id) is
+ procedure Get_Index_Bounds
+ (N : Node_Id;
+ L : out Node_Id;
+ H : out Node_Id;
+ Use_Full_View : Boolean := False)
+ is
+ function Scalar_Range_Of_Type (Typ : Entity_Id) return Node_Id;
+ -- Obtain the scalar range of type Typ. If flag Use_Full_View is set and
+ -- Typ qualifies, the scalar range is obtained from the full view of the
+ -- type.
+
+ --------------------------
+ -- Scalar_Range_Of_Type --
+ --------------------------
+
+ function Scalar_Range_Of_Type (Typ : Entity_Id) return Node_Id is
+ T : Entity_Id := Typ;
+
+ begin
+ if Use_Full_View and then Present (Full_View (T)) then
+ T := Full_View (T);
+ end if;
+
+ return Scalar_Range (T);
+ end Scalar_Range_Of_Type;
+
+ -- Local variables
+
Kind : constant Node_Kind := Nkind (N);
- R : Node_Id;
+ Rng : Node_Id;
+
+ -- Start of processing for Get_Index_Bounds
begin
if Kind = N_Range then
@@ -7984,9 +8097,9 @@ package body Sem_Util is
H := High_Bound (N);
elsif Kind = N_Subtype_Indication then
- R := Range_Expression (Constraint (N));
+ Rng := Range_Expression (Constraint (N));
- if R = Error then
+ if Rng = Error then
L := Error;
H := Error;
return;
@@ -7997,16 +8110,18 @@ package body Sem_Util is
end if;
elsif Is_Entity_Name (N) and then Is_Type (Entity (N)) then
- if Error_Posted (Scalar_Range (Entity (N))) then
+ Rng := Scalar_Range_Of_Type (Entity (N));
+
+ if Error_Posted (Rng) then
L := Error;
H := Error;
- elsif Nkind (Scalar_Range (Entity (N))) = N_Subtype_Indication then
- Get_Index_Bounds (Scalar_Range (Entity (N)), L, H);
+ elsif Nkind (Rng) = N_Subtype_Indication then
+ Get_Index_Bounds (Rng, L, H);
else
- L := Low_Bound (Scalar_Range (Entity (N)));
- H := High_Bound (Scalar_Range (Entity (N)));
+ L := Low_Bound (Rng);
+ H := High_Bound (Rng);
end if;
else
@@ -8062,6 +8177,25 @@ package body Sem_Util is
pragma Assert (Name_Buffer (Name_Len + 1) = ' ');
end Get_Library_Unit_Name_String;
+ --------------------------
+ -- Get_Max_Queue_Length --
+ --------------------------
+
+ function Get_Max_Queue_Length (Id : Entity_Id) return Uint is
+ pragma Assert (Is_Entry (Id));
+ Prag : constant Entity_Id := Get_Pragma (Id, Pragma_Max_Queue_Length);
+
+ begin
+ -- A value of 0 represents no maximum specified, and entries and entry
+ -- families with no Max_Queue_Length aspect or pragma default to it.
+
+ if not Present (Prag) then
+ return Uint_0;
+ end if;
+
+ return Intval (Expression (First (Pragma_Argument_Associations (Prag))));
+ end Get_Max_Queue_Length;
+
------------------------
-- Get_Name_Entity_Id --
------------------------
@@ -8106,9 +8240,76 @@ package body Sem_Util is
function Get_Pragma_Id (N : Node_Id) return Pragma_Id is
begin
- return Get_Pragma_Id (Pragma_Name (N));
+ return Get_Pragma_Id (Pragma_Name_Unmapped (N));
end Get_Pragma_Id;
+ ------------------------
+ -- Get_Qualified_Name --
+ ------------------------
+
+ function Get_Qualified_Name
+ (Id : Entity_Id;
+ Suffix : Entity_Id := Empty) return Name_Id
+ is
+ Suffix_Nam : Name_Id := No_Name;
+
+ begin
+ if Present (Suffix) then
+ Suffix_Nam := Chars (Suffix);
+ end if;
+
+ return Get_Qualified_Name (Chars (Id), Suffix_Nam, Scope (Id));
+ end Get_Qualified_Name;
+
+ function Get_Qualified_Name
+ (Nam : Name_Id;
+ Suffix : Name_Id := No_Name;
+ Scop : Entity_Id := Current_Scope) return Name_Id
+ is
+ procedure Add_Scope (S : Entity_Id);
+ -- Add the fully qualified form of scope S to the name buffer. The
+ -- format is:
+ -- s-1__s__
+
+ ---------------
+ -- Add_Scope --
+ ---------------
+
+ procedure Add_Scope (S : Entity_Id) is
+ begin
+ if S = Empty then
+ null;
+
+ elsif S = Standard_Standard then
+ null;
+
+ else
+ Add_Scope (Scope (S));
+ Get_Name_String_And_Append (Chars (S));
+ Add_Str_To_Name_Buffer ("__");
+ end if;
+ end Add_Scope;
+
+ -- Start of processing for Get_Qualified_Name
+
+ begin
+ Name_Len := 0;
+ Add_Scope (Scop);
+
+ -- Append the base name after all scopes have been chained
+
+ Get_Name_String_And_Append (Nam);
+
+ -- Append the suffix (if present)
+
+ if Suffix /= No_Name then
+ Add_Str_To_Name_Buffer ("__");
+ Get_Name_String_And_Append (Suffix);
+ end if;
+
+ return Name_Find;
+ end Get_Qualified_Name;
+
-----------------------
-- Get_Reason_String --
-----------------------
@@ -8310,6 +8511,71 @@ package body Sem_Util is
return Empty;
end Get_User_Defined_Eq;
+ ---------------
+ -- Get_Views --
+ ---------------
+
+ procedure Get_Views
+ (Typ : Entity_Id;
+ Priv_Typ : out Entity_Id;
+ Full_Typ : out Entity_Id;
+ Full_Base : out Entity_Id;
+ CRec_Typ : out Entity_Id)
+ is
+ IP_View : Entity_Id;
+
+ begin
+ -- Assume that none of the views can be recovered
+
+ Priv_Typ := Empty;
+ Full_Typ := Empty;
+ Full_Base := Empty;
+ CRec_Typ := Empty;
+
+ -- The input type is the corresponding record type of a protected or a
+ -- task type.
+
+ if Ekind (Typ) = E_Record_Type
+ and then Is_Concurrent_Record_Type (Typ)
+ then
+ CRec_Typ := Typ;
+ Full_Typ := Corresponding_Concurrent_Type (CRec_Typ);
+ Full_Base := Base_Type (Full_Typ);
+ Priv_Typ := Incomplete_Or_Partial_View (Full_Typ);
+
+ -- Otherwise the input type denotes an arbitrary type
+
+ else
+ IP_View := Incomplete_Or_Partial_View (Typ);
+
+ -- The input type denotes the full view of a private type
+
+ if Present (IP_View) then
+ Priv_Typ := IP_View;
+ Full_Typ := Typ;
+
+ -- The input type is a private type
+
+ elsif Is_Private_Type (Typ) then
+ Priv_Typ := Typ;
+ Full_Typ := Full_View (Priv_Typ);
+
+ -- Otherwise the input type does not have any views
+
+ else
+ Full_Typ := Typ;
+ end if;
+
+ if Present (Full_Typ) then
+ Full_Base := Base_Type (Full_Typ);
+
+ if Ekind_In (Full_Typ, E_Protected_Type, E_Task_Type) then
+ CRec_Typ := Corresponding_Record_Type (Full_Typ);
+ end if;
+ end if;
+ end if;
+ end Get_Views;
+
-----------------------
-- Has_Access_Values --
-----------------------
@@ -8491,7 +8757,6 @@ package body Sem_Util is
elsif Nkind (Expr) = N_Indexed_Component then
declare
Typ : constant Entity_Id := Etype (Prefix (Expr));
- Ind : constant Node_Id := First_Index (Typ);
begin
-- Packing generates unknown alignment if layout is not done
@@ -8500,22 +8765,12 @@ package body Sem_Util is
Set_Result (Unknown);
end if;
- -- Check prefix and component offset
+ -- Check prefix and component offset (or at least size)
Check_Prefix;
- Offs := Component_Size (Typ);
-
- -- Small optimization: compute the full offset when possible
-
- if Offs /= No_Uint
- and then Offs > Uint_0
- and then Present (Ind)
- and then Nkind (Ind) = N_Range
- and then Compile_Time_Known_Value (Low_Bound (Ind))
- and then Compile_Time_Known_Value (First (Expressions (Expr)))
- then
- Offs := Offs * (Expr_Value (First (Expressions (Expr)))
- - Expr_Value (Low_Bound ((Ind))));
+ Offs := Indexed_Component_Bit_Offset (Expr);
+ if Offs = No_Uint then
+ Offs := Component_Size (Typ);
end if;
end;
end if;
@@ -8768,10 +9023,10 @@ package body Sem_Util is
Assn := First (Constraints (Constr));
while Present (Assn) loop
case Nkind (Assn) is
- when N_Subtype_Indication |
- N_Range |
- N_Identifier
- =>
+ when N_Identifier
+ | N_Range
+ | N_Subtype_Indication
+ =>
if Depends_On_Discriminant (Assn) then
return True;
end if;
@@ -8835,6 +9090,10 @@ package body Sem_Util is
(Item_Id : Entity_Id;
Property : Name_Id) return Boolean
is
+ function Protected_Object_Has_Enabled_Property return Boolean;
+ -- Determine whether a protected object denoted by Item_Id has the
+ -- property enabled.
+
function State_Has_Enabled_Property return Boolean;
-- Determine whether a state denoted by Item_Id has the property enabled
@@ -8842,6 +9101,44 @@ package body Sem_Util is
-- Determine whether a variable denoted by Item_Id has the property
-- enabled.
+ -------------------------------------------
+ -- Protected_Object_Has_Enabled_Property --
+ -------------------------------------------
+
+ function Protected_Object_Has_Enabled_Property return Boolean is
+ Constits : constant Elist_Id := Part_Of_Constituents (Item_Id);
+ Constit_Elmt : Elmt_Id;
+ Constit_Id : Entity_Id;
+
+ begin
+ -- Protected objects always have the properties Async_Readers and
+ -- Async_Writers (SPARK RM 7.1.2(16)).
+
+ if Property = Name_Async_Readers
+ or else Property = Name_Async_Writers
+ then
+ return True;
+
+ -- Protected objects that have Part_Of components also inherit their
+ -- properties Effective_Reads and Effective_Writes
+ -- (SPARK RM 7.1.2(16)).
+
+ elsif Present (Constits) then
+ Constit_Elmt := First_Elmt (Constits);
+ while Present (Constit_Elmt) loop
+ Constit_Id := Node (Constit_Elmt);
+
+ if Has_Enabled_Property (Constit_Id, Property) then
+ return True;
+ end if;
+
+ Next_Elmt (Constit_Elmt);
+ end loop;
+ end if;
+
+ return False;
+ end Protected_Object_Has_Enabled_Property;
+
--------------------------------
-- State_Has_Enabled_Property --
--------------------------------
@@ -9019,7 +9316,11 @@ package body Sem_Util is
-- The implicit case lacks all property pragmas
elsif No (AR) and then No (AW) and then No (ER) and then No (EW) then
- return True;
+ if Is_Protected_Type (Etype (Item_Id)) then
+ return Protected_Object_Has_Enabled_Property;
+ else
+ return True;
+ end if;
else
return False;
@@ -9038,6 +9339,14 @@ package body Sem_Util is
elsif Ekind (Item_Id) = E_Variable then
return Variable_Has_Enabled_Property;
+ -- By default, protected objects only have the properties Async_Readers
+ -- and Async_Writers. If they have Part_Of components, they also inherit
+ -- their properties Effective_Reads and Effective_Writes
+ -- (SPARK RM 7.1.2(16)).
+
+ elsif Ekind (Item_Id) = E_Protected_Object then
+ return Protected_Object_Has_Enabled_Property;
+
-- Otherwise a property is enabled when the related item is effectively
-- volatile.
@@ -9051,39 +9360,20 @@ package body Sem_Util is
-------------------------------------
function Has_Full_Default_Initialization (Typ : Entity_Id) return Boolean is
- Arg : Node_Id;
Comp : Entity_Id;
Prag : Node_Id;
begin
- -- A private type and its full view is fully default initialized when it
- -- is subject to pragma Default_Initial_Condition without an argument or
- -- with a non-null argument. Since any type may act as the full view of
- -- a private type, this check must be performed prior to the specialized
- -- tests below.
+ -- A type subject to pragma Default_Initial_Condition is fully default
+ -- initialized when the pragma appears with a non-null argument. Since
+ -- any type may act as the full view of a private type, this check must
+ -- be performed prior to the specialized tests below.
- if Has_Default_Init_Cond (Typ)
- or else Has_Inherited_Default_Init_Cond (Typ)
- then
+ if Has_DIC (Typ) then
Prag := Get_Pragma (Typ, Pragma_Default_Initial_Condition);
-
- -- Pragma Default_Initial_Condition must be present if one of the
- -- related entity flags is set.
-
pragma Assert (Present (Prag));
- Arg := First (Pragma_Argument_Associations (Prag));
- -- A non-null argument guarantees full default initialization
-
- if Present (Arg) then
- return Nkind (Arg) /= N_Null;
-
- -- Otherwise the missing argument defaults the pragma to "True" which
- -- is considered a non-null argument (see above).
-
- else
- return True;
- end if;
+ return Is_Verifiable_DIC_Pragma (Prag);
end if;
-- A scalar type is fully default initialized if it is subject to aspect
@@ -9101,7 +9391,7 @@ package body Sem_Util is
Has_Default_Aspect (Typ)
or else Has_Full_Default_Initialization (Component_Type (Typ));
- -- A protected type, record type or type extension is fully default
+ -- A protected type, record type, or type extension is fully default
-- initialized if all its components either carry an initialization
-- expression or have a type that is fully default initialized. The
-- parent type of a type extension must be fully default initialized.
@@ -9233,15 +9523,25 @@ package body Sem_Util is
return False;
end Has_Interfaces;
+ --------------------------
+ -- Has_Max_Queue_Length --
+ --------------------------
+
+ function Has_Max_Queue_Length (Id : Entity_Id) return Boolean is
+ begin
+ return
+ Ekind (Id) = E_Entry
+ and then Present (Get_Pragma (Id, Pragma_Max_Queue_Length));
+ end Has_Max_Queue_Length;
+
---------------------------------
-- Has_No_Obvious_Side_Effects --
---------------------------------
function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is
begin
- -- For now, just handle literals, constants, and non-volatile
- -- variables and expressions combining these with operators or
- -- short circuit forms.
+ -- For now handle literals, constants, and non-volatile variables and
+ -- expressions combining these with operators or short circuit forms.
if Nkind (N) in N_Numeric_Or_String_Literal then
return True;
@@ -9282,19 +9582,78 @@ package body Sem_Util is
-----------------------------
function Has_Non_Null_Refinement (Id : Entity_Id) return Boolean is
+ Constits : Elist_Id;
+
begin
pragma Assert (Ekind (Id) = E_Abstract_State);
+ Constits := Refinement_Constituents (Id);
-- For a refinement to be non-null, the first constituent must be
-- anything other than null.
- if Present (Refinement_Constituents (Id)) then
- return
- Nkind (Node (First_Elmt (Refinement_Constituents (Id)))) /= N_Null;
+ return
+ Present (Constits)
+ and then Nkind (Node (First_Elmt (Constits))) /= N_Null;
+ end Has_Non_Null_Refinement;
+
+ -------------------
+ -- Has_Null_Body --
+ -------------------
+
+ function Has_Null_Body (Proc_Id : Entity_Id) return Boolean is
+ Body_Id : Entity_Id;
+ Decl : Node_Id;
+ Spec : Node_Id;
+ Stmt1 : Node_Id;
+ Stmt2 : Node_Id;
+
+ begin
+ Spec := Parent (Proc_Id);
+ Decl := Parent (Spec);
+
+ -- Retrieve the entity of the procedure body (e.g. invariant proc).
+
+ if Nkind (Spec) = N_Procedure_Specification
+ and then Nkind (Decl) = N_Subprogram_Declaration
+ then
+ Body_Id := Corresponding_Body (Decl);
+
+ -- The body acts as a spec
+
+ else
+ Body_Id := Proc_Id;
+ end if;
+
+ -- The body will be generated later
+
+ if No (Body_Id) then
+ return False;
+ end if;
+
+ Spec := Parent (Body_Id);
+ Decl := Parent (Spec);
+
+ pragma Assert
+ (Nkind (Spec) = N_Procedure_Specification
+ and then Nkind (Decl) = N_Subprogram_Body);
+
+ Stmt1 := First (Statements (Handled_Statement_Sequence (Decl)));
+
+ -- Look for a null statement followed by an optional return
+ -- statement.
+
+ if Nkind (Stmt1) = N_Null_Statement then
+ Stmt2 := Next (Stmt1);
+
+ if Present (Stmt2) then
+ return Nkind (Stmt2) = N_Simple_Return_Statement;
+ else
+ return True;
+ end if;
end if;
return False;
- end Has_Non_Null_Refinement;
+ end Has_Null_Body;
------------------------
-- Has_Null_Exclusion --
@@ -9303,19 +9662,21 @@ package body Sem_Util is
function Has_Null_Exclusion (N : Node_Id) return Boolean is
begin
case Nkind (N) is
- when N_Access_Definition |
- N_Access_Function_Definition |
- N_Access_Procedure_Definition |
- N_Access_To_Object_Definition |
- N_Allocator |
- N_Derived_Type_Definition |
- N_Function_Specification |
- N_Subtype_Declaration =>
+ when N_Access_Definition
+ | N_Access_Function_Definition
+ | N_Access_Procedure_Definition
+ | N_Access_To_Object_Definition
+ | N_Allocator
+ | N_Derived_Type_Definition
+ | N_Function_Specification
+ | N_Subtype_Declaration
+ =>
return Null_Exclusion_Present (N);
- when N_Component_Definition |
- N_Formal_Object_Declaration |
- N_Object_Renaming_Declaration =>
+ when N_Component_Definition
+ | N_Formal_Object_Declaration
+ | N_Object_Renaming_Declaration
+ =>
if Present (Subtype_Mark (N)) then
return Null_Exclusion_Present (N);
else pragma Assert (Present (Access_Definition (N)));
@@ -9345,7 +9706,6 @@ package body Sem_Util is
when others =>
return False;
-
end case;
end Has_Null_Exclusion;
@@ -9391,18 +9751,18 @@ package body Sem_Util is
-------------------------
function Has_Null_Refinement (Id : Entity_Id) return Boolean is
+ Constits : Elist_Id;
+
begin
pragma Assert (Ekind (Id) = E_Abstract_State);
+ Constits := Refinement_Constituents (Id);
-- For a refinement to be null, the state's sole constituent must be a
-- null.
- if Present (Refinement_Constituents (Id)) then
- return
- Nkind (Node (First_Elmt (Refinement_Constituents (Id)))) = N_Null;
- end if;
-
- return False;
+ return
+ Present (Constits)
+ and then Nkind (Node (First_Elmt (Constits))) = N_Null;
end Has_Null_Refinement;
-------------------------------
@@ -10038,6 +10398,58 @@ package body Sem_Util is
return Name_Find;
end Remove_Suffix;
+ ----------------------------------
+ -- Replace_Null_By_Null_Address --
+ ----------------------------------
+
+ procedure Replace_Null_By_Null_Address (N : Node_Id) is
+ procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id);
+ -- Replace operand Op with a reference to Null_Address when the operand
+ -- denotes a null Address. Other_Op denotes the other operand.
+
+ --------------------------
+ -- Replace_Null_Operand --
+ --------------------------
+
+ procedure Replace_Null_Operand (Op : Node_Id; Other_Op : Node_Id) is
+ begin
+ -- Check the type of the complementary operand since the N_Null node
+ -- has not been decorated yet.
+
+ if Nkind (Op) = N_Null
+ and then Is_Descendant_Of_Address (Etype (Other_Op))
+ then
+ Rewrite (Op, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (Op)));
+ end if;
+ end Replace_Null_Operand;
+
+ -- Start of processing for Replace_Null_By_Null_Address
+
+ begin
+ pragma Assert (Relaxed_RM_Semantics);
+ pragma Assert (Nkind_In (N, N_Null,
+ N_Op_Eq,
+ N_Op_Ge,
+ N_Op_Gt,
+ N_Op_Le,
+ N_Op_Lt,
+ N_Op_Ne));
+
+ if Nkind (N) = N_Null then
+ Rewrite (N, New_Occurrence_Of (RTE (RE_Null_Address), Sloc (N)));
+
+ else
+ declare
+ L : constant Node_Id := Left_Opnd (N);
+ R : constant Node_Id := Right_Opnd (N);
+
+ begin
+ Replace_Null_Operand (L, Other_Op => R);
+ Replace_Null_Operand (R, Other_Op => L);
+ end;
+ end if;
+ end Replace_Null_By_Null_Address;
+
--------------------------
-- Has_Tagged_Component --
--------------------------
@@ -10251,6 +10663,26 @@ package body Sem_Util is
and then Assertion_Expression_Pragma (Get_Pragma_Id (Prag));
end In_Assertion_Expression_Pragma;
+ ----------------------
+ -- In_Generic_Scope --
+ ----------------------
+
+ function In_Generic_Scope (E : Entity_Id) return Boolean is
+ S : Entity_Id;
+
+ begin
+ S := Scope (E);
+ while Present (S) and then S /= Standard_Standard loop
+ if Is_Generic_Unit (S) then
+ return True;
+ end if;
+
+ S := Scope (S);
+ end loop;
+
+ return False;
+ end In_Generic_Scope;
+
-----------------
-- In_Instance --
-----------------
@@ -10427,6 +10859,51 @@ package body Sem_Util is
end loop;
end In_Pragma_Expression;
+ ---------------------------
+ -- In_Pre_Post_Condition --
+ ---------------------------
+
+ function In_Pre_Post_Condition (N : Node_Id) return Boolean is
+ Par : Node_Id;
+ Prag : Node_Id := Empty;
+ Prag_Id : Pragma_Id;
+
+ begin
+ -- Climb the parent chain looking for an enclosing pragma
+
+ Par := N;
+ while Present (Par) loop
+ if Nkind (Par) = N_Pragma then
+ Prag := Par;
+ exit;
+
+ -- Prevent the search from going too far
+
+ elsif Is_Body_Or_Package_Declaration (Par) then
+ exit;
+ end if;
+
+ Par := Parent (Par);
+ end loop;
+
+ if Present (Prag) then
+ Prag_Id := Get_Pragma_Id (Prag);
+
+ return
+ Prag_Id = Pragma_Post
+ or else Prag_Id = Pragma_Post_Class
+ or else Prag_Id = Pragma_Postcondition
+ or else Prag_Id = Pragma_Pre
+ or else Prag_Id = Pragma_Pre_Class
+ or else Prag_Id = Pragma_Precondition;
+
+ -- Otherwise the node is not enclosed by a pre/postcondition pragma
+
+ else
+ return False;
+ end if;
+ end In_Pre_Post_Condition;
+
-------------------------------------
-- In_Reverse_Storage_Order_Object --
-------------------------------------
@@ -10531,20 +11008,31 @@ package body Sem_Util is
while Present (Decl) loop
Match := Empty;
+ -- The partial view of a Taft-amendment type is an incomplete
+ -- type.
+
if Taft then
if Nkind (Decl) = N_Incomplete_Type_Declaration then
Match := Defining_Identifier (Decl);
end if;
- else
- if Nkind_In (Decl, N_Private_Extension_Declaration,
+ -- Otherwise look for a private type whose full view matches the
+ -- input type. Note that this checks full_type_declaration nodes
+ -- to account for derivations from a private type where the type
+ -- declaration hold the partial view and the full view is an
+ -- itype.
+
+ elsif Nkind_In (Decl, N_Full_Type_Declaration,
+ N_Private_Extension_Declaration,
N_Private_Type_Declaration)
- then
- Match := Defining_Identifier (Decl);
- end if;
+ then
+ Match := Defining_Identifier (Decl);
end if;
+ -- Guard against unanalyzed entities
+
if Present (Match)
+ and then Is_Type (Match)
and then Present (Full_View (Match))
and then Full_View (Match) = Id
then
@@ -10583,7 +11071,9 @@ package body Sem_Util is
Pkg_Decl : Node_Id := Pkg;
begin
- if Present (Pkg) and then Ekind (Pkg) = E_Package then
+ if Present (Pkg)
+ and then Ekind_In (Pkg, E_Generic_Package, E_Package)
+ then
while Nkind (Pkg_Decl) /= N_Package_Specification loop
Pkg_Decl := Parent (Pkg_Decl);
end loop;
@@ -10619,79 +11109,201 @@ package body Sem_Util is
return Empty;
end Incomplete_Or_Partial_View;
- -----------------------------------------
- -- Inherit_Default_Init_Cond_Procedure --
- -----------------------------------------
+ ----------------------------------
+ -- Indexed_Component_Bit_Offset --
+ ----------------------------------
- procedure Inherit_Default_Init_Cond_Procedure (Typ : Entity_Id) is
- Par_Typ : constant Entity_Id := Etype (Typ);
+ function Indexed_Component_Bit_Offset (N : Node_Id) return Uint is
+ Exp : constant Node_Id := First (Expressions (N));
+ Typ : constant Entity_Id := Etype (Prefix (N));
+ Off : constant Uint := Component_Size (Typ);
+ Ind : Node_Id;
begin
- -- A derived type inherits the default initial condition procedure of
- -- its parent type.
+ -- Return early if the component size is not known or variable
- if No (Default_Init_Cond_Procedure (Typ)) then
- Set_Default_Init_Cond_Procedure
- (Typ, Default_Init_Cond_Procedure (Par_Typ));
+ if Off = No_Uint or else Off < Uint_0 then
+ return No_Uint;
end if;
- end Inherit_Default_Init_Cond_Procedure;
+
+ -- Deal with the degenerate case of an empty component
+
+ if Off = Uint_0 then
+ return Off;
+ end if;
+
+ -- Check that both the index value and the low bound are known
+
+ if not Compile_Time_Known_Value (Exp) then
+ return No_Uint;
+ end if;
+
+ Ind := First_Index (Typ);
+ if No (Ind) then
+ return No_Uint;
+ end if;
+
+ if Nkind (Ind) = N_Subtype_Indication then
+ Ind := Constraint (Ind);
+
+ if Nkind (Ind) = N_Range_Constraint then
+ Ind := Range_Expression (Ind);
+ end if;
+ end if;
+
+ if Nkind (Ind) /= N_Range
+ or else not Compile_Time_Known_Value (Low_Bound (Ind))
+ then
+ return No_Uint;
+ end if;
+
+ -- Return the scaled offset
+
+ return Off * (Expr_Value (Exp) - Expr_Value (Low_Bound ((Ind))));
+ end Indexed_Component_Bit_Offset;
----------------------------
-- Inherit_Rep_Item_Chain --
----------------------------
procedure Inherit_Rep_Item_Chain (Typ : Entity_Id; From_Typ : Entity_Id) is
- From_Item : constant Node_Id := First_Rep_Item (From_Typ);
- Item : Node_Id := Empty;
- Last_Item : Node_Id := Empty;
+ Item : Node_Id;
+ Next_Item : Node_Id;
begin
- -- Reach the end of the destination type's chain (if any) and capture
- -- the last item.
+ -- There are several inheritance scenarios to consider depending on
+ -- whether both types have rep item chains and whether the destination
+ -- type already inherits part of the source type's rep item chain.
- Item := First_Rep_Item (Typ);
- while Present (Item) loop
+ -- 1) The source type lacks a rep item chain
+ -- From_Typ ---> Empty
+ --
+ -- Typ --------> Item (or Empty)
- -- Do not inherit a chain that has been inherited already
+ -- In this case inheritance cannot take place because there are no items
+ -- to inherit.
- if Item = From_Item then
- return;
- end if;
+ -- 2) The destination type lacks a rep item chain
+ -- From_Typ ---> Item ---> ...
+ --
+ -- Typ --------> Empty
- Last_Item := Item;
- Item := Next_Rep_Item (Item);
- end loop;
+ -- Inheritance takes place by setting the First_Rep_Item of the
+ -- destination type to the First_Rep_Item of the source type.
+ -- From_Typ ---> Item ---> ...
+ -- ^
+ -- Typ -----------+
- Item := First_Rep_Item (From_Typ);
+ -- 3.1) Both source and destination types have at least one rep item.
+ -- The destination type does NOT inherit a rep item from the source
+ -- type.
+ -- From_Typ ---> Item ---> Item
+ --
+ -- Typ --------> Item ---> Item
- -- Additional check when both parent and current type have rep.
- -- items, to prevent circularities when the derivation completes
- -- a private declaration and inherits from both views of the parent.
- -- There may be a remaining problem with the proper ordering of
- -- attribute specifications and aspects on the chains of the four
- -- entities involved. ???
+ -- Inheritance takes place by setting the Next_Rep_Item of the last item
+ -- of the destination type to the First_Rep_Item of the source type.
+ -- From_Typ -------------------> Item ---> Item
+ -- ^
+ -- Typ --------> Item ---> Item --+
- if Present (Item) and then Present (From_Item) then
- while Present (Item) loop
- if Item = First_Rep_Item (Typ) then
- return;
- end if;
+ -- 3.2) Both source and destination types have at least one rep item.
+ -- The destination type DOES inherit part of the rep item chain of the
+ -- source type.
+ -- From_Typ ---> Item ---> Item ---> Item
+ -- ^
+ -- Typ --------> Item ------+
- Item := Next_Rep_Item (Item);
- end loop;
- end if;
+ -- This rare case arises when the full view of a private extension must
+ -- inherit the rep item chain from the full view of its parent type and
+ -- the full view of the parent type contains extra rep items. Currently
+ -- only invariants may lead to such form of inheritance.
+
+ -- type From_Typ is tagged private
+ -- with Type_Invariant'Class => Item_2;
+
+ -- type Typ is new From_Typ with private
+ -- with Type_Invariant => Item_4;
- -- When the destination type has a rep item chain, the chain of the
- -- source type is appended to it.
+ -- At this point the rep item chains contain the following items
- if Present (Last_Item) then
- Set_Next_Rep_Item (Last_Item, From_Item);
+ -- From_Typ -----------> Item_2 ---> Item_3
+ -- ^
+ -- Typ --------> Item_4 --+
- -- Otherwise the destination type directly inherits the rep item chain
- -- of the source type (if any).
+ -- The full views of both types may introduce extra invariants
+
+ -- type From_Typ is tagged null record
+ -- with Type_Invariant => Item_1;
+
+ -- type Typ is new From_Typ with null record;
+
+ -- The full view of Typ would have to inherit any new rep items added to
+ -- the full view of From_Typ.
+
+ -- From_Typ -----------> Item_1 ---> Item_2 ---> Item_3
+ -- ^
+ -- Typ --------> Item_4 --+
+
+ -- To achieve this form of inheritance, the destination type must first
+ -- sever the link between its own rep chain and that of the source type,
+ -- then inheritance 3.1 takes place.
+
+ -- Case 1: The source type lacks a rep item chain
+
+ if No (First_Rep_Item (From_Typ)) then
+ return;
+
+ -- Case 2: The destination type lacks a rep item chain
+
+ elsif No (First_Rep_Item (Typ)) then
+ Set_First_Rep_Item (Typ, First_Rep_Item (From_Typ));
+
+ -- Case 3: Both the source and destination types have at least one rep
+ -- item. Traverse the rep item chain of the destination type to find the
+ -- last rep item.
else
- Set_First_Rep_Item (Typ, From_Item);
+ Item := Empty;
+ Next_Item := First_Rep_Item (Typ);
+ while Present (Next_Item) loop
+
+ -- Detect a link between the destination type's rep chain and that
+ -- of the source type. There are two possibilities:
+
+ -- Variant 1
+ -- Next_Item
+ -- V
+ -- From_Typ ---> Item_1 --->
+ -- ^
+ -- Typ -----------+
+ --
+ -- Item is Empty
+
+ -- Variant 2
+ -- Next_Item
+ -- V
+ -- From_Typ ---> Item_1 ---> Item_2 --->
+ -- ^
+ -- Typ --------> Item_3 ------+
+ -- ^
+ -- Item
+
+ if Has_Rep_Item (From_Typ, Next_Item) then
+ exit;
+ end if;
+
+ Item := Next_Item;
+ Next_Item := Next_Rep_Item (Next_Item);
+ end loop;
+
+ -- Inherit the source type's rep item chain
+
+ if Present (Item) then
+ Set_Next_Rep_Item (Item, First_Rep_Item (From_Typ));
+ else
+ Set_First_Rep_Item (Typ, First_Rep_Item (From_Typ));
+ end if;
end if;
end Inherit_Rep_Item_Chain;
@@ -10777,7 +11389,7 @@ package body Sem_Util is
------------------------------------------
procedure Inspect_Deferred_Constant_Completion (Decls : List_Id) is
- Decl : Node_Id;
+ Decl : Node_Id;
begin
Decl := First (Decls);
@@ -11574,6 +12186,23 @@ package body Sem_Util is
and then Defining_Entity (P) = Typ
then
return True;
+
+ -- A subtype name may appear in an aspect specification for a
+ -- Predicate_Failure aspect, for which we do not construct a
+ -- wrapper procedure. The subtype will be replaced by the
+ -- expression being tested when the corresponding predicate
+ -- check is expanded.
+
+ elsif Nkind (P) = N_Aspect_Specification
+ and then Nkind (Parent (P)) = N_Subtype_Declaration
+ then
+ return True;
+
+ elsif Nkind (P) = N_Pragma
+ and then
+ Get_Pragma_Id (P) = Pragma_Predicate_Failure
+ then
+ return True;
end if;
P := Parent (P);
@@ -11591,32 +12220,38 @@ package body Sem_Util is
function Is_Declaration (N : Node_Id) return Boolean is
begin
+ return
+ Is_Declaration_Other_Than_Renaming (N)
+ or else Is_Renaming_Declaration (N);
+ end Is_Declaration;
+
+ ----------------------------------------
+ -- Is_Declaration_Other_Than_Renaming --
+ ----------------------------------------
+
+ function Is_Declaration_Other_Than_Renaming (N : Node_Id) return Boolean is
+ begin
case Nkind (N) is
- when N_Abstract_Subprogram_Declaration |
- N_Exception_Declaration |
- N_Exception_Renaming_Declaration |
- N_Full_Type_Declaration |
- N_Generic_Function_Renaming_Declaration |
- N_Generic_Package_Declaration |
- N_Generic_Package_Renaming_Declaration |
- N_Generic_Procedure_Renaming_Declaration |
- N_Generic_Subprogram_Declaration |
- N_Number_Declaration |
- N_Object_Declaration |
- N_Object_Renaming_Declaration |
- N_Package_Declaration |
- N_Package_Renaming_Declaration |
- N_Private_Extension_Declaration |
- N_Private_Type_Declaration |
- N_Subprogram_Declaration |
- N_Subprogram_Renaming_Declaration |
- N_Subtype_Declaration =>
+ when N_Abstract_Subprogram_Declaration
+ | N_Exception_Declaration
+ | N_Expression_Function
+ | N_Full_Type_Declaration
+ | N_Generic_Package_Declaration
+ | N_Generic_Subprogram_Declaration
+ | N_Number_Declaration
+ | N_Object_Declaration
+ | N_Package_Declaration
+ | N_Private_Extension_Declaration
+ | N_Private_Type_Declaration
+ | N_Subprogram_Declaration
+ | N_Subtype_Declaration
+ =>
return True;
- when others =>
+ when others =>
return False;
end case;
- end Is_Declaration;
+ end Is_Declaration_Other_Than_Renaming;
--------------------------------
-- Is_Declared_Within_Variant --
@@ -11807,10 +12442,10 @@ package body Sem_Util is
end Is_Dereferenced;
----------------------
- -- Is_Descendent_Of --
+ -- Is_Descendant_Of --
----------------------
- function Is_Descendent_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
+ function Is_Descendant_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean is
T : Entity_Id;
Etyp : Entity_Id;
@@ -11863,7 +12498,7 @@ package body Sem_Util is
T := Base_Type (Etyp);
end loop;
end if;
- end Is_Descendent_Of;
+ end Is_Descendant_Of;
----------------------------------------
-- Is_Descendant_Of_Suspension_Object --
@@ -11930,7 +12565,7 @@ package body Sem_Util is
return True;
-- An array type is effectively volatile when it is subject to pragma
- -- Atomic_Components or Volatile_Components or its compolent type is
+ -- Atomic_Components or Volatile_Components or its component type is
-- effectively volatile.
elsif Is_Array_Type (Id) then
@@ -11975,9 +12610,6 @@ package body Sem_Util is
if Is_Entity_Name (N) then
return Is_Effectively_Volatile (Entity (N));
- elsif Nkind (N) = N_Expanded_Name then
- return Is_Effectively_Volatile (Entity (N));
-
elsif Nkind (N) = N_Indexed_Component then
return Is_Effectively_Volatile_Object (Prefix (N));
@@ -12014,6 +12646,19 @@ package body Sem_Util is
and then Nkind (Unit_Declaration_Node (Id)) = N_Entry_Declaration;
end Is_Entry_Declaration;
+ ------------------------------------
+ -- Is_Expanded_Priority_Attribute --
+ ------------------------------------
+
+ function Is_Expanded_Priority_Attribute (E : Entity_Id) return Boolean is
+ begin
+ return
+ Nkind (E) = N_Function_Call
+ and then not Configurable_Run_Time_Mode
+ and then (Entity (Name (E)) = RTE (RE_Get_Ceiling)
+ or else Entity (Name (E)) = RTE (RO_PE_Get_Ceiling));
+ end Is_Expanded_Priority_Attribute;
+
----------------------------
-- Is_Expression_Function --
----------------------------
@@ -12212,7 +12857,7 @@ package body Sem_Util is
else
Indx_Typ := Etype (Indx);
- if Is_Private_Type (Indx_Typ) then
+ if Is_Private_Type (Indx_Typ) then
Indx_Typ := Full_View (Indx_Typ);
end if;
@@ -12513,6 +13158,41 @@ package body Sem_Util is
and then Defining_Identifier (Parent (E)) = Typ;
end Is_Inherited_Operation_For_Type;
+ --------------------------------------
+ -- Is_Inlinable_Expression_Function --
+ --------------------------------------
+
+ function Is_Inlinable_Expression_Function
+ (Subp : Entity_Id) return Boolean
+ is
+ Return_Expr : Node_Id;
+
+ begin
+ if Is_Expression_Function_Or_Completion (Subp)
+ and then Has_Pragma_Inline_Always (Subp)
+ and then Needs_No_Actuals (Subp)
+ and then No (Contract (Subp))
+ and then not Is_Dispatching_Operation (Subp)
+ and then Needs_Finalization (Etype (Subp))
+ and then not Is_Class_Wide_Type (Etype (Subp))
+ and then not (Has_Invariants (Etype (Subp)))
+ and then Present (Subprogram_Body (Subp))
+ and then Was_Expression_Function (Subprogram_Body (Subp))
+ then
+ Return_Expr := Expression_Of_Expression_Function (Subp);
+
+ -- The returned object must not have a qualified expression and its
+ -- nominal subtype must be statically compatible with the result
+ -- subtype of the expression function.
+
+ return
+ Nkind (Return_Expr) = N_Identifier
+ and then Etype (Return_Expr) = Etype (Subp);
+ end if;
+
+ return False;
+ end Is_Inlinable_Expression_Function;
+
-----------------
-- Is_Iterator --
-----------------
@@ -12528,11 +13208,14 @@ package body Sem_Util is
function Denotes_Iterator (Iter_Typ : Entity_Id) return Boolean is
begin
+ -- Check that the name matches, and that the ultimate ancestor is in
+ -- a predefined unit, i.e the one that declares iterator interfaces.
+
return
Nam_In (Chars (Iter_Typ), Name_Forward_Iterator,
Name_Reversible_Iterator)
and then Is_Predefined_File_Name
- (Unit_File_Name (Get_Source_Unit (Iter_Typ)));
+ (Unit_File_Name (Get_Source_Unit (Root_Type (Iter_Typ))));
end Denotes_Iterator;
-- Local variables
@@ -12694,20 +13377,70 @@ package body Sem_Util is
end if;
end Is_Local_Variable_Reference;
- -----------------------------------------------
- -- Is_Nontrivial_Default_Init_Cond_Procedure --
- -----------------------------------------------
+ -----------------------
+ -- Is_Name_Reference --
+ -----------------------
- function Is_Nontrivial_Default_Init_Cond_Procedure
- (Id : Entity_Id) return Boolean
- is
+ function Is_Name_Reference (N : Node_Id) return Boolean is
+ begin
+ if Is_Entity_Name (N) then
+ return Present (Entity (N)) and then Is_Object (Entity (N));
+ end if;
+
+ case Nkind (N) is
+ when N_Indexed_Component
+ | N_Slice
+ =>
+ return
+ Is_Name_Reference (Prefix (N))
+ or else Is_Access_Type (Etype (Prefix (N)));
+
+ -- Attributes 'Input, 'Old and 'Result produce objects
+
+ when N_Attribute_Reference =>
+ return
+ Nam_In (Attribute_Name (N), Name_Input, Name_Old, Name_Result);
+
+ when N_Selected_Component =>
+ return
+ Is_Name_Reference (Selector_Name (N))
+ and then
+ (Is_Name_Reference (Prefix (N))
+ or else Is_Access_Type (Etype (Prefix (N))));
+
+ when N_Explicit_Dereference =>
+ return True;
+
+ -- A view conversion of a tagged name is a name reference
+
+ when N_Type_Conversion =>
+ return
+ Is_Tagged_Type (Etype (Subtype_Mark (N)))
+ and then Is_Tagged_Type (Etype (Expression (N)))
+ and then Is_Name_Reference (Expression (N));
+
+ -- An unchecked type conversion is considered to be a name if the
+ -- operand is a name (this construction arises only as a result of
+ -- expansion activities).
+
+ when N_Unchecked_Type_Conversion =>
+ return Is_Name_Reference (Expression (N));
+
+ when others =>
+ return False;
+ end case;
+ end Is_Name_Reference;
+
+ ---------------------------------
+ -- Is_Nontrivial_DIC_Procedure --
+ ---------------------------------
+
+ function Is_Nontrivial_DIC_Procedure (Id : Entity_Id) return Boolean is
Body_Decl : Node_Id;
- Stmt : Node_Id;
+ Stmt : Node_Id;
begin
- if Ekind (Id) = E_Procedure
- and then Is_Default_Init_Cond_Procedure (Id)
- then
+ if Ekind (Id) = E_Procedure and then Is_DIC_Procedure (Id) then
Body_Decl :=
Unit_Declaration_Node
(Corresponding_Body (Unit_Declaration_Node (Id)));
@@ -12731,7 +13464,21 @@ package body Sem_Util is
end if;
return False;
- end Is_Nontrivial_Default_Init_Cond_Procedure;
+ end Is_Nontrivial_DIC_Procedure;
+
+ -------------------------
+ -- Is_Null_Record_Type --
+ -------------------------
+
+ function Is_Null_Record_Type (T : Entity_Id) return Boolean is
+ Decl : constant Node_Id := Parent (T);
+ begin
+ return Nkind (Decl) = N_Full_Type_Declaration
+ and then Nkind (Type_Definition (Decl)) = N_Record_Definition
+ and then
+ (No (Component_List (Type_Definition (Decl)))
+ or else Null_Present (Component_List (Type_Definition (Decl))));
+ end Is_Null_Record_Type;
-------------------------
-- Is_Object_Reference --
@@ -12771,7 +13518,9 @@ package body Sem_Util is
else
case Nkind (N) is
- when N_Indexed_Component | N_Slice =>
+ when N_Indexed_Component
+ | N_Slice
+ =>
return
Is_Object_Reference (Prefix (N))
or else Is_Access_Type (Etype (Prefix (N)));
@@ -12782,7 +13531,7 @@ package body Sem_Util is
when N_Function_Call =>
return Etype (N) /= Standard_Void_Type;
- -- Attributes 'Input, 'Loop_Entry, 'Old and 'Result produce
+ -- Attributes 'Input, 'Loop_Entry, 'Old, and 'Result produce
-- objects.
when N_Attribute_Reference =>
@@ -12959,6 +13708,277 @@ package body Sem_Util is
end if;
end Is_OK_Variable_For_Out_Formal;
+ ----------------------------
+ -- Is_OK_Volatile_Context --
+ ----------------------------
+
+ function Is_OK_Volatile_Context
+ (Context : Node_Id;
+ Obj_Ref : Node_Id) return Boolean
+ is
+ function Is_Protected_Operation_Call (Nod : Node_Id) return Boolean;
+ -- Determine whether an arbitrary node denotes a call to a protected
+ -- entry, function, or procedure in prefixed form where the prefix is
+ -- Obj_Ref.
+
+ function Within_Check (Nod : Node_Id) return Boolean;
+ -- Determine whether an arbitrary node appears in a check node
+
+ function Within_Subprogram_Call (Nod : Node_Id) return Boolean;
+ -- Determine whether an arbitrary node appears in an entry, function, or
+ -- procedure call.
+
+ function Within_Volatile_Function (Id : Entity_Id) return Boolean;
+ -- Determine whether an arbitrary entity appears in a volatile function
+
+ ---------------------------------
+ -- Is_Protected_Operation_Call --
+ ---------------------------------
+
+ function Is_Protected_Operation_Call (Nod : Node_Id) return Boolean is
+ Pref : Node_Id;
+ Subp : Node_Id;
+
+ begin
+ -- A call to a protected operations retains its selected component
+ -- form as opposed to other prefixed calls that are transformed in
+ -- expanded names.
+
+ if Nkind (Nod) = N_Selected_Component then
+ Pref := Prefix (Nod);
+ Subp := Selector_Name (Nod);
+
+ return
+ Pref = Obj_Ref
+ and then Present (Etype (Pref))
+ and then Is_Protected_Type (Etype (Pref))
+ and then Is_Entity_Name (Subp)
+ and then Present (Entity (Subp))
+ and then Ekind_In (Entity (Subp), E_Entry,
+ E_Entry_Family,
+ E_Function,
+ E_Procedure);
+ else
+ return False;
+ end if;
+ end Is_Protected_Operation_Call;
+
+ ------------------
+ -- Within_Check --
+ ------------------
+
+ function Within_Check (Nod : Node_Id) return Boolean is
+ Par : Node_Id;
+
+ begin
+ -- Climb the parent chain looking for a check node
+
+ Par := Nod;
+ while Present (Par) loop
+ if Nkind (Par) in N_Raise_xxx_Error then
+ return True;
+
+ -- Prevent the search from going too far
+
+ elsif Is_Body_Or_Package_Declaration (Par) then
+ exit;
+ end if;
+
+ Par := Parent (Par);
+ end loop;
+
+ return False;
+ end Within_Check;
+
+ ----------------------------
+ -- Within_Subprogram_Call --
+ ----------------------------
+
+ function Within_Subprogram_Call (Nod : Node_Id) return Boolean is
+ Par : Node_Id;
+
+ begin
+ -- Climb the parent chain looking for a function or procedure call
+
+ Par := Nod;
+ while Present (Par) loop
+ if Nkind_In (Par, N_Entry_Call_Statement,
+ N_Function_Call,
+ N_Procedure_Call_Statement)
+ then
+ return True;
+
+ -- Prevent the search from going too far
+
+ elsif Is_Body_Or_Package_Declaration (Par) then
+ exit;
+ end if;
+
+ Par := Parent (Par);
+ end loop;
+
+ return False;
+ end Within_Subprogram_Call;
+
+ ------------------------------
+ -- Within_Volatile_Function --
+ ------------------------------
+
+ function Within_Volatile_Function (Id : Entity_Id) return Boolean is
+ Func_Id : Entity_Id;
+
+ begin
+ -- Traverse the scope stack looking for a [generic] function
+
+ Func_Id := Id;
+ while Present (Func_Id) and then Func_Id /= Standard_Standard loop
+ if Ekind_In (Func_Id, E_Function, E_Generic_Function) then
+ return Is_Volatile_Function (Func_Id);
+ end if;
+
+ Func_Id := Scope (Func_Id);
+ end loop;
+
+ return False;
+ end Within_Volatile_Function;
+
+ -- Local variables
+
+ Obj_Id : Entity_Id;
+
+ -- Start of processing for Is_OK_Volatile_Context
+
+ begin
+ -- The volatile object appears on either side of an assignment
+
+ if Nkind (Context) = N_Assignment_Statement then
+ return True;
+
+ -- The volatile object is part of the initialization expression of
+ -- another object.
+
+ elsif Nkind (Context) = N_Object_Declaration
+ and then Present (Expression (Context))
+ and then Expression (Context) = Obj_Ref
+ then
+ Obj_Id := Defining_Entity (Context);
+
+ -- The volatile object acts as the initialization expression of an
+ -- extended return statement. This is valid context as long as the
+ -- function is volatile.
+
+ if Is_Return_Object (Obj_Id) then
+ return Within_Volatile_Function (Obj_Id);
+
+ -- Otherwise this is a normal object initialization
+
+ else
+ return True;
+ end if;
+
+ -- The volatile object acts as the name of a renaming declaration
+
+ elsif Nkind (Context) = N_Object_Renaming_Declaration
+ and then Name (Context) = Obj_Ref
+ then
+ return True;
+
+ -- The volatile object appears as an actual parameter in a call to an
+ -- instance of Unchecked_Conversion whose result is renamed.
+
+ elsif Nkind (Context) = N_Function_Call
+ and then Is_Entity_Name (Name (Context))
+ and then Is_Unchecked_Conversion_Instance (Entity (Name (Context)))
+ and then Nkind (Parent (Context)) = N_Object_Renaming_Declaration
+ then
+ return True;
+
+ -- The volatile object is actually the prefix in a protected entry,
+ -- function, or procedure call.
+
+ elsif Is_Protected_Operation_Call (Context) then
+ return True;
+
+ -- The volatile object appears as the expression of a simple return
+ -- statement that applies to a volatile function.
+
+ elsif Nkind (Context) = N_Simple_Return_Statement
+ and then Expression (Context) = Obj_Ref
+ then
+ return
+ Within_Volatile_Function (Return_Statement_Entity (Context));
+
+ -- The volatile object appears as the prefix of a name occurring in a
+ -- non-interfering context.
+
+ elsif Nkind_In (Context, N_Attribute_Reference,
+ N_Explicit_Dereference,
+ N_Indexed_Component,
+ N_Selected_Component,
+ N_Slice)
+ and then Prefix (Context) = Obj_Ref
+ and then Is_OK_Volatile_Context
+ (Context => Parent (Context),
+ Obj_Ref => Context)
+ then
+ return True;
+
+ -- The volatile object appears as the prefix of attributes Address,
+ -- Alignment, Component_Size, First_Bit, Last_Bit, Position, Size,
+ -- Storage_Size.
+
+ elsif Nkind (Context) = N_Attribute_Reference
+ and then Prefix (Context) = Obj_Ref
+ and then Nam_In (Attribute_Name (Context), Name_Address,
+ Name_Alignment,
+ Name_Component_Size,
+ Name_First_Bit,
+ Name_Last_Bit,
+ Name_Position,
+ Name_Size,
+ Name_Storage_Size)
+ then
+ return True;
+
+ -- The volatile object appears as the expression of a type conversion
+ -- occurring in a non-interfering context.
+
+ elsif Nkind_In (Context, N_Type_Conversion,
+ N_Unchecked_Type_Conversion)
+ and then Expression (Context) = Obj_Ref
+ and then Is_OK_Volatile_Context
+ (Context => Parent (Context),
+ Obj_Ref => Context)
+ then
+ return True;
+
+ -- The volatile object appears as the expression in a delay statement
+
+ elsif Nkind (Context) in N_Delay_Statement then
+ return True;
+
+ -- Allow references to volatile objects in various checks. This is not a
+ -- direct SPARK 2014 requirement.
+
+ elsif Within_Check (Context) then
+ return True;
+
+ -- Assume that references to effectively volatile objects that appear
+ -- as actual parameters in a subprogram call are always legal. A full
+ -- legality check is done when the actuals are resolved (see routine
+ -- Resolve_Actuals).
+
+ elsif Within_Subprogram_Call (Context) then
+ return True;
+
+ -- Otherwise the context is not suitable for an effectively volatile
+ -- object.
+
+ else
+ return False;
+ end if;
+ end Is_OK_Volatile_Context;
+
------------------------------------
-- Is_Package_Contract_Annotation --
------------------------------------
@@ -13264,7 +14284,7 @@ package body Sem_Util is
begin
-- Verify that prefix is analyzed and has the proper form. Note that
- -- the attributes Elab_Spec, Elab_Body and Elab_Subp_Body which also
+ -- the attributes Elab_Spec, Elab_Body, and Elab_Subp_Body, which also
-- produce the address of an entity, do not analyze their prefix
-- because they denote entities that are not necessarily visible.
-- Neither of them can apply to a protected type.
@@ -13441,16 +14461,17 @@ package body Sem_Util is
function Is_Renaming_Declaration (N : Node_Id) return Boolean is
begin
case Nkind (N) is
- when N_Exception_Renaming_Declaration |
- N_Generic_Function_Renaming_Declaration |
- N_Generic_Package_Renaming_Declaration |
- N_Generic_Procedure_Renaming_Declaration |
- N_Object_Renaming_Declaration |
- N_Package_Renaming_Declaration |
- N_Subprogram_Renaming_Declaration =>
+ when N_Exception_Renaming_Declaration
+ | N_Generic_Function_Renaming_Declaration
+ | N_Generic_Package_Renaming_Declaration
+ | N_Generic_Procedure_Renaming_Declaration
+ | N_Object_Renaming_Declaration
+ | N_Package_Renaming_Declaration
+ | N_Subprogram_Renaming_Declaration
+ =>
return True;
- when others =>
+ when others =>
return False;
end case;
end Is_Renaming_Declaration;
@@ -13619,23 +14640,27 @@ package body Sem_Util is
pragma Assert (Nkind (Orig_N) in N_Subexpr);
case Nkind (Orig_N) is
- when N_Character_Literal |
- N_Integer_Literal |
- N_Real_Literal |
- N_String_Literal =>
+ when N_Character_Literal
+ | N_Integer_Literal
+ | N_Real_Literal
+ | N_String_Literal
+ =>
null;
- when N_Identifier |
- N_Expanded_Name =>
+ when N_Expanded_Name
+ | N_Identifier
+ =>
if Is_Entity_Name (Orig_N)
and then Present (Entity (Orig_N)) -- needed in some cases
then
case Ekind (Entity (Orig_N)) is
- when E_Constant |
- E_Enumeration_Literal |
- E_Named_Integer |
- E_Named_Real =>
+ when E_Constant
+ | E_Enumeration_Literal
+ | E_Named_Integer
+ | E_Named_Real
+ =>
null;
+
when others =>
if Is_Type (Entity (Orig_N)) then
null;
@@ -13645,22 +14670,25 @@ package body Sem_Util is
end case;
end if;
- when N_Qualified_Expression |
- N_Type_Conversion =>
+ when N_Qualified_Expression
+ | N_Type_Conversion
+ =>
Is_Ok := Is_SPARK_05_Initialization_Expr (Expression (Orig_N));
when N_Unary_Op =>
Is_Ok := Is_SPARK_05_Initialization_Expr (Right_Opnd (Orig_N));
- when N_Binary_Op |
- N_Short_Circuit |
- N_Membership_Test =>
+ when N_Binary_Op
+ | N_Membership_Test
+ | N_Short_Circuit
+ =>
Is_Ok := Is_SPARK_05_Initialization_Expr (Left_Opnd (Orig_N))
and then
Is_SPARK_05_Initialization_Expr (Right_Opnd (Orig_N));
- when N_Aggregate |
- N_Extension_Aggregate =>
+ when N_Aggregate
+ | N_Extension_Aggregate
+ =>
if Nkind (Orig_N) = N_Extension_Aggregate then
Is_Ok :=
Is_SPARK_05_Initialization_Expr (Ancestor_Part (Orig_N));
@@ -13971,21 +14999,31 @@ package body Sem_Util is
--------------------------------------
function Is_Unchecked_Conversion_Instance (Id : Entity_Id) return Boolean is
- Gen_Par : Entity_Id;
+ Par : Node_Id;
begin
-- Look for a function whose generic parent is the predefined intrinsic
- -- function Unchecked_Conversion.
+ -- function Unchecked_Conversion, or for one that renames such an
+ -- instance.
if Ekind (Id) = E_Function then
- Gen_Par := Generic_Parent (Parent (Id));
+ Par := Parent (Id);
- return
- Present (Gen_Par)
- and then Chars (Gen_Par) = Name_Unchecked_Conversion
- and then Is_Intrinsic_Subprogram (Gen_Par)
- and then Is_Predefined_File_Name
- (Unit_File_Name (Get_Source_Unit (Gen_Par)));
+ if Nkind (Par) = N_Function_Specification then
+ Par := Generic_Parent (Par);
+
+ if Present (Par) then
+ return
+ Chars (Par) = Name_Unchecked_Conversion
+ and then Is_Intrinsic_Subprogram (Par)
+ and then Is_Predefined_File_Name
+ (Unit_File_Name (Get_Source_Unit (Par)));
+ else
+ return
+ Present (Alias (Id))
+ and then Is_Unchecked_Conversion_Instance (Alias (Id));
+ end if;
+ end if;
end if;
return False;
@@ -14249,7 +15287,9 @@ package body Sem_Util is
else
case Nkind (Orig_Node) is
- when N_Indexed_Component | N_Slice =>
+ when N_Indexed_Component
+ | N_Slice
+ =>
return Is_Variable_Prefix (Prefix (Orig_Node));
when N_Selected_Component =>
@@ -14302,6 +15342,21 @@ package body Sem_Util is
end if;
end Is_Variable;
+ ------------------------------
+ -- Is_Verifiable_DIC_Pragma --
+ ------------------------------
+
+ function Is_Verifiable_DIC_Pragma (Prag : Node_Id) return Boolean is
+ Args : constant List_Id := Pragma_Argument_Associations (Prag);
+
+ begin
+ -- To qualify as verifiable, a DIC pragma must have a non-null argument
+
+ return
+ Present (Args)
+ and then Nkind (Get_Pragma_Arg (First (Args))) /= N_Null;
+ end Is_Verifiable_DIC_Pragma;
+
---------------------------
-- Is_Visibly_Controlled --
---------------------------
@@ -14320,17 +15375,11 @@ package body Sem_Util is
function Is_Volatile_Function (Func_Id : Entity_Id) return Boolean is
begin
- -- The caller must ensure that Func_Id denotes a function
-
pragma Assert (Ekind_In (Func_Id, E_Function, E_Generic_Function));
- -- A protected function is automatically volatile
+ -- A function declared within a protected type is volatile
- if Is_Primitive (Func_Id)
- and then Present (First_Formal (Func_Id))
- and then Is_Protected_Type (Etype (First_Formal (Func_Id)))
- and then Etype (First_Formal (Func_Id)) = Scope (Func_Id)
- then
+ if Is_Protected_Type (Scope (Func_Id)) then
return True;
-- An instance of Ada.Unchecked_Conversion is a volatile function if
@@ -14593,16 +15642,16 @@ package body Sem_Util is
when N_Assignment_Statement =>
return N = Name (P);
- -- Function call arguments are never lvalues
+ -- Function call arguments are never lvalues
when N_Function_Call =>
return False;
-- Positional parameter for procedure or accept call
- when N_Procedure_Call_Statement |
- N_Accept_Statement
- =>
+ when N_Accept_Statement
+ | N_Procedure_Call_Statement
+ =>
declare
Proc : Entity_Id;
Form : Entity_Id;
@@ -14690,7 +15739,6 @@ package body Sem_Util is
when others =>
return False;
-
end case;
end Known_To_Be_Assigned;
@@ -14842,11 +15890,15 @@ package body Sem_Util is
return N = Name (P);
-- Test prefix of component or attribute. Note that the prefix of an
- -- explicit or implicit dereference cannot be an l-value.
+ -- explicit or implicit dereference cannot be an l-value. In the case
+ -- of a 'Read attribute, the reference can be an actual in the
+ -- argument list of the attribute.
when N_Attribute_Reference =>
- return N = Prefix (P)
- and then Name_Implies_Lvalue_Prefix (Attribute_Name (P));
+ return (N = Prefix (P)
+ and then Name_Implies_Lvalue_Prefix (Attribute_Name (P)))
+ or else
+ Attribute_Name (P) = Name_Read;
-- For an expanded name, the name is an lvalue if the expanded name
-- is an lvalue, but the prefix is never an lvalue, since it is just
@@ -14880,7 +15932,9 @@ package body Sem_Util is
-- or slice is an lvalue, except if it is an access type, where we
-- have an implicit dereference.
- when N_Indexed_Component | N_Slice =>
+ when N_Indexed_Component
+ | N_Slice
+ =>
if N /= Prefix (P)
or else (Present (Etype (N)) and then Is_Access_Type (Etype (N)))
then
@@ -14903,9 +15957,9 @@ package body Sem_Util is
-- In older versions of Ada function call arguments are never
-- lvalues. In Ada 2012 functions can have in-out parameters.
- when N_Subprogram_Call |
- N_Entry_Call_Statement |
- N_Accept_Statement
+ when N_Accept_Statement
+ | N_Entry_Call_Statement
+ | N_Subprogram_Call
=>
if Nkind (P) = N_Function_Call and then Ada_Version < Ada_2012 then
return False;
@@ -15006,7 +16060,6 @@ package body Sem_Util is
when others =>
return False;
-
end case;
end May_Be_Lvalue;
@@ -15078,7 +16131,7 @@ package body Sem_Util is
N_Allocator,
N_Qualified_Expression);
- -- An alloctor that appears within the initialization expression of an
+ -- An allocator that appears within the initialization expression of an
-- object declaration is considered a potentially dynamic coextension
-- when the initialization expression is an allocator or a qualified
-- expression.
@@ -15117,7 +16170,10 @@ package body Sem_Util is
begin
-- Ada 2005 or later, and formals present
- if Ada_Version >= Ada_2005 and then Present (First_Formal (E)) then
+ if Ada_Version >= Ada_2005
+ and then Present (First_Formal (E))
+ and then No (Default_Value (First_Formal (E)))
+ then
Formal := Next_Formal (First_Formal (E));
while Present (Formal) loop
if No (Default_Value (Formal)) then
@@ -15161,97 +16217,81 @@ package body Sem_Util is
end if;
end New_Copy_List_Tree;
- --------------------------------------------------
- -- New_Copy_Tree Auxiliary Data and Subprograms --
- --------------------------------------------------
-
- use Atree.Unchecked_Access;
- use Atree_Private_Part;
+ -------------------
+ -- New_Copy_Tree --
+ -------------------
- -- Our approach here requires a two pass traversal of the tree. The
- -- first pass visits all nodes that eventually will be copied looking
- -- for defining Itypes. If any defining Itypes are found, then they are
- -- copied, and an entry is added to the replacement map. In the second
- -- phase, the tree is copied, using the replacement map to replace any
- -- Itype references within the copied tree.
+ function New_Copy_Tree
+ (Source : Node_Id;
+ Map : Elist_Id := No_Elist;
+ New_Sloc : Source_Ptr := No_Location;
+ New_Scope : Entity_Id := Empty) return Node_Id
+ is
+ ------------------------------------
+ -- Auxiliary Data and Subprograms --
+ ------------------------------------
- -- The following hash tables are used if the Map supplied has more
- -- than hash threshold entries to speed up access to the map. If
- -- there are fewer entries, then the map is searched sequentially
- -- (because setting up a hash table for only a few entries takes
- -- more time than it saves.
+ use Atree.Unchecked_Access;
+ use Atree_Private_Part;
- function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num;
- -- Hash function used for hash operations
+ -- Our approach here requires a two pass traversal of the tree. The
+ -- first pass visits all nodes that eventually will be copied looking
+ -- for defining Itypes. If any defining Itypes are found, then they are
+ -- copied, and an entry is added to the replacement map. In the second
+ -- phase, the tree is copied, using the replacement map to replace any
+ -- Itype references within the copied tree.
- -------------------
- -- New_Copy_Hash --
- -------------------
+ -- The following hash tables are used if the Map supplied has more than
+ -- hash threshold entries to speed up access to the map. If there are
+ -- fewer entries, then the map is searched sequentially (because setting
+ -- up a hash table for only a few entries takes more time than it saves.
- function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num is
- begin
- return Nat (E) mod (NCT_Header_Num'Last + 1);
- end New_Copy_Hash;
+ subtype NCT_Header_Num is Int range 0 .. 511;
+ -- Defines range of headers in hash tables (512 headers)
- ---------------
- -- NCT_Assoc --
- ---------------
+ function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num;
+ -- Hash function used for hash operations
- -- The hash table NCT_Assoc associates old entities in the table
- -- with their corresponding new entities (i.e. the pairs of entries
- -- presented in the original Map argument are Key-Element pairs).
+ ---------------
+ -- NCT_Assoc --
+ ---------------
- package NCT_Assoc is new Simple_HTable (
- Header_Num => NCT_Header_Num,
- Element => Entity_Id,
- No_Element => Empty,
- Key => Entity_Id,
- Hash => New_Copy_Hash,
- Equal => Types."=");
+ -- The hash table NCT_Assoc associates old entities in the table with
+ -- their corresponding new entities (i.e. the pairs of entries presented
+ -- in the original Map argument are Key-Element pairs).
- ---------------------
- -- NCT_Itype_Assoc --
- ---------------------
+ package NCT_Assoc is new Simple_HTable (
+ Header_Num => NCT_Header_Num,
+ Element => Entity_Id,
+ No_Element => Empty,
+ Key => Entity_Id,
+ Hash => New_Copy_Hash,
+ Equal => Types."=");
- -- The hash table NCT_Itype_Assoc contains entries only for those
- -- old nodes which have a non-empty Associated_Node_For_Itype set.
- -- The key is the associated node, and the element is the new node
- -- itself (NOT the associated node for the new node).
-
- package NCT_Itype_Assoc is new Simple_HTable (
- Header_Num => NCT_Header_Num,
- Element => Entity_Id,
- No_Element => Empty,
- Key => Entity_Id,
- Hash => New_Copy_Hash,
- Equal => Types."=");
+ ---------------------
+ -- NCT_Itype_Assoc --
+ ---------------------
- -------------------
- -- New_Copy_Tree --
- -------------------
+ -- The hash table NCT_Itype_Assoc contains entries only for those old
+ -- nodes which have a non-empty Associated_Node_For_Itype set. The key
+ -- is the associated node, and the element is the new node itself (NOT
+ -- the associated node for the new node).
- function New_Copy_Tree
- (Source : Node_Id;
- Map : Elist_Id := No_Elist;
- New_Sloc : Source_Ptr := No_Location;
- New_Scope : Entity_Id := Empty) return Node_Id
- is
- Actual_Map : Elist_Id := Map;
- -- This is the actual map for the copy. It is initialized with the
- -- given elements, and then enlarged as required for Itypes that are
- -- copied during the first phase of the copy operation. The visit
- -- procedures add elements to this map as Itypes are encountered.
- -- The reason we cannot use Map directly, is that it may well be
- -- (and normally is) initialized to No_Elist, and if we have mapped
- -- entities, we have to reset it to point to a real Elist.
+ package NCT_Itype_Assoc is new Simple_HTable (
+ Header_Num => NCT_Header_Num,
+ Element => Entity_Id,
+ No_Element => Empty,
+ Key => Entity_Id,
+ Hash => New_Copy_Hash,
+ Equal => Types."=");
function Assoc (N : Node_Or_Entity_Id) return Node_Id;
-- Called during second phase to map entities into their corresponding
- -- copies using Actual_Map. If the argument is not an entity, or is not
- -- in Actual_Map, then it is returned unchanged.
+ -- copies using the hash table. If the argument is not an entity, or is
+ -- not in the hash table, then it is returned unchanged.
procedure Build_NCT_Hash_Tables;
- -- Builds hash tables (number of elements >= threshold value)
+ -- Builds hash tables.
function Copy_Elist_With_Replacement
(Old_Elist : Elist_Id) return Elist_Id;
@@ -15260,7 +16300,7 @@ package body Sem_Util is
procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id);
-- Called during the second phase to process a copied Itype. The actual
-- copy happened during the first phase (so that we could make the entry
- -- in the mapping), but we still have to deal with the descendents of
+ -- in the mapping), but we still have to deal with the descendants of
-- the copied Itype and copy them where necessary.
function Copy_List_With_Replacement (Old_List : List_Id) return List_Id;
@@ -15273,9 +16313,9 @@ package body Sem_Util is
-- Called during first phase to visit all elements of an Elist
procedure Visit_Field (F : Union_Id; N : Node_Id);
- -- Visit a single field, recursing to call Visit_Node or Visit_List
- -- if the field is a syntactic descendent of the current node (i.e.
- -- its parent is Node N).
+ -- Visit a single field, recursing to call Visit_Node or Visit_List if
+ -- the field is a syntactic descendant of the current node (i.e. its
+ -- parent is Node N).
procedure Visit_Itype (Old_Itype : Entity_Id);
-- Called during first phase to visit subsidiary fields of a defining
@@ -15293,33 +16333,18 @@ package body Sem_Util is
-----------
function Assoc (N : Node_Or_Entity_Id) return Node_Id is
- E : Elmt_Id;
Ent : Entity_Id;
begin
- if not Has_Extension (N) or else No (Actual_Map) then
+ if Nkind (N) not in N_Entity then
return N;
- elsif NCT_Hash_Tables_Used then
+ else
Ent := NCT_Assoc.Get (Entity_Id (N));
if Present (Ent) then
return Ent;
- else
- return N;
end if;
-
- -- No hash table used, do serial search
-
- else
- E := First_Elmt (Actual_Map);
- while Present (E) loop
- if Node (E) = N then
- return Node (Next_Elmt (E));
- else
- E := Next_Elmt (Next_Elmt (E));
- end if;
- end loop;
end if;
return N;
@@ -15332,13 +16357,13 @@ package body Sem_Util is
procedure Build_NCT_Hash_Tables is
Elmt : Elmt_Id;
Ent : Entity_Id;
+
begin
- if NCT_Hash_Table_Setup then
- NCT_Assoc.Reset;
- NCT_Itype_Assoc.Reset;
+ if No (Map) then
+ return;
end if;
- Elmt := First_Elmt (Actual_Map);
+ Elmt := First_Elmt (Map);
while Present (Elmt) loop
Ent := Node (Elmt);
@@ -15355,9 +16380,9 @@ package body Sem_Util is
begin
if Present (Anode) then
- -- Enter a link between the associated node of the
- -- old Itype and the new Itype, for updating later
- -- when node is copied.
+ -- Enter a link between the associated node of the old
+ -- Itype and the new Itype, for updating later when node
+ -- is copied.
NCT_Itype_Assoc.Set (Anode, Node (Elmt));
end if;
@@ -15366,9 +16391,6 @@ package body Sem_Util is
Next_Elmt (Elmt);
end loop;
-
- NCT_Hash_Tables_Used := True;
- NCT_Hash_Table_Setup := True;
end Build_NCT_Hash_Tables;
---------------------------------
@@ -15406,7 +16428,7 @@ package body Sem_Util is
procedure Copy_Itype_With_Replacement (New_Itype : Entity_Id) is
begin
- -- Translate Next_Entity, Scope and Etype fields, in case they
+ -- Translate Next_Entity, Scope, and Etype fields, in case they
-- reference entities that have been mapped into copies.
Set_Next_Entity (New_Itype, Assoc (Next_Entity (New_Itype)));
@@ -15516,19 +16538,18 @@ package body Sem_Util is
if Nkind (Old_E) = N_Parameter_Association
and then Present (Next_Named_Actual (Old_E))
then
- if First_Named_Actual (Old_Node)
- = Explicit_Actual_Parameter (Old_E)
+ if First_Named_Actual (Old_Node) =
+ Explicit_Actual_Parameter (Old_E)
then
Set_First_Named_Actual
(New_Node, Explicit_Actual_Parameter (New_E));
end if;
- -- Now scan parameter list from the beginning,to locate
+ -- Now scan parameter list from the beginning, to locate
-- next named actual, which can be out of order.
Old_Next := First (Parameter_Associations (Old_Node));
New_Next := First (Parameter_Associations (New_Node));
-
while Nkind (Old_Next) /= N_Parameter_Association
or else Explicit_Actual_Parameter (Old_Next) /=
Next_Named_Actual (Old_E)
@@ -15618,7 +16639,7 @@ package body Sem_Util is
if Old_Node <= Empty_Or_Error then
return Old_Node;
- elsif Has_Extension (Old_Node) then
+ elsif Nkind (Old_Node) in N_Entity then
return Assoc (Old_Node);
else
@@ -15628,41 +16649,16 @@ package body Sem_Util is
-- previously copied Itype, then adjust the associated node
-- of the copy of that Itype accordingly.
- if Present (Actual_Map) then
- declare
- E : Elmt_Id;
- Ent : Entity_Id;
-
- begin
- -- Case of hash table used
-
- if NCT_Hash_Tables_Used then
- Ent := NCT_Itype_Assoc.Get (Old_Node);
-
- if Present (Ent) then
- Set_Associated_Node_For_Itype (Ent, New_Node);
- end if;
-
- -- Case of no hash table used
-
- else
- E := First_Elmt (Actual_Map);
- while Present (E) loop
- if Is_Itype (Node (E))
- and then
- Old_Node = Associated_Node_For_Itype (Node (E))
- then
- Set_Associated_Node_For_Itype
- (Node (Next_Elmt (E)), New_Node);
- end if;
+ declare
+ Ent : constant Entity_Id := NCT_Itype_Assoc.Get (Old_Node);
- E := Next_Elmt (Next_Elmt (E));
- end loop;
- end if;
- end;
- end if;
+ begin
+ if Present (Ent) then
+ Set_Associated_Node_For_Itype (Ent, New_Node);
+ end if;
+ end;
- -- Recursively copy descendents
+ -- Recursively copy descendants
Set_Field1
(New_Node, Copy_Field_With_Replacement (Field1 (New_Node)));
@@ -15680,21 +16676,20 @@ package body Sem_Util is
if New_Sloc /= No_Location then
Set_Sloc (New_Node, New_Sloc);
- -- If we adjust the Sloc, then we are essentially making
- -- a completely new node, so the Comes_From_Source flag
- -- should be reset to the proper default value.
+ -- If we adjust the Sloc, then we are essentially making a
+ -- completely new node, so the Comes_From_Source flag should
+ -- be reset to the proper default value.
- Nodes.Table (New_Node).Comes_From_Source :=
- Default_Node.Comes_From_Source;
+ Set_Comes_From_Source
+ (New_Node, Default_Node.Comes_From_Source);
end if;
- -- If the node is call and has named associations,
- -- set the corresponding links in the copy.
+ -- If the node is a call and has named associations, set the
+ -- corresponding links in the copy.
- if (Nkind (Old_Node) = N_Function_Call
- or else Nkind (Old_Node) = N_Entry_Call_Statement
- or else
- Nkind (Old_Node) = N_Procedure_Call_Statement)
+ if Nkind_In (Old_Node, N_Entry_Call_Statement,
+ N_Function_Call,
+ N_Procedure_Call_Statement)
and then Present (First_Named_Actual (Old_Node))
then
Adjust_Named_Associations (Old_Node, New_Node);
@@ -15731,6 +16726,15 @@ package body Sem_Util is
return New_Node;
end Copy_Node_With_Replacement;
+ -------------------
+ -- New_Copy_Hash --
+ -------------------
+
+ function New_Copy_Hash (E : Entity_Id) return NCT_Header_Num is
+ begin
+ return Nat (E) mod (NCT_Header_Num'Last + 1);
+ end New_Copy_Hash;
+
-----------------
-- Visit_Elist --
-----------------
@@ -15775,10 +16779,10 @@ package body Sem_Util is
-- Note: the exclusion of self-referential copies is just an
-- optimization, since the search of the already copied list
- -- would catch it, but it is a common case (Etype pointing
- -- to itself for an Itype that is a base type).
+ -- would catch it, but it is a common case (Etype pointing to
+ -- itself for an Itype that is a base type).
- elsif Has_Extension (Node_Id (F))
+ elsif Nkind (Node_Id (F)) in N_Entity
and then Is_Itype (Entity_Id (F))
and then Node_Id (F) /= N
then
@@ -15816,7 +16820,6 @@ package body Sem_Util is
procedure Visit_Itype (Old_Itype : Entity_Id) is
New_Itype : Entity_Id;
- E : Elmt_Id;
Ent : Entity_Id;
begin
@@ -15832,8 +16835,8 @@ package body Sem_Util is
New_Itype := New_Copy (Old_Itype);
- -- The new Itype has all the attributes of the old one, and
- -- we just copy the contents of the entity. However, the back-end
+ -- The new Itype has all the attributes of the old one, and we
+ -- just copy the contents of the entity. However, the back-end
-- needs different names for debugging purposes, so we create a
-- new internal name for it in all cases.
@@ -15845,50 +16848,23 @@ package body Sem_Util is
-- node of some previously copied Itype, then we set the right
-- pointer in the other direction.
- if Present (Actual_Map) then
-
- -- Case of hash tables used
-
- if NCT_Hash_Tables_Used then
+ Ent := NCT_Assoc.Get (Associated_Node_For_Itype (Old_Itype));
- Ent := NCT_Assoc.Get (Associated_Node_For_Itype (Old_Itype));
-
- if Present (Ent) then
- Set_Associated_Node_For_Itype (New_Itype, Ent);
- end if;
-
- Ent := NCT_Itype_Assoc.Get (Old_Itype);
- if Present (Ent) then
- Set_Associated_Node_For_Itype (Ent, New_Itype);
-
- -- If the hash table has no association for this Itype and
- -- its associated node, enter one now.
-
- else
- NCT_Itype_Assoc.Set
- (Associated_Node_For_Itype (Old_Itype), New_Itype);
- end if;
+ if Present (Ent) then
+ Set_Associated_Node_For_Itype (New_Itype, Ent);
+ end if;
- -- Case of hash tables not used
+ Ent := NCT_Itype_Assoc.Get (Old_Itype);
- else
- E := First_Elmt (Actual_Map);
- while Present (E) loop
- if Associated_Node_For_Itype (Old_Itype) = Node (E) then
- Set_Associated_Node_For_Itype
- (New_Itype, Node (Next_Elmt (E)));
- end if;
+ if Present (Ent) then
+ Set_Associated_Node_For_Itype (Ent, New_Itype);
- if Is_Type (Node (E))
- and then Old_Itype = Associated_Node_For_Itype (Node (E))
- then
- Set_Associated_Node_For_Itype
- (Node (Next_Elmt (E)), New_Itype);
- end if;
+ -- If the hash table has no association for this Itype and its
+ -- associated node, enter one now.
- E := Next_Elmt (Next_Elmt (E));
- end loop;
- end if;
+ else
+ NCT_Itype_Assoc.Set
+ (Associated_Node_For_Itype (Old_Itype), New_Itype);
end if;
if Present (Freeze_Node (New_Itype)) then
@@ -15898,32 +16874,16 @@ package body Sem_Util is
-- Add new association to map
- if No (Actual_Map) then
- Actual_Map := New_Elmt_List;
- end if;
-
- Append_Elmt (Old_Itype, Actual_Map);
- Append_Elmt (New_Itype, Actual_Map);
-
- if NCT_Hash_Tables_Used then
- NCT_Assoc.Set (Old_Itype, New_Itype);
-
- else
- NCT_Table_Entries := NCT_Table_Entries + 1;
-
- if NCT_Table_Entries > NCT_Hash_Threshold then
- Build_NCT_Hash_Tables;
- end if;
- end if;
+ NCT_Assoc.Set (Old_Itype, New_Itype);
-- If a record subtype is simply copied, the entity list will be
-- shared. Thus cloned_Subtype must be set to indicate the sharing.
- if Ekind_In (Old_Itype, E_Record_Subtype, E_Class_Wide_Subtype) then
+ if Ekind_In (Old_Itype, E_Class_Wide_Subtype, E_Record_Subtype) then
Set_Cloned_Subtype (New_Itype, Old_Itype);
end if;
- -- Visit descendents that eventually get copied
+ -- Visit descendants that eventually get copied
Visit_Field (Union_Id (Etype (Old_Itype)), Old_Itype);
@@ -15936,14 +16896,14 @@ package body Sem_Util is
elsif Is_Array_Type (Old_Itype) then
if Present (First_Index (Old_Itype)) then
- Visit_Field (Union_Id (List_Containing
- (First_Index (Old_Itype))),
- Old_Itype);
+ Visit_Field
+ (Union_Id (List_Containing (First_Index (Old_Itype))),
+ Old_Itype);
end if;
if Is_Packed (Old_Itype) then
- Visit_Field (Union_Id (Packed_Array_Impl_Type (Old_Itype)),
- Old_Itype);
+ Visit_Field
+ (Union_Id (Packed_Array_Impl_Type (Old_Itype)), Old_Itype);
end if;
end if;
end Visit_Itype;
@@ -15970,48 +16930,23 @@ package body Sem_Util is
----------------
procedure Visit_Node (N : Node_Or_Entity_Id) is
-
- -- Start of processing for Visit_Node
-
begin
-- Handle case of an Itype, which must be copied
- if Has_Extension (N) and then Is_Itype (N) then
+ if Nkind (N) in N_Entity and then Is_Itype (N) then
-- Nothing to do if already in the list. This can happen with an
- -- Itype entity that appears more than once in the tree.
- -- Note that we do not want to visit descendents in this case.
-
- -- Test for already in list when hash table is used
-
- if NCT_Hash_Tables_Used then
- if Present (NCT_Assoc.Get (Entity_Id (N))) then
- return;
- end if;
-
- -- Test for already in list when hash table not used
+ -- Itype entity that appears more than once in the tree. Note that
+ -- we do not want to visit descendants in this case.
- else
- declare
- E : Elmt_Id;
- begin
- if Present (Actual_Map) then
- E := First_Elmt (Actual_Map);
- while Present (E) loop
- if Node (E) = N then
- return;
- else
- E := Next_Elmt (Next_Elmt (E));
- end if;
- end loop;
- end if;
- end;
+ if Present (NCT_Assoc.Get (Entity_Id (N))) then
+ return;
end if;
Visit_Itype (N);
end if;
- -- Visit descendents
+ -- Visit descendants
Visit_Field (Field1 (N), N);
Visit_Field (Field2 (N), N);
@@ -16023,64 +16958,42 @@ package body Sem_Util is
-- Start of processing for New_Copy_Tree
begin
- Actual_Map := Map;
-
- -- See if we should use hash table
+ Build_NCT_Hash_Tables;
- if No (Actual_Map) then
- NCT_Hash_Tables_Used := False;
+ -- Hash table set up if required, now start phase one by visiting top
+ -- node (we will recursively visit the descendants).
- else
- declare
- Elmt : Elmt_Id;
+ Visit_Node (Source);
- begin
- NCT_Table_Entries := 0;
+ -- Now the second phase of the copy can start. First we process all the
+ -- mapped entities, copying their descendants.
- Elmt := First_Elmt (Actual_Map);
- while Present (Elmt) loop
- NCT_Table_Entries := NCT_Table_Entries + 1;
- Next_Elmt (Elmt);
- Next_Elmt (Elmt);
- end loop;
+ declare
+ Old_E : Entity_Id := Empty;
+ New_E : Entity_Id;
- if NCT_Table_Entries > NCT_Hash_Threshold then
- Build_NCT_Hash_Tables;
- else
- NCT_Hash_Tables_Used := False;
+ begin
+ NCT_Assoc.Get_First (Old_E, New_E);
+ while Present (New_E) loop
+ if Is_Itype (New_E) then
+ Copy_Itype_With_Replacement (New_E);
end if;
- end;
- end if;
-
- -- Hash table set up if required, now start phase one by visiting
- -- top node (we will recursively visit the descendents).
- Visit_Node (Source);
-
- -- Now the second phase of the copy can start. First we process
- -- all the mapped entities, copying their descendents.
+ NCT_Assoc.Get_Next (Old_E, New_E);
+ end loop;
+ end;
- if Present (Actual_Map) then
- declare
- Elmt : Elmt_Id;
- New_Itype : Entity_Id;
- begin
- Elmt := First_Elmt (Actual_Map);
- while Present (Elmt) loop
- Next_Elmt (Elmt);
- New_Itype := Node (Elmt);
+ -- Now we can copy the actual tree
- if Is_Itype (New_Itype) then
- Copy_Itype_With_Replacement (New_Itype);
- end if;
- Next_Elmt (Elmt);
- end loop;
- end;
- end if;
+ declare
+ Result : constant Node_Id := Copy_Node_With_Replacement (Source);
- -- Now we can copy the actual tree
+ begin
+ NCT_Assoc.Reset;
+ NCT_Itype_Assoc.Reset;
- return Copy_Node_With_Replacement (Source);
+ return Result;
+ end;
end New_Copy_Tree;
-------------------------
@@ -16174,6 +17087,232 @@ package body Sem_Util is
Actual_Id := Next_Actual (Actual_Id);
end Next_Actual;
+ ----------------------------------
+ -- New_Requires_Transient_Scope --
+ ----------------------------------
+
+ function New_Requires_Transient_Scope (Id : Entity_Id) return Boolean is
+ function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean;
+ -- This is called for untagged records and protected types, with
+ -- nondefaulted discriminants. Returns True if the size of function
+ -- results is known at the call site, False otherwise. Returns False
+ -- if there is a variant part that depends on the discriminants of
+ -- this type, or if there is an array constrained by the discriminants
+ -- of this type. ???Currently, this is overly conservative (the array
+ -- could be nested inside some other record that is constrained by
+ -- nondiscriminants). That is, the recursive calls are too conservative.
+
+ function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean;
+ -- Returns True if Typ is a nonlimited record with defaulted
+ -- discriminants whose max size makes it unsuitable for allocating on
+ -- the primary stack.
+
+ ------------------------------
+ -- Caller_Known_Size_Record --
+ ------------------------------
+
+ function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean is
+ pragma Assert (Typ = Underlying_Type (Typ));
+
+ begin
+ if Has_Variant_Part (Typ) and then not Is_Definite_Subtype (Typ) then
+ return False;
+ end if;
+
+ declare
+ Comp : Entity_Id;
+
+ begin
+ Comp := First_Entity (Typ);
+ while Present (Comp) loop
+
+ -- Only look at E_Component entities. No need to look at
+ -- E_Discriminant entities, and we must ignore internal
+ -- subtypes generated for constrained components.
+
+ if Ekind (Comp) = E_Component then
+ declare
+ Comp_Type : constant Entity_Id :=
+ Underlying_Type (Etype (Comp));
+
+ begin
+ if Is_Record_Type (Comp_Type)
+ or else
+ Is_Protected_Type (Comp_Type)
+ then
+ if not Caller_Known_Size_Record (Comp_Type) then
+ return False;
+ end if;
+
+ elsif Is_Array_Type (Comp_Type) then
+ if Size_Depends_On_Discriminant (Comp_Type) then
+ return False;
+ end if;
+ end if;
+ end;
+ end if;
+
+ Next_Entity (Comp);
+ end loop;
+ end;
+
+ return True;
+ end Caller_Known_Size_Record;
+
+ ------------------------------
+ -- Large_Max_Size_Mutable --
+ ------------------------------
+
+ function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean is
+ pragma Assert (Typ = Underlying_Type (Typ));
+
+ function Is_Large_Discrete_Type (T : Entity_Id) return Boolean;
+ -- Returns true if the discrete type T has a large range
+
+ ----------------------------
+ -- Is_Large_Discrete_Type --
+ ----------------------------
+
+ function Is_Large_Discrete_Type (T : Entity_Id) return Boolean is
+ Threshold : constant Int := 16;
+ -- Arbitrary threshold above which we consider it "large". We want
+ -- a fairly large threshold, because these large types really
+ -- shouldn't have default discriminants in the first place, in
+ -- most cases.
+
+ begin
+ return UI_To_Int (RM_Size (T)) > Threshold;
+ end Is_Large_Discrete_Type;
+
+ -- Start of processing for Large_Max_Size_Mutable
+
+ begin
+ if Is_Record_Type (Typ)
+ and then not Is_Limited_View (Typ)
+ and then Has_Defaulted_Discriminants (Typ)
+ then
+ -- Loop through the components, looking for an array whose upper
+ -- bound(s) depends on discriminants, where both the subtype of
+ -- the discriminant and the index subtype are too large.
+
+ declare
+ Comp : Entity_Id;
+
+ begin
+ Comp := First_Entity (Typ);
+ while Present (Comp) loop
+ if Ekind (Comp) = E_Component then
+ declare
+ Comp_Type : constant Entity_Id :=
+ Underlying_Type (Etype (Comp));
+
+ Hi : Node_Id;
+ Indx : Node_Id;
+ Ityp : Entity_Id;
+
+ begin
+ if Is_Array_Type (Comp_Type) then
+ Indx := First_Index (Comp_Type);
+
+ while Present (Indx) loop
+ Ityp := Etype (Indx);
+ Hi := Type_High_Bound (Ityp);
+
+ if Nkind (Hi) = N_Identifier
+ and then Ekind (Entity (Hi)) = E_Discriminant
+ and then Is_Large_Discrete_Type (Ityp)
+ and then Is_Large_Discrete_Type
+ (Etype (Entity (Hi)))
+ then
+ return True;
+ end if;
+
+ Next_Index (Indx);
+ end loop;
+ end if;
+ end;
+ end if;
+
+ Next_Entity (Comp);
+ end loop;
+ end;
+ end if;
+
+ return False;
+ end Large_Max_Size_Mutable;
+
+ -- Local declarations
+
+ Typ : constant Entity_Id := Underlying_Type (Id);
+
+ -- Start of processing for New_Requires_Transient_Scope
+
+ begin
+ -- This is a private type which is not completed yet. This can only
+ -- happen in a default expression (of a formal parameter or of a
+ -- record component). Do not expand transient scope in this case.
+
+ if No (Typ) then
+ return False;
+
+ -- Do not expand transient scope for non-existent procedure return or
+ -- string literal types.
+
+ elsif Typ = Standard_Void_Type
+ or else Ekind (Typ) = E_String_Literal_Subtype
+ then
+ return False;
+
+ -- If Typ is a generic formal incomplete type, then we want to look at
+ -- the actual type.
+
+ elsif Ekind (Typ) = E_Record_Subtype
+ and then Present (Cloned_Subtype (Typ))
+ then
+ return New_Requires_Transient_Scope (Cloned_Subtype (Typ));
+
+ -- Functions returning specific tagged types may dispatch on result, so
+ -- their returned value is allocated on the secondary stack, even in the
+ -- definite case. We must treat nondispatching functions the same way,
+ -- because access-to-function types can point at both, so the calling
+ -- conventions must be compatible. Is_Tagged_Type includes controlled
+ -- types and class-wide types. Controlled type temporaries need
+ -- finalization.
+
+ -- ???It's not clear why we need to return noncontrolled types with
+ -- controlled components on the secondary stack.
+
+ elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then
+ return True;
+
+ -- Untagged definite subtypes are known size. This includes all
+ -- elementary [sub]types. Tasks are known size even if they have
+ -- discriminants. So we return False here, with one exception:
+ -- For a type like:
+ -- type T (Last : Natural := 0) is
+ -- X : String (1 .. Last);
+ -- end record;
+ -- we return True. That's because for "P(F(...));", where F returns T,
+ -- we don't know the size of the result at the call site, so if we
+ -- allocated it on the primary stack, we would have to allocate the
+ -- maximum size, which is way too big.
+
+ elsif Is_Definite_Subtype (Typ) or else Is_Task_Type (Typ) then
+ return Large_Max_Size_Mutable (Typ);
+
+ -- Indefinite (discriminated) untagged record or protected type
+
+ elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then
+ return not Caller_Known_Size_Record (Typ);
+
+ -- Unconstrained array
+
+ else
+ pragma Assert (Is_Array_Type (Typ) and not Is_Definite_Subtype (Typ));
+ return True;
+ end if;
+ end New_Requires_Transient_Scope;
+
-----------------------
-- Normalize_Actuals --
-----------------------
@@ -16445,9 +17584,24 @@ package body Sem_Util is
and then Actual /= Last
and then No (Next_Named_Actual (Actual))
then
- Error_Msg_N ("unmatched actual & in call",
- Selector_Name (Actual));
- exit;
+ -- A validity check may introduce a copy of a call that
+ -- includes an extra actual (for example for an unrelated
+ -- accessibility check). Check that the extra actual matches
+ -- some extra formal, which must exist already because
+ -- subprogram must be frozen at this point.
+
+ if Present (Extra_Formals (S))
+ and then not Comes_From_Source (Actual)
+ and then Nkind (Actual) = N_Parameter_Association
+ and then Chars (Extra_Formals (S)) =
+ Chars (Selector_Name (Actual))
+ then
+ null;
+ else
+ Error_Msg_N
+ ("unmatched actual & in call", Selector_Name (Actual));
+ exit;
+ end if;
end if;
Next (Actual);
@@ -16563,11 +17717,20 @@ package body Sem_Util is
if Comes_From_Source (Exp)
or else Modification_Comes_From_Source
then
- -- Give warning if pragma unmodified given and we are
+ -- Give warning if pragma unmodified is given and we are
-- sure this is a modification.
if Has_Pragma_Unmodified (Ent) and then Sure then
- Error_Msg_NE ("??pragma Unmodified given for &!", N, Ent);
+
+ -- Note that the entity may be present only as a result
+ -- of pragma Unused.
+
+ if Has_Pragma_Unused (Ent) then
+ Error_Msg_NE ("??pragma Unused given for &!", N, Ent);
+ else
+ Error_Msg_NE
+ ("??pragma Unmodified given for &!", N, Ent);
+ end if;
end if;
Set_Never_Set_In_Source (Ent, False);
@@ -16680,6 +17843,44 @@ package body Sem_Util is
end loop;
end Note_Possible_Modification;
+ --------------------------------------
+ -- Null_To_Null_Address_Convert_OK --
+ --------------------------------------
+
+ function Null_To_Null_Address_Convert_OK
+ (N : Node_Id;
+ Typ : Entity_Id := Empty) return Boolean
+ is
+ begin
+ if not Relaxed_RM_Semantics then
+ return False;
+ end if;
+
+ if Nkind (N) = N_Null then
+ return Present (Typ) and then Is_Descendant_Of_Address (Typ);
+
+ elsif Nkind_In (N, N_Op_Eq, N_Op_Ge, N_Op_Gt, N_Op_Le, N_Op_Lt, N_Op_Ne)
+ then
+ declare
+ L : constant Node_Id := Left_Opnd (N);
+ R : constant Node_Id := Right_Opnd (N);
+
+ begin
+ -- We check the Etype of the complementary operand since the
+ -- N_Null node is not decorated at this stage.
+
+ return
+ ((Nkind (L) = N_Null
+ and then Is_Descendant_Of_Address (Etype (R)))
+ or else
+ (Nkind (R) = N_Null
+ and then Is_Descendant_Of_Address (Etype (L))));
+ end;
+ end if;
+
+ return False;
+ end Null_To_Null_Address_Convert_OK;
+
-------------------------
-- Object_Access_Level --
-------------------------
@@ -16884,7 +18085,6 @@ package body Sem_Util is
else
Return_Master_Scope_Depth_Of_Call : declare
-
function Innermost_Master_Scope_Depth
(N : Node_Id) return Uint;
-- Returns the scope depth of the given node's innermost
@@ -16907,42 +18107,42 @@ package body Sem_Util is
while Present (Node_Par) loop
case Nkind (Node_Par) is
- when N_Component_Declaration |
- N_Entry_Declaration |
- N_Formal_Object_Declaration |
- N_Formal_Type_Declaration |
- N_Full_Type_Declaration |
- N_Incomplete_Type_Declaration |
- N_Loop_Parameter_Specification |
- N_Object_Declaration |
- N_Protected_Type_Declaration |
- N_Private_Extension_Declaration |
- N_Private_Type_Declaration |
- N_Subtype_Declaration |
- N_Function_Specification |
- N_Procedure_Specification |
- N_Task_Type_Declaration |
- N_Body_Stub |
- N_Generic_Instantiation |
- N_Proper_Body |
- N_Implicit_Label_Declaration |
- N_Package_Declaration |
- N_Single_Task_Declaration |
- N_Subprogram_Declaration |
- N_Generic_Declaration |
- N_Renaming_Declaration |
- N_Block_Statement |
- N_Formal_Subprogram_Declaration |
- N_Abstract_Subprogram_Declaration |
- N_Entry_Body |
- N_Exception_Declaration |
- N_Formal_Package_Declaration |
- N_Number_Declaration |
- N_Package_Specification |
- N_Parameter_Specification |
- N_Single_Protected_Declaration |
- N_Subunit =>
-
+ when N_Abstract_Subprogram_Declaration
+ | N_Block_Statement
+ | N_Body_Stub
+ | N_Component_Declaration
+ | N_Entry_Body
+ | N_Entry_Declaration
+ | N_Exception_Declaration
+ | N_Formal_Object_Declaration
+ | N_Formal_Package_Declaration
+ | N_Formal_Subprogram_Declaration
+ | N_Formal_Type_Declaration
+ | N_Full_Type_Declaration
+ | N_Function_Specification
+ | N_Generic_Declaration
+ | N_Generic_Instantiation
+ | N_Implicit_Label_Declaration
+ | N_Incomplete_Type_Declaration
+ | N_Loop_Parameter_Specification
+ | N_Number_Declaration
+ | N_Object_Declaration
+ | N_Package_Declaration
+ | N_Package_Specification
+ | N_Parameter_Specification
+ | N_Private_Extension_Declaration
+ | N_Private_Type_Declaration
+ | N_Procedure_Specification
+ | N_Proper_Body
+ | N_Protected_Type_Declaration
+ | N_Renaming_Declaration
+ | N_Single_Protected_Declaration
+ | N_Single_Task_Declaration
+ | N_Subprogram_Declaration
+ | N_Subtype_Declaration
+ | N_Subunit
+ | N_Task_Type_Declaration
+ =>
return Scope_Depth
(Nearest_Dynamic_Scope
(Defining_Entity (Node_Par)));
@@ -16989,6 +18189,105 @@ package body Sem_Util is
end if;
end Object_Access_Level;
+ ----------------------------------
+ -- Old_Requires_Transient_Scope --
+ ----------------------------------
+
+ function Old_Requires_Transient_Scope (Id : Entity_Id) return Boolean is
+ Typ : constant Entity_Id := Underlying_Type (Id);
+
+ begin
+ -- This is a private type which is not completed yet. This can only
+ -- happen in a default expression (of a formal parameter or of a
+ -- record component). Do not expand transient scope in this case.
+
+ if No (Typ) then
+ return False;
+
+ -- Do not expand transient scope for non-existent procedure return
+
+ elsif Typ = Standard_Void_Type then
+ return False;
+
+ -- Elementary types do not require a transient scope
+
+ elsif Is_Elementary_Type (Typ) then
+ return False;
+
+ -- Generally, indefinite subtypes require a transient scope, since the
+ -- back end cannot generate temporaries, since this is not a valid type
+ -- for declaring an object. It might be possible to relax this in the
+ -- future, e.g. by declaring the maximum possible space for the type.
+
+ elsif not Is_Definite_Subtype (Typ) then
+ return True;
+
+ -- Functions returning tagged types may dispatch on result so their
+ -- returned value is allocated on the secondary stack. Controlled
+ -- type temporaries need finalization.
+
+ elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then
+ return True;
+
+ -- Record type
+
+ elsif Is_Record_Type (Typ) then
+ declare
+ Comp : Entity_Id;
+
+ begin
+ Comp := First_Entity (Typ);
+ while Present (Comp) loop
+ if Ekind (Comp) = E_Component then
+
+ -- ???It's not clear we need a full recursive call to
+ -- Old_Requires_Transient_Scope here. Note that the
+ -- following can't happen.
+
+ pragma Assert (Is_Definite_Subtype (Etype (Comp)));
+ pragma Assert (not Has_Controlled_Component (Etype (Comp)));
+
+ if Old_Requires_Transient_Scope (Etype (Comp)) then
+ return True;
+ end if;
+ end if;
+
+ Next_Entity (Comp);
+ end loop;
+ end;
+
+ return False;
+
+ -- String literal types never require transient scope
+
+ elsif Ekind (Typ) = E_String_Literal_Subtype then
+ return False;
+
+ -- Array type. Note that we already know that this is a constrained
+ -- array, since unconstrained arrays will fail the indefinite test.
+
+ elsif Is_Array_Type (Typ) then
+
+ -- If component type requires a transient scope, the array does too
+
+ if Old_Requires_Transient_Scope (Component_Type (Typ)) then
+ return True;
+
+ -- Otherwise, we only need a transient scope if the size depends on
+ -- the value of one or more discriminants.
+
+ else
+ return Size_Depends_On_Discriminant (Typ);
+ end if;
+
+ -- All other cases do not require a transient scope
+
+ else
+ pragma Assert (Is_Protected_Type (Typ) or else Is_Task_Type (Typ));
+ return False;
+ end if;
+ end Old_Requires_Transient_Scope;
+
---------------------------------
-- Original_Aspect_Pragma_Name --
---------------------------------
@@ -17079,6 +18378,41 @@ package body Sem_Util is
end if;
end Original_Corresponding_Operation;
+ -------------------
+ -- Output_Entity --
+ -------------------
+
+ procedure Output_Entity (Id : Entity_Id) is
+ Scop : Entity_Id;
+
+ begin
+ Scop := Scope (Id);
+
+ -- The entity may lack a scope when it is in the process of being
+ -- analyzed. Use the current scope as an approximation.
+
+ if No (Scop) then
+ Scop := Current_Scope;
+ end if;
+
+ Output_Name (Chars (Id), Scop);
+ end Output_Entity;
+
+ -----------------
+ -- Output_Name --
+ -----------------
+
+ procedure Output_Name (Nam : Name_Id; Scop : Entity_Id := Current_Scope) is
+ begin
+ Write_Str
+ (Get_Name_String
+ (Get_Qualified_Name
+ (Nam => Nam,
+ Suffix => No_Name,
+ Scop => Scop)));
+ Write_Eol;
+ end Output_Name;
+
----------------------
-- Policy_In_Effect --
----------------------
@@ -17298,7 +18632,6 @@ package body Sem_Util is
---------------------------
function Primitive_Names_Match (E1, E2 : Entity_Id) return Boolean is
-
function Non_Internal_Name (E : Entity_Id) return Name_Id;
-- Given an internal name, returns the corresponding non-internal name
@@ -17518,6 +18851,127 @@ package body Sem_Util is
Set_Sloc (Endl, Loc);
end Process_End_Label;
+ --------------------------------
+ -- Propagate_Concurrent_Flags --
+ --------------------------------
+
+ procedure Propagate_Concurrent_Flags
+ (Typ : Entity_Id;
+ Comp_Typ : Entity_Id)
+ is
+ begin
+ if Has_Task (Comp_Typ) then
+ Set_Has_Task (Typ);
+ end if;
+
+ if Has_Protected (Comp_Typ) then
+ Set_Has_Protected (Typ);
+ end if;
+
+ if Has_Timing_Event (Comp_Typ) then
+ Set_Has_Timing_Event (Typ);
+ end if;
+ end Propagate_Concurrent_Flags;
+
+ ------------------------------
+ -- Propagate_DIC_Attributes --
+ ------------------------------
+
+ procedure Propagate_DIC_Attributes
+ (Typ : Entity_Id;
+ From_Typ : Entity_Id)
+ is
+ DIC_Proc : Entity_Id;
+
+ begin
+ if Present (Typ) and then Present (From_Typ) then
+ pragma Assert (Is_Type (Typ) and then Is_Type (From_Typ));
+
+ -- Nothing to do if both the source and the destination denote the
+ -- same type.
+
+ if From_Typ = Typ then
+ return;
+ end if;
+
+ DIC_Proc := DIC_Procedure (From_Typ);
+
+ -- The setting of the attributes is intentionally conservative. This
+ -- prevents accidental clobbering of enabled attributes.
+
+ if Has_Inherited_DIC (From_Typ)
+ and then not Has_Inherited_DIC (Typ)
+ then
+ Set_Has_Inherited_DIC (Typ);
+ end if;
+
+ if Has_Own_DIC (From_Typ) and then not Has_Own_DIC (Typ) then
+ Set_Has_Own_DIC (Typ);
+ end if;
+
+ if Present (DIC_Proc) and then No (DIC_Procedure (Typ)) then
+ Set_DIC_Procedure (Typ, DIC_Proc);
+ end if;
+ end if;
+ end Propagate_DIC_Attributes;
+
+ ------------------------------------
+ -- Propagate_Invariant_Attributes --
+ ------------------------------------
+
+ procedure Propagate_Invariant_Attributes
+ (Typ : Entity_Id;
+ From_Typ : Entity_Id)
+ is
+ Full_IP : Entity_Id;
+ Part_IP : Entity_Id;
+
+ begin
+ if Present (Typ) and then Present (From_Typ) then
+ pragma Assert (Is_Type (Typ) and then Is_Type (From_Typ));
+
+ -- Nothing to do if both the source and the destination denote the
+ -- same type.
+
+ if From_Typ = Typ then
+ return;
+ end if;
+
+ Full_IP := Invariant_Procedure (From_Typ);
+ Part_IP := Partial_Invariant_Procedure (From_Typ);
+
+ -- The setting of the attributes is intentionally conservative. This
+ -- prevents accidental clobbering of enabled attributes.
+
+ if Has_Inheritable_Invariants (From_Typ)
+ and then not Has_Inheritable_Invariants (Typ)
+ then
+ Set_Has_Inheritable_Invariants (Typ, True);
+ end if;
+
+ if Has_Inherited_Invariants (From_Typ)
+ and then not Has_Inherited_Invariants (Typ)
+ then
+ Set_Has_Inherited_Invariants (Typ, True);
+ end if;
+
+ if Has_Own_Invariants (From_Typ)
+ and then not Has_Own_Invariants (Typ)
+ then
+ Set_Has_Own_Invariants (Typ, True);
+ end if;
+
+ if Present (Full_IP) and then No (Invariant_Procedure (Typ)) then
+ Set_Invariant_Procedure (Typ, Full_IP);
+ end if;
+
+ if Present (Part_IP) and then No (Partial_Invariant_Procedure (Typ))
+ then
+ Set_Partial_Invariant_Procedure (Typ, Part_IP);
+ end if;
+ end if;
+ end Propagate_Invariant_Attributes;
+
---------------------------------------
-- Record_Possible_Part_Of_Reference --
---------------------------------------
@@ -17792,81 +19246,6 @@ package body Sem_Util is
end if;
end Require_Entity;
- -------------------------------
- -- Requires_State_Refinement --
- -------------------------------
-
- function Requires_State_Refinement
- (Spec_Id : Entity_Id;
- Body_Id : Entity_Id) return Boolean
- is
- function Mode_Is_Off (Prag : Node_Id) return Boolean;
- -- Given pragma SPARK_Mode, determine whether the mode is Off
-
- -----------------
- -- Mode_Is_Off --
- -----------------
-
- function Mode_Is_Off (Prag : Node_Id) return Boolean is
- Mode : Node_Id;
-
- begin
- -- The default SPARK mode is On
-
- if No (Prag) then
- return False;
- end if;
-
- Mode := Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
-
- -- Then the pragma lacks an argument, the default mode is On
-
- if No (Mode) then
- return False;
- else
- return Chars (Mode) = Name_Off;
- end if;
- end Mode_Is_Off;
-
- -- Start of processing for Requires_State_Refinement
-
- begin
- -- A package that does not define at least one abstract state cannot
- -- possibly require refinement.
-
- if No (Abstract_States (Spec_Id)) then
- return False;
-
- -- The package instroduces a single null state which does not merit
- -- refinement.
-
- elsif Has_Null_Abstract_State (Spec_Id) then
- return False;
-
- -- Check whether the package body is subject to pragma SPARK_Mode. If
- -- it is and the mode is Off, the package body is considered to be in
- -- regular Ada and does not require refinement.
-
- elsif Mode_Is_Off (SPARK_Pragma (Body_Id)) then
- return False;
-
- -- The body's SPARK_Mode may be inherited from a similar pragma that
- -- appears in the private declarations of the spec. The pragma we are
- -- interested appears as the second entry in SPARK_Pragma.
-
- elsif Present (SPARK_Pragma (Spec_Id))
- and then Mode_Is_Off (Next_Pragma (SPARK_Pragma (Spec_Id)))
- then
- return False;
-
- -- The spec defines at least one abstract state and the body has no way
- -- of circumventing the refinement.
-
- else
- return True;
- end if;
- end Requires_State_Refinement;
-
------------------------------
-- Requires_Transient_Scope --
------------------------------
@@ -17875,33 +19254,6 @@ package body Sem_Util is
-- allocated on the secondary stack, or when finalization actions must be
-- generated before the next instruction.
- function Old_Requires_Transient_Scope (Id : Entity_Id) return Boolean;
- function New_Requires_Transient_Scope (Id : Entity_Id) return Boolean;
- -- ???We retain the old and new algorithms for Requires_Transient_Scope for
- -- the time being. New_Requires_Transient_Scope is used by default; the
- -- debug switch -gnatdQ can be used to do Old_Requires_Transient_Scope
- -- instead. The intent is to use this temporarily to measure before/after
- -- efficiency. Note: when this temporary code is removed, the documentation
- -- of dQ in debug.adb should be removed.
-
- procedure Results_Differ (Id : Entity_Id);
- -- ???Debugging code. Called when the Old_ and New_ results differ. Will be
- -- removed when New_Requires_Transient_Scope becomes
- -- Requires_Transient_Scope and Old_Requires_Transient_Scope is eliminated.
-
- procedure Results_Differ (Id : Entity_Id) is
- begin
- if False then -- False to disable; True for debugging
- Treepr.Print_Tree_Node (Id);
-
- if Old_Requires_Transient_Scope (Id) =
- New_Requires_Transient_Scope (Id)
- then
- raise Program_Error;
- end if;
- end if;
- end Results_Differ;
-
function Requires_Transient_Scope (Id : Entity_Id) return Boolean is
Old_Result : constant Boolean := Old_Requires_Transient_Scope (Id);
@@ -17924,342 +19276,37 @@ package body Sem_Util is
end if;
if New_Result /= Old_Result then
- Results_Differ (Id);
+ Results_Differ (Id, Old_Result, New_Result);
end if;
return New_Result;
end;
end Requires_Transient_Scope;
- ----------------------------------
- -- Old_Requires_Transient_Scope --
- ----------------------------------
-
- function Old_Requires_Transient_Scope (Id : Entity_Id) return Boolean is
- Typ : constant Entity_Id := Underlying_Type (Id);
+ --------------------
+ -- Results_Differ --
+ --------------------
+ procedure Results_Differ
+ (Id : Entity_Id;
+ Old_Val : Boolean;
+ New_Val : Boolean)
+ is
begin
- -- This is a private type which is not completed yet. This can only
- -- happen in a default expression (of a formal parameter or of a
- -- record component). Do not expand transient scope in this case.
-
- if No (Typ) then
- return False;
-
- -- Do not expand transient scope for non-existent procedure return
-
- elsif Typ = Standard_Void_Type then
- return False;
-
- -- Elementary types do not require a transient scope
-
- elsif Is_Elementary_Type (Typ) then
- return False;
-
- -- Generally, indefinite subtypes require a transient scope, since the
- -- back end cannot generate temporaries, since this is not a valid type
- -- for declaring an object. It might be possible to relax this in the
- -- future, e.g. by declaring the maximum possible space for the type.
-
- elsif not Is_Definite_Subtype (Typ) then
- return True;
-
- -- Functions returning tagged types may dispatch on result so their
- -- returned value is allocated on the secondary stack. Controlled
- -- type temporaries need finalization.
-
- elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then
- return True;
-
- -- Record type
-
- elsif Is_Record_Type (Typ) then
- declare
- Comp : Entity_Id;
-
- begin
- Comp := First_Entity (Typ);
- while Present (Comp) loop
- if Ekind (Comp) = E_Component then
-
- -- ???It's not clear we need a full recursive call to
- -- Old_Requires_Transient_Scope here. Note that the
- -- following can't happen.
-
- pragma Assert (Is_Definite_Subtype (Etype (Comp)));
- pragma Assert (not Has_Controlled_Component (Etype (Comp)));
-
- if Old_Requires_Transient_Scope (Etype (Comp)) then
- return True;
- end if;
- end if;
-
- Next_Entity (Comp);
- end loop;
- end;
-
- return False;
-
- -- String literal types never require transient scope
-
- elsif Ekind (Typ) = E_String_Literal_Subtype then
- return False;
-
- -- Array type. Note that we already know that this is a constrained
- -- array, since unconstrained arrays will fail the indefinite test.
-
- elsif Is_Array_Type (Typ) then
-
- -- If component type requires a transient scope, the array does too
-
- if Old_Requires_Transient_Scope (Component_Type (Typ)) then
- return True;
-
- -- Otherwise, we only need a transient scope if the size depends on
- -- the value of one or more discriminants.
-
- else
- return Size_Depends_On_Discriminant (Typ);
- end if;
-
- -- All other cases do not require a transient scope
-
- else
- pragma Assert (Is_Protected_Type (Typ) or else Is_Task_Type (Typ));
- return False;
- end if;
- end Old_Requires_Transient_Scope;
-
- ----------------------------------
- -- New_Requires_Transient_Scope --
- ----------------------------------
-
- function New_Requires_Transient_Scope (Id : Entity_Id) return Boolean is
-
- function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean;
- -- This is called for untagged records and protected types, with
- -- nondefaulted discriminants. Returns True if the size of function
- -- results is known at the call site, False otherwise. Returns False
- -- if there is a variant part that depends on the discriminants of
- -- this type, or if there is an array constrained by the discriminants
- -- of this type. ???Currently, this is overly conservative (the array
- -- could be nested inside some other record that is constrained by
- -- nondiscriminants). That is, the recursive calls are too conservative.
-
- function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean;
- -- Returns True if Typ is a nonlimited record with defaulted
- -- discriminants whose max size makes it unsuitable for allocating on
- -- the primary stack.
-
- ------------------------------
- -- Caller_Known_Size_Record --
- ------------------------------
-
- function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean is
- pragma Assert (Typ = Underlying_Type (Typ));
-
- begin
- if Has_Variant_Part (Typ) and then not Is_Definite_Subtype (Typ) then
- return False;
- end if;
-
- declare
- Comp : Entity_Id;
-
- begin
- Comp := First_Entity (Typ);
- while Present (Comp) loop
-
- -- Only look at E_Component entities. No need to look at
- -- E_Discriminant entities, and we must ignore internal
- -- subtypes generated for constrained components.
-
- if Ekind (Comp) = E_Component then
- declare
- Comp_Type : constant Entity_Id :=
- Underlying_Type (Etype (Comp));
-
- begin
- if Is_Record_Type (Comp_Type)
- or else
- Is_Protected_Type (Comp_Type)
- then
- if not Caller_Known_Size_Record (Comp_Type) then
- return False;
- end if;
-
- elsif Is_Array_Type (Comp_Type) then
- if Size_Depends_On_Discriminant (Comp_Type) then
- return False;
- end if;
- end if;
- end;
- end if;
-
- Next_Entity (Comp);
- end loop;
- end;
-
- return True;
- end Caller_Known_Size_Record;
-
- ------------------------------
- -- Large_Max_Size_Mutable --
- ------------------------------
-
- function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean is
- pragma Assert (Typ = Underlying_Type (Typ));
-
- function Is_Large_Discrete_Type (T : Entity_Id) return Boolean;
- -- Returns true if the discrete type T has a large range
-
- ----------------------------
- -- Is_Large_Discrete_Type --
- ----------------------------
-
- function Is_Large_Discrete_Type (T : Entity_Id) return Boolean is
- Threshold : constant Int := 16;
- -- Arbitrary threshold above which we consider it "large". We want
- -- a fairly large threshold, because these large types really
- -- shouldn't have default discriminants in the first place, in
- -- most cases.
-
- begin
- return UI_To_Int (RM_Size (T)) > Threshold;
- end Is_Large_Discrete_Type;
-
- begin
- if Is_Record_Type (Typ)
- and then not Is_Limited_View (Typ)
- and then Has_Defaulted_Discriminants (Typ)
- then
- -- Loop through the components, looking for an array whose upper
- -- bound(s) depends on discriminants, where both the subtype of
- -- the discriminant and the index subtype are too large.
-
- declare
- Comp : Entity_Id;
-
- begin
- Comp := First_Entity (Typ);
- while Present (Comp) loop
- if Ekind (Comp) = E_Component then
- declare
- Comp_Type : constant Entity_Id :=
- Underlying_Type (Etype (Comp));
- Indx : Node_Id;
- Ityp : Entity_Id;
- Hi : Node_Id;
-
- begin
- if Is_Array_Type (Comp_Type) then
- Indx := First_Index (Comp_Type);
-
- while Present (Indx) loop
- Ityp := Etype (Indx);
- Hi := Type_High_Bound (Ityp);
-
- if Nkind (Hi) = N_Identifier
- and then Ekind (Entity (Hi)) = E_Discriminant
- and then Is_Large_Discrete_Type (Ityp)
- and then Is_Large_Discrete_Type
- (Etype (Entity (Hi)))
- then
- return True;
- end if;
-
- Next_Index (Indx);
- end loop;
- end if;
- end;
- end if;
+ if False then -- False to disable; True for debugging
+ Treepr.Print_Tree_Node (Id);
- Next_Entity (Comp);
- end loop;
- end;
+ if Old_Val = New_Val then
+ raise Program_Error;
end if;
-
- return False;
- end Large_Max_Size_Mutable;
-
- -- Local declarations
-
- Typ : constant Entity_Id := Underlying_Type (Id);
-
- -- Start of processing for New_Requires_Transient_Scope
-
- begin
- -- This is a private type which is not completed yet. This can only
- -- happen in a default expression (of a formal parameter or of a
- -- record component). Do not expand transient scope in this case.
-
- if No (Typ) then
- return False;
-
- -- Do not expand transient scope for non-existent procedure return or
- -- string literal types.
-
- elsif Typ = Standard_Void_Type
- or else Ekind (Typ) = E_String_Literal_Subtype
- then
- return False;
-
- -- If Typ is a generic formal incomplete type, then we want to look at
- -- the actual type.
-
- elsif Ekind (Typ) = E_Record_Subtype
- and then Present (Cloned_Subtype (Typ))
- then
- return New_Requires_Transient_Scope (Cloned_Subtype (Typ));
-
- -- Functions returning specific tagged types may dispatch on result, so
- -- their returned value is allocated on the secondary stack, even in the
- -- definite case. We must treat nondispatching functions the same way,
- -- because access-to-function types can point at both, so the calling
- -- conventions must be compatible. Is_Tagged_Type includes controlled
- -- types and class-wide types. Controlled type temporaries need
- -- finalization.
-
- -- ???It's not clear why we need to return noncontrolled types with
- -- controlled components on the secondary stack.
-
- elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then
- return True;
-
- -- Untagged definite subtypes are known size. This includes all
- -- elementary [sub]types. Tasks are known size even if they have
- -- discriminants. So we return False here, with one exception:
- -- For a type like:
- -- type T (Last : Natural := 0) is
- -- X : String (1 .. Last);
- -- end record;
- -- we return True. That's because for "P(F(...));", where F returns T,
- -- we don't know the size of the result at the call site, so if we
- -- allocated it on the primary stack, we would have to allocate the
- -- maximum size, which is way too big.
-
- elsif Is_Definite_Subtype (Typ) or else Is_Task_Type (Typ) then
- return Large_Max_Size_Mutable (Typ);
-
- -- Indefinite (discriminated) untagged record or protected type
-
- elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then
- return not Caller_Known_Size_Record (Typ);
-
- -- Unconstrained array
-
- else
- pragma Assert (Is_Array_Type (Typ) and not Is_Definite_Subtype (Typ));
- return True;
end if;
- end New_Requires_Transient_Scope;
+ end Results_Differ;
--------------------------
-- Reset_Analyzed_Flags --
--------------------------
procedure Reset_Analyzed_Flags (N : Node_Id) is
-
function Clear_Analyzed (N : Node_Id) return Traverse_Result;
-- Function used to reset Analyzed flags in tree. Note that we do
-- not reset Analyzed flags in entities, since there is no need to
@@ -18272,7 +19319,7 @@ package body Sem_Util is
function Clear_Analyzed (N : Node_Id) return Traverse_Result is
begin
- if not Has_Extension (N) then
+ if Nkind (N) not in N_Entity then
Set_Analyzed (N, False);
end if;
@@ -18628,7 +19675,7 @@ package body Sem_Util is
null;
elsif Present (SPARK_Pragma (Context)) then
- SPARK_Mode := Get_SPARK_Mode_From_Pragma (SPARK_Pragma (Context));
+ SPARK_Mode := Get_SPARK_Mode_From_Annotation (SPARK_Pragma (Context));
end if;
end Save_SPARK_Mode_And_Set;
@@ -19434,13 +20481,14 @@ package body Sem_Util is
return False;
end if;
- -- Check that the size of the component is 8, 16, 32 or 64 bits and that
- -- Typ is properly aligned.
+ -- Check that the size of the component is 8, 16, 32, or 64 bits and
+ -- that Typ is properly aligned.
case Size is
when 8 | 16 | 32 | 64 =>
return Size = UI_To_Int (Alignment (Typ)) * 8;
- when others =>
+
+ when others =>
return False;
end case;
end Support_Atomic_Primitives;
@@ -19751,13 +20799,27 @@ package body Sem_Util is
if Nkind (Parent (E)) = N_Entry_Body then
declare
Prot_Item : Entity_Id;
+ Prot_Type : Entity_Id;
+
begin
+ if Ekind (E) = E_Entry then
+ Prot_Type := Scope (E);
+
+ -- Bodies of entry families are nested within an extra scope
+ -- that contains an entry index declaration
+
+ else
+ Prot_Type := Scope (Scope (E));
+ end if;
+
+ pragma Assert (Ekind (Prot_Type) = E_Protected_Type);
+
-- Traverse the entity list of the protected type and locate
-- an entry declaration which matches the entry body.
- Prot_Item := First_Entity (Scope (E));
+ Prot_Item := First_Entity (Prot_Type);
while Present (Prot_Item) loop
- if Ekind (Prot_Item) = E_Entry
+ if Ekind (Prot_Item) in Entry_Kind
and then Corresponding_Body (Parent (Prot_Item)) = E
then
U := Prot_Item;
@@ -19804,6 +20866,10 @@ package body Sem_Util is
and then Present (Corresponding_Spec_Of_Stub (P))
then
U := Corresponding_Spec_Of_Stub (P);
+
+ if Is_Single_Protected_Object (U) then
+ U := Etype (U);
+ end if;
end if;
when E_Subprogram_Body =>
@@ -19824,6 +20890,9 @@ package body Sem_Util is
and then Present (Corresponding_Spec_Of_Stub (P))
then
U := Corresponding_Spec_Of_Stub (P);
+
+ elsif Nkind (P) = N_Subprogram_Renaming_Declaration then
+ U := Corresponding_Spec (P);
end if;
when E_Task_Body =>
@@ -19838,6 +20907,10 @@ package body Sem_Util is
and then Present (Corresponding_Spec_Of_Stub (P))
then
U := Corresponding_Spec_Of_Stub (P);
+
+ if Is_Single_Task_Object (U) then
+ U := Etype (U);
+ end if;
end if;
when Type_Kind =>
@@ -19858,48 +20931,78 @@ package body Sem_Util is
function Unique_Name (E : Entity_Id) return String is
- -- Names of E_Subprogram_Body or E_Package_Body entities are not
+ -- Names in E_Subprogram_Body or E_Package_Body entities are not
-- reliable, as they may not include the overloading suffix. Instead,
-- when looking for the name of E or one of its enclosing scope, we get
-- the name of the corresponding Unique_Entity.
- function Get_Scoped_Name (E : Entity_Id) return String;
- -- Return the name of E prefixed by all the names of the scopes to which
- -- E belongs, except for Standard.
+ U : constant Entity_Id := Unique_Entity (E);
- ---------------------
- -- Get_Scoped_Name --
- ---------------------
+ function This_Name return String;
- function Get_Scoped_Name (E : Entity_Id) return String is
- Name : constant String := Get_Name_String (Chars (E));
+ ---------------
+ -- This_Name --
+ ---------------
+
+ function This_Name return String is
begin
- if Has_Fully_Qualified_Name (E)
- or else Scope (E) = Standard_Standard
- then
- return Name;
- else
- return Get_Scoped_Name (Unique_Entity (Scope (E))) & "__" & Name;
- end if;
- end Get_Scoped_Name;
+ return Get_Name_String (Chars (U));
+ end This_Name;
-- Start of processing for Unique_Name
begin
- if E = Standard_Standard then
- return Get_Name_String (Name_Standard);
-
- elsif Scope (E) = Standard_Standard
- and then not (Ekind (E) = E_Package or else Is_Subprogram (E))
+ if E = Standard_Standard
+ or else Has_Fully_Qualified_Name (E)
then
- return Get_Name_String (Name_Standard) & "__" &
- Get_Name_String (Chars (E));
+ return This_Name;
elsif Ekind (E) = E_Enumeration_Literal then
- return Unique_Name (Etype (E)) & "__" & Get_Name_String (Chars (E));
+ return Unique_Name (Etype (E)) & "__" & This_Name;
else
- return Get_Scoped_Name (Unique_Entity (E));
+ declare
+ S : constant Entity_Id := Scope (U);
+ pragma Assert (Present (S));
+
+ begin
+ -- Prefix names of predefined types with standard__, but leave
+ -- names of user-defined packages and subprograms without prefix
+ -- (even if technically they are nested in the Standard package).
+
+ if S = Standard_Standard then
+ if Ekind (U) = E_Package or else Is_Subprogram (U) then
+ return This_Name;
+ else
+ return Unique_Name (S) & "__" & This_Name;
+ end if;
+
+ -- For intances of generic subprograms use the name of the related
+ -- instace and skip the scope of its wrapper package.
+
+ elsif Is_Wrapper_Package (S) then
+ pragma Assert (Scope (S) = Scope (Related_Instance (S)));
+ -- Wrapper package and the instantiation are in the same scope
+
+ declare
+ Enclosing_Name : constant String :=
+ Unique_Name (Scope (S)) & "__" &
+ Get_Name_String (Chars (Related_Instance (S)));
+
+ begin
+ if Is_Subprogram (U)
+ and then not Is_Generic_Actual_Subprogram (U)
+ then
+ return Enclosing_Name;
+ else
+ return Enclosing_Name & "__" & This_Name;
+ end if;
+ end;
+
+ else
+ return Unique_Name (S) & "__" & This_Name;
+ end if;
+ end;
end if;
end Unique_Name;
@@ -20128,18 +21231,8 @@ package body Sem_Util is
------------------
function Within_Scope (E : Entity_Id; S : Entity_Id) return Boolean is
- SE : Entity_Id;
begin
- SE := Scope (E);
- loop
- if SE = S then
- return True;
- elsif SE = Standard_Standard then
- return False;
- else
- SE := Scope (SE);
- end if;
- end loop;
+ return Scope_Within_Or_Same (Scope (E), S);
end Within_Scope;
----------------
@@ -20605,4 +21698,28 @@ package body Sem_Util is
end if;
end Yields_Synchronized_Object;
+ ---------------------------
+ -- Yields_Universal_Type --
+ ---------------------------
+
+ function Yields_Universal_Type (N : Node_Id) return Boolean is
+ begin
+ -- Integer and real literals are of a universal type
+
+ if Nkind_In (N, N_Integer_Literal, N_Real_Literal) then
+ return True;
+
+ -- The values of certain attributes are of a universal type
+
+ elsif Nkind (N) = N_Attribute_Reference then
+ return
+ Universal_Type_Attribute (Get_Attribute_Id (Attribute_Name (N)));
+
+ -- ??? There are possibly other cases to consider
+
+ else
+ return False;
+ end if;
+ end Yields_Universal_Type;
+
end Sem_Util;
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index b37402ac0e..f9ab813548 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -62,9 +62,12 @@ package Sem_Util is
function Address_Integer_Convert_OK (T1, T2 : Entity_Id) return Boolean;
-- Given two types, returns True if we are in Allow_Integer_Address mode
- -- and one of the types is (a descendent of) System.Address (and this type
+ -- and one of the types is (a descendant of) System.Address (and this type
-- is private), and the other type is any integer type.
+ function Address_Value (N : Node_Id) return Node_Id;
+ -- Return the underlying value of the expression N of an address clause
+
function Addressable (V : Uint) return Boolean;
function Addressable (V : Int) return Boolean;
pragma Inline (Addressable);
@@ -135,7 +138,9 @@ package Sem_Util is
-- is present, this is used instead. Warn is normally False. If it is
-- True then the message is treated as a warning even though it does
-- not end with a ? (this is used when the caller wants to parameterize
- -- whether an error or warning is given).
+ -- whether an error or warning is given), or when the message should be
+ -- treated as a warning even when SPARK_Mode is On (which otherwise would
+ -- force an error).
function Async_Readers_Enabled (Id : Entity_Id) return Boolean;
-- Given the entity of an abstract state or a variable, determine whether
@@ -149,10 +154,10 @@ package Sem_Util is
function Available_Full_View_Of_Component (T : Entity_Id) return Boolean;
-- If at the point of declaration an array type has a private or limited
- -- component, several array operations are not avaiable on the type, and
+ -- component, several array operations are not available on the type, and
-- the array type is flagged accordingly. If in the immediate scope of
-- the array type the component becomes non-private or non-limited, these
- -- operations become avaiable. This can happen if the scopes of both types
+ -- operations become available. This can happen if the scopes of both types
-- are open, and the scope of the array is not outside the scope of the
-- component.
@@ -204,24 +209,6 @@ package Sem_Util is
-- Determine whether a selected component has a type that depends on
-- discriminants, and build actual subtype for it if so.
- function Build_Default_Init_Cond_Call
- (Loc : Source_Ptr;
- Obj_Id : Entity_Id;
- Typ : Entity_Id) return Node_Id;
- -- Build a call to the default initial condition procedure of type Typ with
- -- Obj_Id as the actual parameter.
-
- procedure Build_Default_Init_Cond_Procedure_Bodies (Priv_Decls : List_Id);
- -- Inspect the contents of private declarations Priv_Decls and build the
- -- bodies the default initial condition procedures for all types subject
- -- to pragma Default_Initial_Condition.
-
- procedure Build_Default_Init_Cond_Procedure_Declaration (Typ : Entity_Id);
- -- If private type Typ is subject to pragma Default_Initial_Condition,
- -- build the declaration of the procedure which verifies the assumption
- -- of the pragma at runtime. The declaration is inserted after the related
- -- pragma.
-
function Build_Default_Subtype
(T : Entity_Id;
N : Node_Id) return Entity_Id;
@@ -255,10 +242,6 @@ package Sem_Util is
-- not necessarily mean that CE could be raised, but a response of True
-- means that for sure CE cannot be raised.
- procedure Check_Part_Of_Reference (Var_Id : Entity_Id; Ref : Node_Id);
- -- Verify the legality of reference Ref to variable Var_Id when the
- -- variable is a constituent of a single protected/task type.
-
procedure Check_Dynamically_Tagged_Expression
(Expr : Node_Id;
Typ : Entity_Id;
@@ -320,6 +303,10 @@ package Sem_Util is
-- Verify that the profile of nonvolatile function Func_Id does not contain
-- effectively volatile parameters or return type.
+ procedure Check_Part_Of_Reference (Var_Id : Entity_Id; Ref : Node_Id);
+ -- Verify the legality of reference Ref to variable Var_Id when the
+ -- variable is a constituent of a single protected/task type.
+
procedure Check_Potentially_Blocking_Operation (N : Node_Id);
-- N is one of the statement forms that is a potentially blocking
-- operation. If it appears within a protected action, emit warning.
@@ -329,6 +316,15 @@ package Sem_Util is
-- 'Result and it contains an expression that evaluates differently in pre-
-- and post-state.
+ procedure Check_State_Refinements
+ (Context : Node_Id;
+ Is_Main_Unit : Boolean := False);
+ -- Verify that all abstract states declared in a block statement, entry
+ -- body, package body, protected body, subprogram body, task body, or a
+ -- package declaration denoted by Context have proper refinement. Emit an
+ -- error if this is not the case. Flag Is_Main_Unit should be set when
+ -- Context denotes the main compilation unit.
+
procedure Check_Unused_Body_States (Body_Id : Entity_Id);
-- Verify that all abstract states and objects declared in the state space
-- of package body Body_Id are used as constituents. Emit an error if this
@@ -341,6 +337,12 @@ package Sem_Util is
-- and the context is external to the protected operation, to warn against
-- a possible unlocked access to data.
+ function Choice_List (N : Node_Id) return List_Id;
+ -- Utility to retrieve the choices of a Component_Association or the
+ -- Discrete_Choices of an Iterated_Component_Association. For various
+ -- reasons these nodes have a different structure even though they play
+ -- similar roles in array aggregates.
+
function Collect_Body_States (Body_Id : Entity_Id) return Elist_Id;
-- Gather the entities of all abstract states and objects declared in the
-- body state space of package body Body_Id.
@@ -422,6 +424,12 @@ package Sem_Util is
-- of inlining, and for private protected ops. Also used to create bodies
-- for stubbed subprograms.
+ procedure Copy_SPARK_Mode_Aspect (From : Node_Id; To : Node_Id);
+ -- Copy the SPARK_Mode aspect if present in the aspect specifications
+ -- of node From to node To. On entry it is assumed that To does not have
+ -- aspect specifications. If From has no aspects, the routine has no
+ -- effect.
+
function Copy_Subprogram_Spec (Spec : Node_Id) return Node_Id;
-- Replicate a function or a procedure specification denoted by Spec. The
-- resulting tree is an exact duplicate of the original tree. New entities
@@ -447,6 +455,9 @@ package Sem_Util is
function Current_Scope return Entity_Id;
-- Get entity representing current scope
+ function Current_Scope_No_Loops return Entity_Id;
+ -- Return the current scope ignoring internally generated loops
+
function Current_Subprogram return Entity_Id;
-- Returns current enclosing subprogram. If Current_Scope is a subprogram,
-- then that is what is returned, otherwise the Enclosing_Subprogram of the
@@ -557,13 +568,11 @@ package Sem_Util is
-- Returns the declaration node enclosing N (including possibly N itself),
-- if any, or Empty otherwise.
- function Enclosing_Generic_Body
- (N : Node_Id) return Node_Id;
+ function Enclosing_Generic_Body (N : Node_Id) return Node_Id;
-- Returns the Node_Id associated with the innermost enclosing generic
-- body, if any. If none, then returns Empty.
- function Enclosing_Generic_Unit
- (N : Node_Id) return Node_Id;
+ function Enclosing_Generic_Unit (N : Node_Id) return Node_Id;
-- Returns the Node_Id associated with the innermost enclosing generic
-- unit, if any. If none, then returns Empty.
@@ -612,6 +621,10 @@ package Sem_Util is
-- continuation lines to the message explaining why type T is limited.
-- Messages are placed at node N.
+ function Expression_Of_Expression_Function
+ (Subp : Entity_Id) return Node_Id;
+ -- Return the expression of expression function Subp
+
type Extensions_Visible_Mode is
(Extensions_Visible_None,
-- Extensions_Visible does not yield a mode when SPARK_Mode is off. This
@@ -888,11 +901,19 @@ package Sem_Util is
-- ancestor declared in a parent unit, even if there is an intermediate
-- derivation that does not see the full view of that ancestor.
- procedure Get_Index_Bounds (N : Node_Id; L, H : out Node_Id);
+ procedure Get_Index_Bounds
+ (N : Node_Id;
+ L : out Node_Id;
+ H : out Node_Id;
+ Use_Full_View : Boolean := False);
-- This procedure assigns to L and H respectively the values of the low and
-- high bounds of node N, which must be a range, subtype indication, or the
-- name of a scalar subtype. The result in L, H may be set to Error if
-- there was an earlier error in the range.
+ -- Use_Full_View is intended for use by clients other than the compiler
+ -- (specifically, gnat2scil) to indicate that we want the full view if
+ -- the index type turns out to be a partial view; this case should not
+ -- arise during normal compilation of semantically correct programs.
function Get_Enum_Lit_From_Pos
(T : Entity_Id;
@@ -900,9 +921,12 @@ package Sem_Util is
Loc : Source_Ptr) return Node_Id;
-- This function returns an identifier denoting the E_Enumeration_Literal
-- entity for the specified value from the enumeration type or subtype T.
- -- The second argument is the Pos value, which is assumed to be in range.
- -- The third argument supplies a source location for constructed nodes
- -- returned by this function.
+ -- The second argument is the Pos value. Constraint_Error is raised if
+ -- argument Pos is not in range. The third argument supplies a source
+ -- location for constructed nodes returned by this function. If No_Location
+ -- is supplied as source location, the location of the returned node is
+ -- copied from the original source location for the enumeration literal,
+ -- when available.
function Get_Iterable_Type_Primitive
(Typ : Entity_Id;
@@ -914,6 +938,10 @@ package Sem_Util is
-- Retrieve the fully expanded name of the library unit declared by
-- Decl_Node into the name buffer.
+ function Get_Max_Queue_Length (Id : Entity_Id) return Uint;
+ -- Return the argument of pragma Max_Queue_Length or zero if the annotation
+ -- is not present. It is assumed that Id denotes an entry.
+
function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id;
pragma Inline (Get_Name_Entity_Id);
-- An entity value is associated with each name in the name table. The
@@ -934,7 +962,21 @@ package Sem_Util is
function Get_Pragma_Id (N : Node_Id) return Pragma_Id;
pragma Inline (Get_Pragma_Id);
- -- Obtains the Pragma_Id from the Chars field of Pragma_Identifier (N)
+ -- Obtains the Pragma_Id from Pragma_Name_Unmapped (N)
+
+ function Get_Qualified_Name
+ (Id : Entity_Id;
+ Suffix : Entity_Id := Empty) return Name_Id;
+ -- Obtain the fully qualified form of entity Id. The format is:
+ -- scope_of_id-1__scope_of_id__chars_of_id__chars_of_suffix
+
+ function Get_Qualified_Name
+ (Nam : Name_Id;
+ Suffix : Name_Id := No_Name;
+ Scop : Entity_Id := Current_Scope) return Name_Id;
+ -- Obtain the fully qualified form of name Nam assuming it appears in scope
+ -- Scop. The format is:
+ -- scop-1__scop__nam__suffix
procedure Get_Reason_String (N : Node_Id);
-- Recursive routine to analyze reason argument for pragma Warnings. The
@@ -977,6 +1019,20 @@ package Sem_Util is
-- For a type entity, return the entity of the primitive equality function
-- for the type if it exists, otherwise return Empty.
+ procedure Get_Views
+ (Typ : Entity_Id;
+ Priv_Typ : out Entity_Id;
+ Full_Typ : out Entity_Id;
+ Full_Base : out Entity_Id;
+ CRec_Typ : out Entity_Id);
+ -- Obtain the partial and full view of type Typ and in addition any extra
+ -- types the full view may have. The return entities are as follows:
+ --
+ -- Priv_Typ - the partial view (a private type)
+ -- Full_Typ - the full view
+ -- Full_Base - the base type of the full view
+ -- CRec_Typ - the corresponding record type of the full view
+
function Has_Access_Values (T : Entity_Id) return Boolean;
-- Returns true if type or subtype T is an access type, or has a component
-- (at any recursive level) that is an access type. This is a conservative
@@ -1059,6 +1115,10 @@ package Sem_Util is
-- Use_Full_View controls if the check is done using its full view (if
-- available).
+ function Has_Max_Queue_Length (Id : Entity_Id) return Boolean;
+ -- Determine whether Id is subject to pragma Max_Queue_Length. It is
+ -- assumed that Id denotes an entry.
+
function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean;
-- This is a simple minded function for determining whether an expression
-- has no obvious side effects. It is used only for determining whether
@@ -1075,6 +1135,11 @@ package Sem_Util is
-- as expressed in pragma Refined_State. This function does not take into
-- account the visible refinement region of abstract state Id.
+ function Has_Null_Body (Proc_Id : Entity_Id) return Boolean;
+ -- Determine whether the body of procedure Proc_Id contains a sole
+ -- null statement, possibly followed by an optional return. Used to
+ -- optimize useless calls to assertion checks.
+
function Has_Null_Exclusion (N : Node_Id) return Boolean;
-- Determine whether node N has a null exclusion
@@ -1147,8 +1212,11 @@ package Sem_Util is
-- Returns true if the Typ_Ent implements interface Iface_Ent
function In_Assertion_Expression_Pragma (N : Node_Id) return Boolean;
- -- Determine whether an arbitrary node appears in a pragma that acts as an
- -- assertion expression. See Sem_Prag for the list of qualifying pragmas.
+ -- Returns True if node N appears within a pragma that acts as an assertion
+ -- expression. See Sem_Prag for the list of qualifying pragmas.
+
+ function In_Generic_Scope (E : Entity_Id) return Boolean;
+ -- Returns True if entity E is inside a generic scope
function In_Instance return Boolean;
-- Returns True if the current scope is within a generic instance
@@ -1174,6 +1242,10 @@ package Sem_Util is
function In_Pragma_Expression (N : Node_Id; Nam : Name_Id) return Boolean;
-- Returns true if the expression N occurs within a pragma with name Nam
+ function In_Pre_Post_Condition (N : Node_Id) return Boolean;
+ -- Returns True if node N appears within a pre/postcondition pragma. Note
+ -- the pragma Check equivalents are NOT considered.
+
function In_Reverse_Storage_Order_Object (N : Node_Id) return Boolean;
-- Returns True if N denotes a component or subcomponent in a record or
-- array that has Reverse_Storage_Order.
@@ -1195,9 +1267,11 @@ package Sem_Util is
-- partial view of the same entity. Note that Id may not have a partial
-- view in which case the function returns Empty.
- procedure Inherit_Default_Init_Cond_Procedure (Typ : Entity_Id);
- -- Inherit the default initial condition procedure from the parent type of
- -- derived type Typ.
+ function Indexed_Component_Bit_Offset (N : Node_Id) return Uint;
+ -- Given an N_Indexed_Component node, return the first bit position of the
+ -- component if it is known at compile time. A value of No_Uint means that
+ -- either the value is not yet known before back-end processing or it is
+ -- not known at compile time after back-end processing.
procedure Inherit_Rep_Item_Chain (Typ : Entity_Id; From_Typ : Entity_Id);
-- Inherit the rep item chain of type From_Typ without clobbering any
@@ -1311,6 +1385,9 @@ package Sem_Util is
function Is_Declaration (N : Node_Id) return Boolean;
-- Determine whether arbitrary node N denotes a declaration
+ function Is_Declaration_Other_Than_Renaming (N : Node_Id) return Boolean;
+ -- Determine whether arbitrary node N denotes a non-renaming declaration
+
function Is_Declared_Within_Variant (Comp : Entity_Id) return Boolean;
-- Returns True iff component Comp is declared within a variant part
@@ -1327,16 +1404,16 @@ package Sem_Util is
-- access value (selected/indexed component, explicit dereference or a
-- slice), and false otherwise.
- function Is_Descendent_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean;
- -- Returns True if type T1 is a descendent of type T2, and false otherwise.
- -- This is the RM definition, a type is a descendent of another type if it
- -- is the same type or is derived from a descendent of the other type.
+ function Is_Descendant_Of (T1 : Entity_Id; T2 : Entity_Id) return Boolean;
+ -- Returns True if type T1 is a descendant of type T2, and false otherwise.
+ -- This is the RM definition, a type is a descendant of another type if it
+ -- is the same type or is derived from a descendant of the other type.
function Is_Descendant_Of_Suspension_Object
(Typ : Entity_Id) return Boolean;
-- Determine whether type Typ is a descendant of type Suspension_Object
-- defined in Ada.Synchronous_Task_Control. This version is different from
- -- Is_Descendent_Of as the detection of Suspension_Object does not involve
+ -- Is_Descendant_Of as the detection of Suspension_Object does not involve
-- an entity and by extension a call to RTSfind.
function Is_Double_Precision_Floating_Point_Type
@@ -1367,6 +1444,11 @@ package Sem_Util is
function Is_Entry_Declaration (Id : Entity_Id) return Boolean;
-- Determine whether entity Id is the spec entity of an entry [family]
+ function Is_Expanded_Priority_Attribute (E : Entity_Id) return Boolean;
+ -- Check whether a function in a call is an expanded priority attribute,
+ -- which is transformed into an Rtsfind call to Get_Ceiling. This expansion
+ -- does not take place in a configurable runtime.
+
function Is_Expression_Function (Subp : Entity_Id) return Boolean;
-- Determine whether subprogram [body] Subp denotes an expression function
@@ -1418,6 +1500,20 @@ package Sem_Util is
-- E is a subprogram. Return True is E is an implicit operation inherited
-- by the derived type declaration for type Typ.
+ function Is_Inlinable_Expression_Function (Subp : Entity_Id) return Boolean;
+ -- Return True if Subp is an expression function that fulfills all the
+ -- following requirements for inlining:
+ -- 1. pragma/aspect Inline_Always
+ -- 2. No formals
+ -- 3. No contracts
+ -- 4. No dispatching primitive
+ -- 5. Result subtype controlled (or with controlled components)
+ -- 6. Result subtype not subject to type-invariant checks
+ -- 7. Result subtype not a class-wide type
+ -- 8. Return expression naming an object global to the function
+ -- 9. Nominal subtype of the returned object statically compatible
+ -- with the result subtype of the expression function.
+
function Is_Iterator (Typ : Entity_Id) return Boolean;
-- AI05-0139-2: Check whether Typ is one of the predefined interfaces in
-- Ada.Iterator_Interfaces, or it is derived from one.
@@ -1452,12 +1548,21 @@ package Sem_Util is
-- parameter of the current enclosing subprogram.
-- Why are OUT parameters not considered here ???
- function Is_Nontrivial_Default_Init_Cond_Procedure
- (Id : Entity_Id) return Boolean;
+ function Is_Name_Reference (N : Node_Id) return Boolean;
+ -- Determine whether arbitrary node N is a reference to a name. This is
+ -- similar to Is_Object_Reference but returns True only if N can be renamed
+ -- without the need for a temporary, the typical example of an object not
+ -- in this category being a function call.
+
+ function Is_Nontrivial_DIC_Procedure (Id : Entity_Id) return Boolean;
-- Determine whether entity Id denotes the procedure that verifies the
-- assertion expression of pragma Default_Initial_Condition and if it does,
-- the encapsulated expression is nontrivial.
+ function Is_Null_Record_Type (T : Entity_Id) return Boolean;
+ -- Determine whether T is declared with a null record definition or a
+ -- null component list.
+
function Is_Object_Reference (N : Node_Id) return Boolean;
-- Determines if the tree referenced by N represents an object. Both
-- variable and constant objects return True (compare Is_Variable).
@@ -1469,6 +1574,13 @@ package Sem_Util is
-- the Is_Variable sense) with an untagged type target are considered view
-- conversions and hence variables.
+ function Is_OK_Volatile_Context
+ (Context : Node_Id;
+ Obj_Ref : Node_Id) return Boolean;
+ -- Determine whether node Context denotes a "non-interfering context" (as
+ -- defined in SPARK RM 7.1.3(12)) where volatile reference Obj_Ref can
+ -- safely reside.
+
function Is_Package_Contract_Annotation (Item : Node_Id) return Boolean;
-- Determine whether aspect specification or pragma Item is one of the
-- following package contract annotations:
@@ -1664,6 +1776,10 @@ package Sem_Util is
-- default is True since this routine is commonly invoked as part of the
-- semantic analysis and it must not be disturbed by the rewriten nodes.
+ function Is_Verifiable_DIC_Pragma (Prag : Node_Id) return Boolean;
+ -- Determine whether pragma Default_Initial_Condition denoted by Prag has
+ -- an assertion expression which should be verified at runtime.
+
function Is_Visibly_Controlled (T : Entity_Id) return Boolean;
-- Check whether T is derived from a visibly controlled type. This is true
-- if the root type is declared in Ada.Finalization. If T is derived
@@ -1777,21 +1893,21 @@ package Sem_Util is
Map : Elist_Id := No_Elist;
New_Sloc : Source_Ptr := No_Location;
New_Scope : Entity_Id := Empty) return Node_Id;
- -- Given a node that is the root of a subtree, Copy_Tree copies the entire
- -- syntactic subtree, including recursively any descendents whose parent
- -- field references a copied node (descendents not linked to a copied node
- -- by the parent field are not copied, instead the copied tree references
- -- the same descendent as the original in this case, which is appropriate
- -- for non-syntactic fields such as Etype). The parent pointers in the
- -- copy are properly set. Copy_Tree (Empty/Error) returns Empty/Error.
- -- The one exception to the rule of not copying semantic fields is that
- -- any implicit types attached to the subtree are duplicated, so that
- -- the copy contains a distinct set of implicit type entities. Thus this
- -- function is used when it is necessary to duplicate an analyzed tree,
- -- declared in the same or some other compilation unit. This function is
- -- declared here rather than in atree because it uses semantic information
- -- in particular concerning the structure of itypes and the generation of
- -- public symbols.
+ -- Given a node that is the root of a subtree, New_Copy_Tree copies the
+ -- entire syntactic subtree, including recursively any descendants whose
+ -- parent field references a copied node (descendants not linked to a
+ -- copied node by the parent field are not copied, instead the copied tree
+ -- references the same descendant as the original in this case, which is
+ -- appropriate for non-syntactic fields such as Etype). The parent pointers
+ -- in the copy are properly set. New_Copy_Tree (Empty/Error) returns
+ -- Empty/Error. The one exception to the rule of not copying semantic
+ -- fields is that any implicit types attached to the subtree are
+ -- duplicated, so that the copy contains a distinct set of implicit type
+ -- entities. Thus this function is used when it is necessary to duplicate
+ -- an analyzed tree, declared in the same or some other compilation unit.
+ -- This function is declared here rather than in atree because it uses
+ -- semantic information in particular concerning the structure of itypes
+ -- and the generation of public symbols.
-- The Map argument, if set to a non-empty Elist, specifies a set of
-- mappings to be applied to entities in the tree. The map has the form:
@@ -1880,6 +1996,14 @@ package Sem_Util is
-- (e.g. target of assignment, or out parameter), and to False if the
-- modification is only potential (e.g. address of entity taken).
+ function Null_To_Null_Address_Convert_OK
+ (N : Node_Id;
+ Typ : Entity_Id := Empty) return Boolean;
+ -- Return True if we are compiling in relaxed RM semantics mode and:
+ -- 1) N is a N_Null node and Typ is a descendant of System.Address, or
+ -- 2) N is a comparison operator, one of the operands is null, and the
+ -- type of the other operand is a descendant of System.Address.
+
function Object_Access_Level (Obj : Node_Id) return Uint;
-- Return the accessibility level of the view of the object Obj. For
-- convenience, qualified expressions applied to object names are also
@@ -1903,6 +2027,22 @@ package Sem_Util is
-- corresponding operation of S is the original corresponding operation of
-- S2. Otherwise, it is S itself.
+ procedure Output_Entity (Id : Entity_Id);
+ -- Print entity Id to standard output. The name of the entity appears in
+ -- fully qualified form.
+ --
+ -- WARNING: this routine should be used in debugging scenarios such as
+ -- tracking down undefined symbols as it is fairly low level.
+
+ procedure Output_Name (Nam : Name_Id; Scop : Entity_Id := Current_Scope);
+ -- Print name Nam to standard output. The name appears in fully qualified
+ -- form assuming it appears in scope Scop. Note that this may not reflect
+ -- the final qualification as the entity which carries the name may be
+ -- relocated to a different scope.
+ --
+ -- WARNING: this routine should be used in debugging scenarios such as
+ -- tracking down undefined symbols as it is fairly low level.
+
function Policy_In_Effect (Policy : Name_Id) return Name_Id;
-- Given a policy, return the policy identifier associated with it. If no
-- such policy is in effect, the value returned is No_Name.
@@ -1939,6 +2079,27 @@ package Sem_Util is
-- parameter Ent gives the entity to which the End_Label refers,
-- and to which cross-references are to be generated.
+ procedure Propagate_Concurrent_Flags
+ (Typ : Entity_Id;
+ Comp_Typ : Entity_Id);
+ -- Set Has_Task, Has_Protected and Has_Timing_Event on Typ when the flags
+ -- are set on Comp_Typ. This follows the definition of these flags which
+ -- are set (recursively) on any composite type which has a component marked
+ -- by one of these flags. This procedure can only set flags for Typ, and
+ -- never clear them. Comp_Typ is the type of a component or a parent.
+
+ procedure Propagate_DIC_Attributes
+ (Typ : Entity_Id;
+ From_Typ : Entity_Id);
+ -- Inherit all Default_Initial_Condition-related attributes from type
+ -- From_Typ. Typ is the destination type.
+
+ procedure Propagate_Invariant_Attributes
+ (Typ : Entity_Id;
+ From_Typ : Entity_Id);
+ -- Inherit all invariant-related attributes form type From_Typ. Typ is the
+ -- destination type.
+
procedure Record_Possible_Part_Of_Reference
(Var_Id : Entity_Id;
Ref : Node_Id);
@@ -1951,8 +2112,8 @@ package Sem_Util is
-- Determine whether entity Id is referenced within expression Expr
function References_Generic_Formal_Type (N : Node_Id) return Boolean;
- -- Returns True if the expression Expr contains any references to a
- -- generic type. This can only happen within a generic template.
+ -- Returns True if the expression Expr contains any references to a generic
+ -- type. This can only happen within a generic template.
procedure Remove_Homonym (E : Entity_Id);
-- Removes E from the homonym chain
@@ -1966,6 +2127,11 @@ package Sem_Util is
function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id;
-- Returns the name of E without Suffix
+ procedure Replace_Null_By_Null_Address (N : Node_Id);
+ -- N is N_Null or a binary comparison operator, we are compiling in relaxed
+ -- RM semantics mode, and one of the operands is null. Replace null with
+ -- System.Null_Address.
+
function Rep_To_Pos_Flag (E : Entity_Id; Loc : Source_Ptr) return Node_Id;
-- This is used to construct the second argument in a call to Rep_To_Pos
-- which is Standard_True if range checks are enabled (E is an entity to
@@ -1986,12 +2152,6 @@ package Sem_Util is
-- This is used as a defense mechanism against ill-formed trees caused by
-- previous errors (particularly in -gnatq mode).
- function Requires_State_Refinement
- (Spec_Id : Entity_Id;
- Body_Id : Entity_Id) return Boolean;
- -- Determine whether a package denoted by its spec and body entities
- -- requires refinement of abstract states.
-
function Requires_Transient_Scope (Id : Entity_Id) return Boolean;
-- Id is a type entity. The result is True when temporaries of this type
-- need to be wrapped in a transient scope to be reclaimed properly when a
@@ -2219,12 +2379,12 @@ package Sem_Util is
-- Return the entity which represents declaration N, so that different
-- views of the same entity have the same unique defining entity:
-- * entry declaration and entry body
- -- * package spec and body
- -- * protected type declaration, protected body stub and protected body
+ -- * package spec, package body, and package body stub
+ -- * protected type declaration, protected body, and protected body stub
-- * private view and full view of a deferred constant
-- * private view and full view of a type
- -- * subprogram declaration, subprogram stub and subprogram body
- -- * task type declaration, task body stub and task body
+ -- * subprogram declaration, subprogram, and subprogram body stub
+ -- * task type declaration, task body, and task body stub
-- In other cases, return the defining entity for N.
function Unique_Entity (E : Entity_Id) return Entity_Id;
@@ -2279,4 +2439,7 @@ package Sem_Util is
-- * A synchronized interface type
-- * A task type
+ function Yields_Universal_Type (N : Node_Id) return Boolean;
+ -- Determine whether unanalyzed node N yields a universal type
+
end Sem_Util;
diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb
index 3b3bc2b0f8..29bdfd4886 100644
--- a/gcc/ada/sem_warn.adb
+++ b/gcc/ada/sem_warn.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -314,6 +314,11 @@ package body Sem_Warn is
elsif Is_Suspicious_Function_Name (Entity (Name (N))) then
return;
+ -- Forget it if function is marked Volatile_Function
+
+ elsif Is_Volatile_Function (Entity (Name (N))) then
+ return;
+
-- Forget it if warnings are suppressed on function entity
elsif Has_Warnings_Off (Entity (Name (N))) then
@@ -382,7 +387,7 @@ package body Sem_Warn is
Comp := First_Component (Rec);
while Present (Comp) loop
if Is_Access_Type (Etype (Comp))
- or else Is_Descendent_Of_Address (Etype (Comp))
+ or else Is_Descendant_Of_Address (Etype (Comp))
then
return True;
end if;
@@ -985,7 +990,7 @@ package body Sem_Warn is
-- Similarly, the generic formals of a generic subprogram are
-- not accessible.
- when N_Generic_Subprogram_Declaration =>
+ when N_Generic_Subprogram_Declaration =>
if Is_List_Member (Prev)
and then List_Containing (Prev) =
Generic_Formal_Declarations (P)
@@ -1009,12 +1014,13 @@ package body Sem_Warn is
-- If we reach any other body, definitely not referenceable
- when N_Package_Body |
- N_Task_Body |
- N_Entry_Body |
- N_Protected_Body |
- N_Block_Statement |
- N_Subunit =>
+ when N_Block_Statement
+ | N_Entry_Body
+ | N_Package_Body
+ | N_Protected_Body
+ | N_Subunit
+ | N_Task_Body
+ =>
return False;
-- For all other cases, keep looking up tree
@@ -1137,13 +1143,16 @@ package body Sem_Warn is
-- A special case, if this variable is volatile and not
-- imported, it is not helpful to tell the programmer
-- to mark the variable as constant, since this would be
- -- illegal by virtue of RM C.6(13).
+ -- illegal by virtue of RM C.6(13). Instead we suggest
+ -- using pragma Export (can't be Import because of the
+ -- initial value).
if (Is_Volatile (E1) or else Has_Volatile_Components (E1))
and then not Is_Imported (E1)
then
Error_Msg_N
- ("?k?& is not modified, volatile has no effect!", E1);
+ ("?k?& is not modified, consider pragma Export for "
+ & "volatile variable!", E1);
-- Another special case, Exception_Occurrence, this catches
-- the case of exception choice (and a bit more too, but not
@@ -1694,20 +1703,21 @@ package body Sem_Warn is
-----------------------------
function Is_OK_Fully_Initialized return Boolean is
+ Prag : Node_Id;
+
begin
if Is_Access_Type (Typ) and then Is_Dereferenced (N) then
return False;
- -- If a type has Default_Initial_Condition set, or it inherits it,
- -- DIC might be specified with a boolean value, meaning that the type
- -- is considered to be fully default initialized (SPARK RM 3.1 and
- -- SPARK RM 7.3.3). To avoid generating spurious warnings in this
- -- case, consider all types with DIC as fully initialized.
+ -- A type subject to pragma Default_Initial_Condition is fully
+ -- default initialized when the pragma appears with a non-null
+ -- argument (SPARK RM 3.1 and SPARK RM 7.3.3).
- elsif Has_Default_Init_Cond (Typ)
- or else Has_Inherited_Default_Init_Cond (Typ)
- then
- return True;
+ elsif Has_DIC (Typ) then
+ Prag := Get_Pragma (Typ, Pragma_Default_Initial_Condition);
+ pragma Assert (Present (Prag));
+
+ return Is_Verifiable_DIC_Pragma (Prag);
else
return Is_Fully_Initialized_Type (Typ);
@@ -1783,7 +1793,9 @@ package body Sem_Warn is
-- For identifier or expanded name, examine the entity involved
- when N_Identifier | N_Expanded_Name =>
+ when N_Expanded_Name
+ | N_Identifier
+ =>
declare
E : constant Entity_Id := Entity (N);
@@ -1868,7 +1880,7 @@ package body Sem_Warn is
Nod := Parent (N);
while Present (Nod) loop
if Nkind (Nod) = N_Pragma
- and then Nam_In (Pragma_Name (Nod),
+ and then Nam_In (Pragma_Name_Unmapped (Nod),
Name_Postcondition,
Name_Refined_Post,
Name_Contract_Cases)
@@ -1879,7 +1891,8 @@ package body Sem_Warn is
P := Parent (Nod);
if Nkind (P) = N_Pragma
- and then Pragma_Name (P) = Name_Test_Case
+ and then Pragma_Name (P) =
+ Name_Test_Case
and then Nod = Test_Case_Arg (P, Name_Ensures)
then
return True;
@@ -2042,8 +2055,9 @@ package body Sem_Warn is
-- Indexed component or slice
- when N_Indexed_Component | N_Slice =>
-
+ when N_Indexed_Component
+ | N_Slice
+ =>
-- If prefix does not involve dereferencing an access type, then
-- we know we are OK if the component type is fully initialized,
-- since the component will have been set as part of the default
@@ -2114,9 +2128,10 @@ package body Sem_Warn is
-- For type conversions, qualifications, or expressions with actions,
-- examine the expression.
- when N_Type_Conversion |
- N_Qualified_Expression |
- N_Expression_With_Actions =>
+ when N_Expression_With_Actions
+ | N_Qualified_Expression
+ | N_Type_Conversion
+ =>
Check_Unset_Reference (Expression (N));
-- For explicit dereference, always check prefix, which will generate
@@ -2129,7 +2144,6 @@ package body Sem_Warn is
when others =>
null;
-
end case;
end Check_Unset_Reference;
@@ -3364,7 +3378,7 @@ package body Sem_Warn is
P := Parent (C);
loop
-- If tree is not attached, do not issue warning (this is very
- -- peculiar, and probably arises from some other error condition)
+ -- peculiar, and probably arises from some other error condition).
if No (P) then
return;
@@ -3389,8 +3403,8 @@ package body Sem_Warn is
-- node, since assert pragmas get rewritten at analysis time.
elsif Nkind (Original_Node (P)) = N_Pragma
- and then Nam_In (Pragma_Name (Original_Node (P)), Name_Assert,
- Name_Check)
+ and then Nam_In (Pragma_Name_Unmapped (Original_Node (P)),
+ Name_Assert, Name_Check)
then
return;
end if;
@@ -4131,11 +4145,11 @@ package body Sem_Warn is
end if;
end if;
- when E_In_Parameter |
- E_In_Out_Parameter =>
-
- -- Do not emit message for formals of a renaming, because
- -- they are never referenced explicitly.
+ when E_In_Out_Parameter
+ | E_In_Parameter
+ =>
+ -- Do not emit message for formals of a renaming, because they
+ -- are never referenced explicitly.
if Nkind (Original_Node (Unit_Declaration_Node (Scope (E)))) /=
N_Subprogram_Renaming_Declaration
@@ -4166,8 +4180,9 @@ package body Sem_Warn is
when E_Discriminant =>
Error_Msg_N ("?u?discriminant & is not referenced!", E);
- when E_Named_Integer |
- E_Named_Real =>
+ when E_Named_Integer
+ | E_Named_Real
+ =>
Error_Msg_N -- CODEFIX
("?u?named number & is not referenced!", E);
@@ -4294,8 +4309,10 @@ package body Sem_Warn is
-- When we hit a package/subprogram body, issue warning and exit
- elsif Nkind (P) = N_Subprogram_Body
- or else Nkind (P) = N_Package_Body
+ elsif Nkind_In (P, N_Entry_Body,
+ N_Package_Body,
+ N_Subprogram_Body,
+ N_Task_Body)
then
-- Case of assigned value never referenced
@@ -4306,7 +4323,12 @@ package body Sem_Warn is
begin
-- Don't give this for OUT and IN OUT formals, since
-- clearly caller may reference the assigned value. Also
- -- never give such warnings for internal variables.
+ -- never give such warnings for internal variables. In
+ -- either case, word the warning in a conditional way,
+ -- because in the case of a component of a controlled
+ -- type, the assigned value might be referenced in the
+ -- Finalize operation, so we can't make a definitive
+ -- statement that it's never referenced.
if Ekind (Ent) = E_Variable
and then not Is_Internal_Name (Chars (Ent))
@@ -4314,17 +4336,17 @@ package body Sem_Warn is
-- Give appropriate message, distinguishing between
-- assignment statements and out parameters.
- if Nkind_In (Parent (LA), N_Procedure_Call_Statement,
- N_Parameter_Association)
+ if Nkind_In (Parent (LA), N_Parameter_Association,
+ N_Procedure_Call_Statement)
then
Error_Msg_NE
- ("?m?& modified by call, but value never "
+ ("?m?& modified by call, but value might not be "
& "referenced", LA, Ent);
else
Error_Msg_NE -- CODEFIX
- ("?m?useless assignment to&, value never "
- & "referenced!", LA, Ent);
+ ("?m?possibly useless assignment to&, value "
+ & "might not be referenced!", LA, Ent);
end if;
end if;
end;
@@ -4373,8 +4395,10 @@ package body Sem_Warn is
-- not generate the warning, since the variable in question
-- may be accessed after an exception in the outer block.
- if Nkind (Parent (P)) /= N_Subprogram_Body
- and then Nkind (Parent (P)) /= N_Package_Body
+ if not Nkind_In (Parent (P), N_Entry_Body,
+ N_Package_Body,
+ N_Subprogram_Body,
+ N_Task_Body)
then
Set_Last_Assignment (Ent, Empty);
return;
diff --git a/gcc/ada/sem_warn.ads b/gcc/ada/sem_warn.ads
index b1f2af22da..cd71e3466b 100644
--- a/gcc/ada/sem_warn.ads
+++ b/gcc/ada/sem_warn.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1999-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -238,7 +238,7 @@ package Sem_Warn is
-- should only be made if at least one of the flags Warn_On_Modified_Unread
-- or Warn_On_All_Unread_Out_Parameters is True, and if Ent is in the
-- extended main source unit. N is Empty for the end of block call
- -- (warning message says value unreferenced), or the it is the node for
+ -- (warning message says value unreferenced), or it is the node for
-- an overwriting assignment (warning message points to this assignment).
procedure Warn_On_Useless_Assignments (E : Entity_Id);
diff --git a/gcc/ada/set_targ.adb b/gcc/ada/set_targ.adb
index 4dbd735e97..f25c9f84f8 100755
--- a/gcc/ada/set_targ.adb
+++ b/gcc/ada/set_targ.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2013-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2013-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -203,10 +203,14 @@ package body Set_Targ is
begin
case T is
- when S_Short_Float | S_Float =>
+ when S_Float
+ | S_Short_Float
+ =>
return "float";
+
when S_Long_Float =>
return "double";
+
when S_Long_Long_Float =>
if Long_Double_Index >= 0
and then FPT_Mode_Table (Long_Double_Index).DIGS <= Max_HW_Digs
@@ -302,8 +306,8 @@ package body Set_Targ is
Write_Str ("pragma Float_Representation (");
case Float_Rep is
- when IEEE_Binary => Write_Str ("IEEE");
when AAMP => Write_Str ("AAMP");
+ when IEEE_Binary => Write_Str ("IEEE");
end case;
Write_Line (", " & T (1 .. Last) & ");");
@@ -525,10 +529,8 @@ package body Set_Targ is
AddC (' ');
case E.FLOAT_REP is
- when IEEE_Binary =>
- AddC ('I');
- when AAMP =>
- AddC ('A');
+ when AAMP => AddC ('A');
+ when IEEE_Binary => AddC ('I');
end case;
AddC (' ');
@@ -698,6 +700,8 @@ package body Set_Targ is
Buflen := Read (File_Desc, Buffer'Address, Buffer'Length);
+ Close (File_Desc);
+
if Buflen = Buffer'Length then
Fail ("file is too long: " & File_Name);
end if;
@@ -779,8 +783,10 @@ package body Set_Targ is
case Buffer (N) is
when 'I' =>
E.FLOAT_REP := IEEE_Binary;
+
when 'A' =>
E.FLOAT_REP := AAMP;
+
when others =>
FailN ("bad float rep field for");
end case;
@@ -946,21 +952,21 @@ begin
T : FPT_Mode_Entry renames
FPT_Mode_Table (FPT_Mode_Index_For (S_Float));
begin
- Float_Size := Int (T.SIZE);
+ Float_Size := Pos (T.SIZE);
end;
declare
T : FPT_Mode_Entry renames
FPT_Mode_Table (FPT_Mode_Index_For (S_Long_Float));
begin
- Double_Size := Int (T.SIZE);
+ Double_Size := Pos (T.SIZE);
end;
declare
T : FPT_Mode_Entry renames
FPT_Mode_Table (FPT_Mode_Index_For (S_Long_Long_Float));
begin
- Long_Double_Size := Int (T.SIZE);
+ Long_Double_Size := Pos (T.SIZE);
end;
end if;
diff --git a/gcc/ada/sigtramp-vxworks-target.inc b/gcc/ada/sigtramp-vxworks-target.inc
index a031360cd2..722dd31c7b 100644
--- a/gcc/ada/sigtramp-vxworks-target.inc
+++ b/gcc/ada/sigtramp-vxworks-target.inc
@@ -159,7 +159,7 @@
#define REGNO_R13 13
#define REGNO_R14 14
#define REGNO_R15 15
-#define REGNO_SET_PC 16 /* aka %rip */
+#define REGNO_RPC 16 /* aka %rip */
#define REGNO_EFLAGS 49
#define REGNO_FS 54
@@ -401,8 +401,6 @@ TCR("ret")
#define COMMON_CFI(REG) \
".cfi_offset " S(REGNO_##REG) "," S(REG_##REG)
-#define PC_CFI(REG) \
- ".cfi_offset " S(REGNO_##REG) "," S(REG_##REG)
#define CFI_COMMON_REGS \
CR("# CFI for common registers\n") \
@@ -422,10 +420,8 @@ TCR(COMMON_CFI(RBX)) \
TCR(COMMON_CFI(RDX)) \
TCR(COMMON_CFI(RCX)) \
TCR(COMMON_CFI(RAX)) \
-TCR(COMMON_CFI(EFLAGS)) \
-TCR(COMMON_CFI(SET_PC)) \
-TCR(COMMON_CFI(FS)) \
-TCR(".cfi_return_column " S(REGNO_SET_PC))
+TCR(COMMON_CFI(RPC)) \
+TCR(".cfi_return_column " S(REGNO_RPC))
/* Trampoline body block
--------------------- */
@@ -451,10 +447,17 @@ Not_implemented;
/* Symbol definition block
----------------------- */
+#ifdef __x86_64__
+#define FUNC_ALIGN TCR(".p2align 4,,15")
+#else
+#define FUNC_ALIGN
+#endif
+
#define SIGTRAMP_START(SYM) \
CR("# " S(SYM) " cfi trampoline") \
TCR(".type " S(SYM) ", "FUNCTION) \
CR("") \
+FUNC_ALIGN \
CR(S(SYM) ":") \
TCR(".cfi_startproc") \
TCR(".cfi_signal_frame")
@@ -474,4 +477,3 @@ TCR(".size " S(SYM) ", .-" S(SYM))
asm (".text\n"
TCR(".align 2"));
-
diff --git a/gcc/ada/sigtramp-vxworks-vxsim.c b/gcc/ada/sigtramp-vxworks-vxsim.c
deleted file mode 100644
index 918d9e5d4f..0000000000
--- a/gcc/ada/sigtramp-vxworks-vxsim.c
+++ /dev/null
@@ -1,141 +0,0 @@
-/****************************************************************************
- * *
- * GNAT COMPILER COMPONENTS *
- * *
- * S I G T R A M P *
- * *
- * Asm Implementation File *
- * *
- * Copyright (C) 2011-2015, Free Software Foundation, Inc. *
- * *
- * GNAT is free software; you can redistribute it and/or modify it under *
- * terms of the GNU General Public License as published by the Free Soft- *
- * ware Foundation; either version 3, or (at your option) any later ver- *
- * sion. GNAT is distributed in the hope that it will be useful, but WITH- *
- * OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY *
- * or FITNESS FOR A PARTICULAR PURPOSE. *
- * *
- * As a special exception under Section 7 of GPL version 3, you are granted *
- * additional permissions described in the GCC Runtime Library Exception, *
- * version 3.1, as published by the Free Software Foundation. *
- * *
- * In particular, you can freely distribute your programs built with the *
- * GNAT Pro compiler, including any required library run-time units, using *
- * any licensing terms of your choosing. See the AdaCore Software License *
- * for full details. *
- * *
- * GNAT was originally developed by the GNAT team at New York University. *
- * Extensive contributions were provided by Ada Core Technologies Inc. *
- * *
- ****************************************************************************/
-
-/********************************************************
- * VxWorks VXSIM version of the __gnat_sigtramp service *
- ********************************************************/
-
-#undef CPU
-#define CPU __VXSIM_CPU__
-
-#include "sigtramp.h"
-/* See sigtramp.h for a general explanation of functionality. */
-
-#include <vxWorks.h>
-#include <arch/../regs.h>
-#ifndef __RTP__
-#include <sigLib.h>
-#else
-#include <signal.h>
-#include <regs.h>
-
-typedef struct mcontext
- {
- REG_SET regs;
- } mcontext_t;
-
-typedef struct ucontext
- {
- mcontext_t uc_mcontext; /* register set */
- struct ucontext * uc_link; /* not used */
- sigset_t uc_sigmask; /* set of signals blocked */
- stack_t uc_stack; /* stack of context signaled */
- } ucontext_t;
-#endif
-
-/* ----------------------
- -- General comments --
- ----------------------
-
- Stubs are generated from toplevel asms and .cfi directives, much simpler
- to use and check for correctness than manual encodings of CFI byte
- sequences. The general idea is to establish CFA as sigcontext->sc_pregs
- (for DKM) and mcontext (for RTP) and state where to find the registers as
- offsets from there.
-
- As of today, we support a stub providing CFI info for common
- registers (GPRs, LR, ...). We might need variants with support for floating
- point or altivec registers as well at some point.
-
- Checking which variant should apply and getting at sc_pregs / mcontext
- is simpler to express in C (we can't use offsetof in toplevel asms and
- hardcoding constants is not workable with the flurry of VxWorks variants),
- so this is the choice for our toplevel interface.
-
- Note that the registers we "restore" here are those to which we have
- direct access through the system sigcontext structure, which includes
- only a partial set of the non-volatiles ABI-wise. */
-
-/* -------------------------------------------
- -- Prototypes for our internal asm stubs --
- -------------------------------------------
-
- Eventhough our symbols will remain local, the prototype claims "extern"
- and not "static" to prevent compiler complaints about a symbol used but
- never defined. */
-
-/* sigtramp stub providing CFI info for common registers. */
-
-extern void __gnat_sigtramp_vxsim_common
-(int signo, void *siginfo, void *sigcontext,
- __sigtramphandler_t * handler, void * sc_pregs);
-
-
-/* -------------------------------------
- -- Common interface implementation --
- -------------------------------------
-
- We enforce optimization to minimize the overhead of the extra layer. */
-
-void __gnat_sigtramp_vxsim (int signo, void *si, void *sc,
- __sigtramphandler_t * handler)
- __attribute__((optimize(2)));
-
-void __gnat_sigtramp_vxsim (int signo, void *si, void *sc,
- __sigtramphandler_t * handler)
-{
-#ifdef __RTP__
- mcontext_t *mcontext = &((ucontext_t *) sc)->uc_mcontext;
-
- /* Pass MCONTEXT in the fifth position so that the assembly code can find
- it at the same stack location or in the same register as SC_PREGS. */
- __gnat_sigtramp_vxsim_common (signo, si, mcontext, handler, mcontext);
-#else
- struct sigcontext * sctx = (struct sigcontext *) sc;
-
- __gnat_sigtramp_vxsim_common (signo, si, sctx, handler, sctx->sc_pregs);
-#endif
-}
-
-/* Include the target specific bits. */
-#include "sigtramp-vxworks-target.inc"
-
-/* sigtramp stub for common registers. */
-
-#define TRAMP_COMMON __gnat_sigtramp_vxsim_common
-
-asm (SIGTRAMP_START(TRAMP_COMMON));
-asm (CFI_DEF_CFA);
-asm (CFI_COMMON_REGS);
-asm (SIGTRAMP_BODY);
-asm (SIGTRAMP_END(TRAMP_COMMON));
-
-
diff --git a/gcc/ada/sigtramp-vxworks.c b/gcc/ada/sigtramp-vxworks.c
index 360b921145..e9dd9aa1ce 100644
--- a/gcc/ada/sigtramp-vxworks.c
+++ b/gcc/ada/sigtramp-vxworks.c
@@ -89,12 +89,13 @@ typedef struct ucontext
and not "static" to prevent compiler complaints about a symbol used but
never defined. */
-/* sigtramp stub providing CFI info for common registers. */
+#define TRAMP_COMMON __gnat_sigtramp_common
-extern void __gnat_sigtramp_common
-(int signo, void *siginfo, void *sigcontext,
- __sigtramphandler_t * handler, void * sc_pregs);
+/* sigtramp stub providing CFI info for common registers. */
+extern void
+TRAMP_COMMON (int signo, void *siginfo, void *sigcontext,
+ __sigtramphandler_t * handler, REG_SET * sc_pregs);
/* -------------------------------------
-- Common interface implementation --
@@ -102,6 +103,14 @@ extern void __gnat_sigtramp_common
We enforce optimization to minimize the overhead of the extra layer. */
+#if defined(__vxworks) && (defined (__i386__) || defined (__x86_64__)) && !defined (VTHREADS)
+static int __gnat_is_vxsim = 0;
+
+void __gnat_set_is_vxsim(int val) {
+ __gnat_is_vxsim = val;
+}
+#endif
+
void __gnat_sigtramp (int signo, void *si, void *sc,
__sigtramphandler_t * handler)
__attribute__((optimize(2)));
@@ -109,17 +118,58 @@ void __gnat_sigtramp (int signo, void *si, void *sc,
void __gnat_sigtramp (int signo, void *si, void *sc,
__sigtramphandler_t * handler)
{
-#ifdef __RTP__
+ REG_SET *pregs;
+
+ /* VXSIM uses a different signal context structure than the regular x86
+ targets:
+ * on x86-vx6: two 32-bit values are added at the end of the REG_SET, plus
+ an explicit padding of 0xc8 characters (200 characters). The sigcontext
+ containing a complete REG_SET just before the field 'sc_pregs', this
+ adds a 208 bytes offset to get the value of 'sc_pregs'.
+ * on x86-vx7: the same offset is used on vx7: 3 32-bit values are present
+ at the enf of the reg set, but the padding is then of 0xc4 characters.
+ * on x86_64-vx7: two 64-bit values are added at the beginning of the
+ REG_SET. This adds a 16 bytes offset to get the value of 'sc_pregs',
+ and another 16 bytes offset within the pregs structure to retrieve the
+ registers list.
+ */
+
+ /* Retrieve the registers to restore : */
+#ifndef __RTP__
+#ifdef __HANDLE_VXSIM_SC
+#if defined(__i386__)
+ /* move sctx 208 bytes further, so that the vxsim's sc_pregs field coincide
+ with the expected x86 one */
+ struct sigcontext * sctx =
+ (struct sigcontext *) (sc + (__gnat_is_vxsim ? 208 : 0));
+#elif defined(__x86_64__)
+ /* move sctx 16 bytes further, so that the vxsim's sc_pregs field coincide
+ with the expected x86_64 one */
+ struct sigcontext * sctx =
+ (struct sigcontext *) (sc + (__gnat_is_vxsim ? 16 : 0));
+#endif /* __i386__ || __x86_64__ */
+#else /* __HANDLE_VXSIM_SC__ */
+ struct sigcontext * sctx = (struct sigcontext *) sc;
+#endif
+
+ pregs = sctx->sc_pregs;
+
+#else /* !defined(__RTP__) */
+
mcontext_t *mcontext = &((ucontext_t *) sc)->uc_mcontext;
+ /* No specific offset in this case for vxsim */
+ pregs = &(mcontext->regs);
- /* Pass MCONTEXT in the fifth position so that the assembly code can find
- it at the same stack location or in the same register as SC_PREGS. */
- __gnat_sigtramp_common (signo, si, mcontext, handler, mcontext);
-#else
- struct sigcontext * sctx = (struct sigcontext *) sc;
+#endif /* !defined(__RTP__) */
- __gnat_sigtramp_common (signo, si, sctx, handler, sctx->sc_pregs);
+#if defined (__HANDLE_VXSIM_SC) && defined (__x86_64__)
+ /* Ignore the first two values, that are not registers in case of
+ vxsim */
+ pregs = (REG_SET *) ((void *)pregs + (__gnat_is_vxsim ? 16 : 0));
#endif
+
+ /* And now call the real signal trampoline with the list of registers */
+ __gnat_sigtramp_common (signo, si, sc, handler, pregs);
}
/* Include the target specific bits. */
@@ -127,12 +177,8 @@ void __gnat_sigtramp (int signo, void *si, void *sc,
/* sigtramp stub for common registers. */
-#define TRAMP_COMMON __gnat_sigtramp_common
-
asm (SIGTRAMP_START(TRAMP_COMMON));
asm (CFI_DEF_CFA);
asm (CFI_COMMON_REGS);
asm (SIGTRAMP_BODY);
asm (SIGTRAMP_END(TRAMP_COMMON));
-
-
diff --git a/gcc/ada/sigtramp.h b/gcc/ada/sigtramp.h
index 930365f8d5..7314d6f7db 100644
--- a/gcc/ada/sigtramp.h
+++ b/gcc/ada/sigtramp.h
@@ -43,14 +43,15 @@ extern "C" {
system headers so call it something unique. */
typedef void __sigtramphandler_t (int signo, void *siginfo, void *sigcontext);
-#if defined(__vxworks) && (CPU == SIMNT || CPU == SIMPENTIUM || CPU == SIMLINUX)
-/* Vxsim requires a specially compiled handler. */
-extern void __gnat_sigtramp_vxsim (int signo, void *siginfo, void *sigcontext,
- __sigtramphandler_t * handler);
-#else
+/* The vxsim target has a different sigcontext structure than the one we're
+ compiling the run-time with. We thus need to adjust it in this case */
+#if defined(__vxworks) && (defined (__i386__) || defined (__x86_64__)) && !defined (VTHREADS)
+#define __HANDLE_VXSIM_SC
+extern void __gnat_set_is_vxsim(int val);
+#endif
+
extern void __gnat_sigtramp (int signo, void *siginfo, void *sigcontext,
__sigtramphandler_t * handler);
-#endif
/* The signal trampoline is to be called from an established signal handler.
It sets up the DWARF CFI and calls HANDLER (SIGNO, SIGINFO, SIGCONTEXT).
diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb
index b97fa58765..fc88da8e01 100644
--- a/gcc/ada/sinfo.adb
+++ b/gcc/ada/sinfo.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -366,7 +366,8 @@ package body Sinfo is
or else NT (N).Nkind = N_Formal_Abstract_Subprogram_Declaration
or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration
or else NT (N).Nkind = N_Formal_Package_Declaration
- or else NT (N).Nkind = N_Generic_Association);
+ or else NT (N).Nkind = N_Generic_Association
+ or else NT (N).Nkind = N_Iterated_Component_Association);
return Flag15 (N);
end Box_Present;
@@ -465,6 +466,7 @@ package body Sinfo is
begin
pragma Assert (False
or else NT (N).Nkind = N_Aggregate
+ or else NT (N).Nkind = N_Delta_Aggregate
or else NT (N).Nkind = N_Extension_Aggregate);
return List2 (N);
end Component_Associations;
@@ -691,7 +693,7 @@ package body Sinfo is
end Corresponding_Integer_Value;
function Corresponding_Spec
- (N : Node_Id) return Node_Id is
+ (N : Node_Id) return Entity_Id is
begin
pragma Assert (False
or else NT (N).Nkind = N_Expression_Function
@@ -790,6 +792,7 @@ package body Sinfo is
or else NT (N).Nkind = N_Full_Type_Declaration
or else NT (N).Nkind = N_Implicit_Label_Declaration
or else NT (N).Nkind = N_Incomplete_Type_Declaration
+ or else NT (N).Nkind = N_Iterated_Component_Association
or else NT (N).Nkind = N_Iterator_Specification
or else NT (N).Nkind = N_Loop_Parameter_Specification
or else NT (N).Nkind = N_Number_Declaration
@@ -879,6 +882,7 @@ package body Sinfo is
pragma Assert (False
or else NT (N).Nkind = N_Case_Expression_Alternative
or else NT (N).Nkind = N_Case_Statement_Alternative
+ or else NT (N).Nkind = N_Iterated_Component_Association
or else NT (N).Nkind = N_Variant);
return List4 (N);
end Discrete_Choices;
@@ -1262,12 +1266,14 @@ package body Sinfo is
or else NT (N).Nkind = N_Component_Declaration
or else NT (N).Nkind = N_Delay_Relative_Statement
or else NT (N).Nkind = N_Delay_Until_Statement
+ or else NT (N).Nkind = N_Delta_Aggregate
or else NT (N).Nkind = N_Discriminant_Association
or else NT (N).Nkind = N_Discriminant_Specification
or else NT (N).Nkind = N_Exception_Declaration
or else NT (N).Nkind = N_Expression_Function
or else NT (N).Nkind = N_Expression_With_Actions
or else NT (N).Nkind = N_Free_Statement
+ or else NT (N).Nkind = N_Iterated_Component_Association
or else NT (N).Nkind = N_Mod_Clause
or else NT (N).Nkind = N_Modular_Type_Definition
or else NT (N).Nkind = N_Number_Declaration
@@ -1284,6 +1290,14 @@ package body Sinfo is
return Node3 (N);
end Expression;
+ function Expression_Copy
+ (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Pragma_Argument_Association);
+ return Node2 (N);
+ end Expression_Copy;
+
function Expressions
(N : Node_Id) return List_Id is
begin
@@ -1594,6 +1608,14 @@ package body Sinfo is
return Flag5 (N);
end Has_Storage_Size_Pragma;
+ function Has_Target_Names
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Assignment_Statement);
+ return Flag8 (N);
+ end Has_Target_Names;
+
function Has_Wide_Character
(N : Node_Id) return Boolean is
begin
@@ -1752,6 +1774,14 @@ package body Sinfo is
return Uint3 (N);
end Intval;
+ function Is_Abort_Block
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Block_Statement);
+ return Flag4 (N);
+ end Is_Abort_Block;
+
function Is_Accessibility_Actual
(N : Node_Id) return Boolean is
begin
@@ -1793,6 +1823,14 @@ package body Sinfo is
return Flag11 (N);
end Is_Checked;
+ function Is_Checked_Ghost_Pragma
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Pragma);
+ return Flag3 (N);
+ end Is_Checked_Ghost_Pragma;
+
function Is_Component_Left_Opnd
(N : Node_Id) return Boolean is
begin
@@ -1901,22 +1939,22 @@ package body Sinfo is
return Flag2 (N);
end Is_Generic_Contract_Pragma;
- function Is_Ghost_Pragma
+ function Is_Ignored
(N : Node_Id) return Boolean is
begin
pragma Assert (False
+ or else NT (N).Nkind = N_Aspect_Specification
or else NT (N).Nkind = N_Pragma);
- return Flag3 (N);
- end Is_Ghost_Pragma;
+ return Flag9 (N);
+ end Is_Ignored;
- function Is_Ignored
+ function Is_Ignored_Ghost_Pragma
(N : Node_Id) return Boolean is
begin
pragma Assert (False
- or else NT (N).Nkind = N_Aspect_Specification
or else NT (N).Nkind = N_Pragma);
- return Flag9 (N);
- end Is_Ignored;
+ return Flag8 (N);
+ end Is_Ignored_Ghost_Pragma;
function Is_In_Discriminant_Check
(N : Node_Id) return Boolean is
@@ -1982,6 +2020,14 @@ package body Sinfo is
return Flag7 (N);
end Is_Protected_Subprogram_Body;
+ function Is_Qualified_Universal_Literal
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Qualified_Expression);
+ return Flag4 (N);
+ end Is_Qualified_Universal_Literal;
+
function Is_Static_Coextension
(N : Node_Id) return Boolean is
begin
@@ -2166,7 +2212,8 @@ package body Sinfo is
(N : Node_Id) return List_Id is
begin
pragma Assert (False
- or else NT (N).Nkind = N_Component_Association);
+ or else NT (N).Nkind = N_Component_Association
+ or else NT (N).Nkind = N_Iterated_Component_Association);
return List2 (N);
end Loop_Actions;
@@ -2401,6 +2448,14 @@ package body Sinfo is
return Flag17 (N);
end No_Minimize_Eliminate;
+ function No_Side_Effect_Removal
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Function_Call);
+ return Flag1 (N);
+ end No_Side_Effect_Removal;
+
function No_Truncation
(N : Node_Id) return Boolean is
begin
@@ -3622,7 +3677,8 @@ package body Sinfo is
or else NT (N).Nkind = N_Formal_Abstract_Subprogram_Declaration
or else NT (N).Nkind = N_Formal_Concrete_Subprogram_Declaration
or else NT (N).Nkind = N_Formal_Package_Declaration
- or else NT (N).Nkind = N_Generic_Association);
+ or else NT (N).Nkind = N_Generic_Association
+ or else NT (N).Nkind = N_Iterated_Component_Association);
Set_Flag15 (N, Val);
end Set_Box_Present;
@@ -3721,6 +3777,7 @@ package body Sinfo is
begin
pragma Assert (False
or else NT (N).Nkind = N_Aggregate
+ or else NT (N).Nkind = N_Delta_Aggregate
or else NT (N).Nkind = N_Extension_Aggregate);
Set_List2_With_Parent (N, Val);
end Set_Component_Associations;
@@ -3947,7 +4004,7 @@ package body Sinfo is
end Set_Corresponding_Integer_Value;
procedure Set_Corresponding_Spec
- (N : Node_Id; Val : Node_Id) is
+ (N : Node_Id; Val : Entity_Id) is
begin
pragma Assert (False
or else NT (N).Nkind = N_Expression_Function
@@ -4046,6 +4103,7 @@ package body Sinfo is
or else NT (N).Nkind = N_Full_Type_Declaration
or else NT (N).Nkind = N_Implicit_Label_Declaration
or else NT (N).Nkind = N_Incomplete_Type_Declaration
+ or else NT (N).Nkind = N_Iterated_Component_Association
or else NT (N).Nkind = N_Iterator_Specification
or else NT (N).Nkind = N_Loop_Parameter_Specification
or else NT (N).Nkind = N_Number_Declaration
@@ -4135,6 +4193,7 @@ package body Sinfo is
pragma Assert (False
or else NT (N).Nkind = N_Case_Expression_Alternative
or else NT (N).Nkind = N_Case_Statement_Alternative
+ or else NT (N).Nkind = N_Iterated_Component_Association
or else NT (N).Nkind = N_Variant);
Set_List4_With_Parent (N, Val);
end Set_Discrete_Choices;
@@ -4509,12 +4568,14 @@ package body Sinfo is
or else NT (N).Nkind = N_Component_Declaration
or else NT (N).Nkind = N_Delay_Relative_Statement
or else NT (N).Nkind = N_Delay_Until_Statement
+ or else NT (N).Nkind = N_Delta_Aggregate
or else NT (N).Nkind = N_Discriminant_Association
or else NT (N).Nkind = N_Discriminant_Specification
or else NT (N).Nkind = N_Exception_Declaration
or else NT (N).Nkind = N_Expression_Function
or else NT (N).Nkind = N_Expression_With_Actions
or else NT (N).Nkind = N_Free_Statement
+ or else NT (N).Nkind = N_Iterated_Component_Association
or else NT (N).Nkind = N_Mod_Clause
or else NT (N).Nkind = N_Modular_Type_Definition
or else NT (N).Nkind = N_Number_Declaration
@@ -4531,6 +4592,14 @@ package body Sinfo is
Set_Node3_With_Parent (N, Val);
end Set_Expression;
+ procedure Set_Expression_Copy
+ (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Pragma_Argument_Association);
+ Set_Node2 (N, Val); -- semantic field, no parent set
+ end Set_Expression_Copy;
+
procedure Set_Expressions
(N : Node_Id; Val : List_Id) is
begin
@@ -4841,6 +4910,14 @@ package body Sinfo is
Set_Flag5 (N, Val);
end Set_Has_Storage_Size_Pragma;
+ procedure Set_Has_Target_Names
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Assignment_Statement);
+ Set_Flag8 (N, Val);
+ end Set_Has_Target_Names;
+
procedure Set_Has_Wide_Character
(N : Node_Id; Val : Boolean := True) is
begin
@@ -4999,6 +5076,14 @@ package body Sinfo is
Set_Uint3 (N, Val);
end Set_Intval;
+ procedure Set_Is_Abort_Block
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Block_Statement);
+ Set_Flag4 (N, Val);
+ end Set_Is_Abort_Block;
+
procedure Set_Is_Accessibility_Actual
(N : Node_Id; Val : Boolean := True) is
begin
@@ -5040,6 +5125,14 @@ package body Sinfo is
Set_Flag11 (N, Val);
end Set_Is_Checked;
+ procedure Set_Is_Checked_Ghost_Pragma
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Pragma);
+ Set_Flag3 (N, Val);
+ end Set_Is_Checked_Ghost_Pragma;
+
procedure Set_Is_Component_Left_Opnd
(N : Node_Id; Val : Boolean := True) is
begin
@@ -5148,22 +5241,22 @@ package body Sinfo is
Set_Flag2 (N, Val);
end Set_Is_Generic_Contract_Pragma;
- procedure Set_Is_Ghost_Pragma
+ procedure Set_Is_Ignored
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
+ or else NT (N).Nkind = N_Aspect_Specification
or else NT (N).Nkind = N_Pragma);
- Set_Flag3 (N, Val);
- end Set_Is_Ghost_Pragma;
+ Set_Flag9 (N, Val);
+ end Set_Is_Ignored;
- procedure Set_Is_Ignored
+ procedure Set_Is_Ignored_Ghost_Pragma
(N : Node_Id; Val : Boolean := True) is
begin
pragma Assert (False
- or else NT (N).Nkind = N_Aspect_Specification
or else NT (N).Nkind = N_Pragma);
- Set_Flag9 (N, Val);
- end Set_Is_Ignored;
+ Set_Flag8 (N, Val);
+ end Set_Is_Ignored_Ghost_Pragma;
procedure Set_Is_In_Discriminant_Check
(N : Node_Id; Val : Boolean := True) is
@@ -5229,6 +5322,14 @@ package body Sinfo is
Set_Flag7 (N, Val);
end Set_Is_Protected_Subprogram_Body;
+ procedure Set_Is_Qualified_Universal_Literal
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Qualified_Expression);
+ Set_Flag4 (N, Val);
+ end Set_Is_Qualified_Universal_Literal;
+
procedure Set_Is_Static_Coextension
(N : Node_Id; Val : Boolean := True) is
begin
@@ -5413,7 +5514,8 @@ package body Sinfo is
(N : Node_Id; Val : List_Id) is
begin
pragma Assert (False
- or else NT (N).Nkind = N_Component_Association);
+ or else NT (N).Nkind = N_Component_Association
+ or else NT (N).Nkind = N_Iterated_Component_Association);
Set_List2 (N, Val); -- semantic field, no parent set
end Set_Loop_Actions;
@@ -5648,6 +5750,14 @@ package body Sinfo is
Set_Flag17 (N, Val);
end Set_No_Minimize_Eliminate;
+ procedure Set_No_Side_Effect_Removal
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Function_Call);
+ Set_Flag1 (N, Val);
+ end Set_No_Side_Effect_Removal;
+
procedure Set_No_Truncation
(N : Node_Id; Val : Boolean := True) is
begin
@@ -6765,9 +6875,53 @@ package body Sinfo is
-- Pragma_Name --
-----------------
- function Pragma_Name (N : Node_Id) return Name_Id is
+ function Pragma_Name_Unmapped (N : Node_Id) return Name_Id is
begin
return Chars (Pragma_Identifier (N));
+ end Pragma_Name_Unmapped;
+
+ ---------------------
+ -- Map_Pragma_Name --
+ ---------------------
+
+ -- We don't want to introduce a dependence on some hash table package or
+ -- similar, so we use a simple array of Key => Value pairs, and do a linear
+ -- search. Linear search is plenty efficient, given that we don't expect
+ -- more than a couple of entries in the mapping.
+
+ type Name_Pair is record
+ Key : Name_Id;
+ Value : Name_Id;
+ end record;
+
+ type Pragma_Map_Index is range 1 .. 100;
+ Pragma_Map : array (Pragma_Map_Index) of Name_Pair;
+ Last_Pair : Pragma_Map_Index'Base range 0 .. Pragma_Map_Index'Last := 0;
+
+ procedure Map_Pragma_Name (From, To : Name_Id) is
+ begin
+ if Last_Pair = Pragma_Map'Last then
+ raise Too_Many_Pragma_Mappings;
+ end if;
+
+ Last_Pair := Last_Pair + 1;
+ Pragma_Map (Last_Pair) := (Key => From, Value => To);
+ end Map_Pragma_Name;
+
+ -----------------
+ -- Pragma_Name --
+ -----------------
+
+ function Pragma_Name (N : Node_Id) return Name_Id is
+ Result : constant Name_Id := Pragma_Name_Unmapped (N);
+ begin
+ for J in Pragma_Map'First .. Last_Pair loop
+ if Result = Pragma_Map (J).Key then
+ return Pragma_Map (J).Value;
+ end if;
+ end loop;
+
+ return Result;
end Pragma_Name;
end Sinfo;
diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index 4ef11a31e8..69f283759b 100644
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -528,26 +528,81 @@ package Sinfo is
-- Ghost Mode --
----------------
- -- When a declaration is subject to pragma Ghost, it establishes a Ghost
- -- region depending on the Ghost assertion policy in effect at the point
- -- of declaration. This region is temporal and starts right before the
- -- analysis of the Ghost declaration and ends after its expansion. The
- -- values of global variable Opt.Ghost_Mode are as follows:
+ -- The SPARK RM 6.9 defines two classes of constructs - Ghost entities and
+ -- Ghost statements. The intent of the feature is to treat Ghost constructs
+ -- as non-existent when Ghost assertion policy Ignore is in effect.
+
+ -- The corresponding nodes which map to Ghost constructs are:
+
+ -- Ghost entities
+ -- Declaration nodes
+ -- N_Package_Body
+ -- N_Subprogram_Body
+
+ -- Ghost statements
+ -- N_Assignment_Statement
+ -- N_Procedure_Call_Statement
+ -- N_Pragma
+
+ -- In addition, the compiler treats instantiations as Ghost entities
+
+ -- To achieve the removal of ignored Ghost constructs, the compiler relies
+ -- on global variable Ghost_Mode and a mechanism called "Ghost regions".
+ -- The values of the global variable are as follows:
-- 1. Check - All static semantics as defined in SPARK RM 6.9 are in
- -- effect.
+ -- effect. The Ghost region has mode Check.
-- 2. Ignore - Same as Check, ignored Ghost code is not present in ALI
- -- files, object files as well as the final executable.
+ -- files, object files, and the final executable. The Ghost region
+ -- has mode Ignore.
+
+ -- 3. None - No Ghost region is in effect
+
+ -- A Ghost region is a compiler operating mode, similar to Check_Syntax,
+ -- however a region is much more finely grained and depends on the policy
+ -- in effect. The region starts prior to the analysis of a Ghost construct
+ -- and ends immediately after its expansion. The region is established as
+ -- follows:
+
+ -- 1. Declarations - Prior to analysis, if the declaration is subject to
+ -- pragma Ghost.
+
+ -- 2. Renaming declarations - Same as 1) or when the renamed entity is
+ -- Ghost.
+
+ -- 3. Completing declarations - Same as 1) or when the declaration is
+ -- partially analyzed and the declaration completes a Ghost entity.
+
+ -- 4. N_Package_Body, N_Subprogram_Body - Same as 1) or when the body is
+ -- partially analyzed and completes a Ghost entity.
+
+ -- 5. N_Assignment_Statement - After the left hand side is analyzed and
+ -- references a Ghost entity.
+
+ -- 6. N_Procedure_Call_Statement - After the name is analyzed and denotes
+ -- a Ghost procedure.
+
+ -- 7. N_Pragma - During analysis, when the related entity is Ghost or the
+ -- pragma encloses a Ghost entity.
+
+ -- 8. Instantiations - Save as 1) or when the instantiation is partially
+ -- analyzed and the generic template is Ghost.
+
+ -- Routines Mark_And_Set_Ghost_xxx install a new Ghost region and routine
+ -- Restore_Ghost_Mode ends a Ghost region. A region may be reinstalled
+ -- similar to scopes for decoupled expansion such as the generation of
+ -- dispatch tables or the creation of a predicate function.
- -- To achieve the runtime semantics of "Ignore", the compiler marks each
- -- node created during an ignored Ghost region and signals all enclosing
- -- scopes that such a node resides within. The compilation unit where the
- -- node resides is also added to an auxiliary table for post processing.
+ -- If the mode of a Ghost region is Ignore, any newly created nodes as well
+ -- as source entities are marked as ignored Ghost. In additon, the marking
+ -- process signals all enclosing scopes that an ignored Ghost node resides
+ -- within. The compilation unit where the node resides is also added to an
+ -- auxiliary table for post processing.
-- After the analysis and expansion of all compilation units takes place
-- as well as the instantiation of all inlined [generic] bodies, the GNAT
- -- driver initiates a separate pass which removes all ignored Ghost code
+ -- driver initiates a separate pass which removes all ignored Ghost nodes
-- from all units stored in the auxiliary table.
--------------------
@@ -645,7 +700,10 @@ package Sinfo is
-- analysis, on expression nodes that may trigger the corresponding
-- check. The front end then inserts or not the check during expansion. In
-- particular, these flags should also be correctly set in ASIS mode and
- -- GNATprove mode.
+ -- GNATprove mode. As a special case, the front end does not insert a
+ -- Do_Division_Check flag on float exponentiation expressions, for the case
+ -- where the value is 0.0 and the exponent is negative, although this case
+ -- does lead to a division check failure.
-- Note: the expander always takes care of the Do_Range check case,
-- so this flag will never be set in the expanded tree passed to the
@@ -735,6 +793,11 @@ package Sinfo is
-- they are systematically expanded into loops (for arrays) and
-- individual assignments (for records).
+ -- Unconstrained array types are handled by means of fat pointers.
+
+ -- Postconditions are inlined by the frontend since their body may have
+ -- references to itypes defined in the enclosing subprogram.
+
------------------------------------
-- Description of Semantic Fields --
------------------------------------
@@ -879,9 +942,9 @@ package Sinfo is
-- Present in subprogram declarations. Denotes analyzed but unexpanded
-- body of subprogram, to be used when inlining calls. Present when the
-- subprogram has an Inline pragma and inlining is enabled. If the
- -- declaration is completed by a renaming_as_body, and the renamed en-
- -- tity is a subprogram, the Body_To_Inline is the name of that entity,
- -- which is used directly in later calls to the original subprogram.
+ -- declaration is completed by a renaming_as_body, and the renamed entity
+ -- is a subprogram, the Body_To_Inline is the name of that entity, which
+ -- is used directly in later calls to the original subprogram.
-- Body_Required (Flag13-Sem)
-- A flag that appears in the N_Compilation_Unit node indicating that
@@ -1281,6 +1344,12 @@ package Sinfo is
-- target of the assignment or initialization is used to generate the
-- left-hand side of individual assignment to each sub-component.
+ -- Expression_Copy (Node2-Sem)
+ -- Present in N_Pragma_Argument_Association nodes. Contains a copy of the
+ -- original expression. This field is best used to store pragma-dependent
+ -- modifications performed on the original expression such as replacement
+ -- of the current type instance or substitutions of primitives.
+
-- First_Inlined_Subprogram (Node3-Sem)
-- Present in the N_Compilation_Unit node for the main program. Points
-- to a chain of entities for subprograms that are to be inlined. The
@@ -1469,6 +1538,10 @@ package Sinfo is
-- A flag present in an N_Task_Definition node to flag the presence of a
-- Storage_Size pragma.
+ -- Has_Target_Names (Flag8-Sem)
+ -- Present in assignment statements. Indicates that the RHS contains
+ -- target names (see AI12-0125-3) and must be expanded accordingly.
+
-- Has_Wide_Character (Flag11-Sem)
-- Present in string literals, set if any wide character (i.e. character
-- code outside the Character range but within Wide_Character range)
@@ -1494,10 +1567,10 @@ package Sinfo is
-- Implicit_With (Flag16-Sem)
-- This flag is set in the N_With_Clause node that is implicitly
- -- generated for runtime units that are loaded by the expander, and also
- -- for package System, if it is loaded implicitly by a use of the
- -- 'Address or 'Tag attribute. ???There are other implicit with clauses
- -- as well.
+ -- generated for runtime units that are loaded by the expander or in
+ -- GNATprove mode, and also for package System, if it is loaded
+ -- implicitly by a use of the 'Address or 'Tag attribute.
+ -- ??? There are other implicit with clauses as well.
-- Implicit_With_From_Instantiation (Flag12-Sem)
-- Set in N_With_Clause nodes from generic instantiations.
@@ -1535,6 +1608,10 @@ package Sinfo is
-- to the node for the spec of the instance, inserted as part of the
-- semantic processing for instantiations in Sem_Ch12.
+ -- Is_Abort_Block (Flag4-Sem)
+ -- Present in N_Block_Statement nodes. True if the block protects a list
+ -- of statements with an Abort_Defer / Abort_Undefer_Direct pair.
+
-- Is_Accessibility_Actual (Flag13-Sem)
-- Present in N_Parameter_Association nodes. True if the parameter is
-- an extra actual that carries the accessibility level of the actual
@@ -1571,6 +1648,11 @@ package Sinfo is
-- be further modified (in some cases these flags are copied when a
-- pragma is rewritten).
+ -- Is_Checked_Ghost_Pragma (Flag3-Sem)
+ -- This flag is present in N_Pragma nodes. It is set when the pragma is
+ -- related to a checked Ghost entity or encloses a checked Ghost entity.
+ -- This flag has no relation to Is_Checked.
+
-- Is_Component_Left_Opnd (Flag13-Sem)
-- Is_Component_Right_Opnd (Flag14-Sem)
-- Present in concatenation nodes, to indicate that the corresponding
@@ -1612,7 +1694,7 @@ package Sinfo is
-- actuals to support a build-in-place style of call have been added to
-- the call.
- -- Is_Finalization_Wrapper (Flag9-Sem);
+ -- Is_Finalization_Wrapper (Flag9-Sem)
-- This flag is present in N_Block_Statement nodes. It is set when the
-- block acts as a wrapper of a handled construct which has controlled
-- objects. The wrapper prevents interference between exception handlers
@@ -1641,11 +1723,6 @@ package Sinfo is
-- Refined_State
-- Test_Case
- -- Is_Ghost_Pragma (Flag3-Sem)
- -- This flag is present in N_Pragma nodes. It is set when the pragma is
- -- either declared within a Ghost construct or it applies to a Ghost
- -- construct.
-
-- Is_Ignored (Flag9-Sem)
-- A flag set in an N_Aspect_Specification or N_Pragma node if there was
-- a Check_Policy or Assertion_Policy (or in the case of a Debug_Pragma)
@@ -1660,6 +1737,11 @@ package Sinfo is
-- aspect/pragma is fully analyzed and checked for other syntactic
-- and semantic errors, but it does not have any semantic effect.
+ -- Is_Ignored_Ghost_Pragma (Flag8-Sem)
+ -- This flag is present in N_Pragma nodes. It is set when the pragma is
+ -- related to an ignored Ghost entity or encloses ignored Ghost entity.
+ -- This flag has no relation to Is_Ignored.
+
-- Is_In_Discriminant_Check (Flag11-Sem)
-- This flag is present in a selected component, and is used to indicate
-- that the reference occurs within a discriminant check. The
@@ -1710,6 +1792,12 @@ package Sinfo is
-- handler to make sure that the associated protected object is unlocked
-- when the subprogram completes.
+ -- Is_Qualified_Universal_Literal (Flag4-Sem)
+ -- Present in N_Qualified_Expression nodes. Set when the qualification is
+ -- converting a universal literal to a specific type. Such qualifiers aid
+ -- the resolution of accidental overloading of binary or unary operators
+ -- which may occur in instances.
+
-- Is_Static_Coextension (Flag14-Sem)
-- Present in N_Allocator nodes. Set if the allocator is a coextension
-- of an object allocated on the stack rather than the heap.
@@ -1940,6 +2028,12 @@ package Sinfo is
-- It is used to indicate that processing for extended overflow checking
-- modes is not required (this is used to prevent infinite recursion).
+ -- No_Side_Effect_Removal (Flag1-Sem)
+ -- Present in N_Function_Call nodes. Set when a function call does not
+ -- require side effect removal. This attribute suppresses the generation
+ -- of a temporary to capture the result of the function which eventually
+ -- replaces the function call.
+
-- No_Truncation (Flag17-Sem)
-- Present in N_Unchecked_Type_Conversion node. This flag has an effect
-- only if the RM_Size of the source is greater than the RM_Size of the
@@ -1992,7 +2086,7 @@ package Sinfo is
-- Parent_Spec (Node4-Sem)
-- For a library unit that is a child unit spec (package or subprogram
-- declaration, generic declaration or instantiation, or library level
- -- rename, this field points to the compilation unit node for the parent
+ -- rename) this field points to the compilation unit node for the parent
-- package specification. This field is Empty for library bodies (the
-- parent spec in this case can be found from the corresponding spec).
@@ -2387,8 +2481,8 @@ package Sinfo is
-- Original_Entity (Node2-Sem) If not Empty, holds Named_Number that
-- has been constant-folded into its literal value.
-- Intval (Uint3) contains integer value of literal
- -- plus fields for expression
-- Print_In_Hex (Flag13-Sem)
+ -- plus fields for expression
-- N_Real_Literal
-- Sloc points to literal
@@ -2497,11 +2591,12 @@ package Sinfo is
-- Import_Interface_Present (Flag16-Sem)
-- Is_Analyzed_Pragma (Flag5-Sem)
-- Is_Checked (Flag11-Sem)
+ -- Is_Checked_Ghost_Pragma (Flag3-Sem)
-- Is_Delayed_Aspect (Flag14-Sem)
-- Is_Disabled (Flag15-Sem)
-- Is_Generic_Contract_Pragma (Flag2-Sem)
- -- Is_Ghost_Pragma (Flag3-Sem)
-- Is_Ignored (Flag9-Sem)
+ -- Is_Ignored_Ghost_Pragma (Flag8-Sem)
-- Is_Inherited_Pragma (Flag4-Sem)
-- Split_PPC (Flag17) set if corresponding aspect had Split_PPC set
-- Uneval_Old_Accept (Flag7-Sem)
@@ -2512,8 +2607,8 @@ package Sinfo is
-- Psect_Object is always converted to Common_Object, but there are
-- undoubtedly many other similar notes required ???
- -- Note: a utility function Pragma_Name may be applied to pragma nodes
- -- to conveniently obtain the Chars field of the Pragma_Identifier.
+ -- Note: utility functions Pragma_Name_Unmapped and Pragma_Name may be
+ -- applied to pragma nodes to obtain the Chars or its mapped version.
-- Note: if From_Aspect_Specification is set, then Sloc points to the
-- aspect name, as does the Pragma_Identifier. In this case if the
@@ -2555,6 +2650,7 @@ package Sinfo is
-- N_Pragma_Argument_Association
-- Sloc points to first token in association
-- Chars (Name1) (set to No_Name if no pragma argument identifier)
+ -- Expression_Copy (Node2-Sem)
-- Expression (Node3)
------------------------
@@ -2748,7 +2844,7 @@ package Sinfo is
-- Note: aliased is not permitted in Ada 83 mode
- -- The N_Object_Declaration node is only for the first two cases.
+ -- The N_Object_Declaration node is only for the first three cases.
-- Single task declaration is handled by P_Task (9.1)
-- Single protected declaration is handled by P_protected (9.5)
@@ -3275,7 +3371,7 @@ package Sinfo is
-- N_Discriminant_Association
-- Sloc points to first token of discriminant association
-- Selector_Names (List1) (always non-empty, since if no selector
- -- names are present, this node is not used, see comment above)
+ -- names are present, this node is not used, see comment above)
-- Expression (Node3)
---------------------------------
@@ -3813,7 +3909,6 @@ package Sinfo is
-- Must_Be_Byte_Aligned (Flag14-Sem)
-- Non_Aliased_Prefix (Flag18-Sem)
-- Redundant_Use (Flag13-Sem)
-
-- plus fields for expression
-- Note: in Modify_Tree_For_C mode, Max and Min attributes are expanded
@@ -4014,8 +4109,38 @@ package Sinfo is
-- ARRAY_COMPONENT_ASSOCIATION ::=
-- DISCRETE_CHOICE_LIST => EXPRESSION
+ -- | ITERATED_COMPONENT_ASSOCIATION
-- See Record_Component_Association (4.3.1) for node structure
+ -- The iterated_component_association is introduced into the
+ -- Corrigendum of Ada_2012 by AI12-061.
+
+ ------------------------------------------
+ -- 4.3.3 Iterated component Association --
+ ------------------------------------------
+
+ -- ITERATED_COMPONENT_ASSOCIATION ::=
+ -- for DEFINING_IDENTIFIER in DISCRETE_CHOICE_LIST => EXPRESSION
+
+ -- N_Iterated_Component_Association
+ -- Sloc points to FOR
+ -- Defining_Identifier (Node1)
+ -- Loop_Actions (List2-Sem)
+ -- Expression (Node3)
+ -- Discrete_Choices (List4)
+ -- Box_Present (Flag15)
+
+ -- Note that Box_Present is always False, but it is intentionally added
+ -- for completeness.
+
+ ----------------------------
+ -- 4.3.4 Delta Aggregate --
+ ----------------------------
+
+ -- N_Delta_Aggregate
+ -- Sloc points to left parenthesis
+ -- Expression (Node3)
+ -- Component_Associations (List2)
--------------------------------------------------
-- 4.4 Expression/Relation/Term/Factor/Primary --
@@ -4113,7 +4238,7 @@ package Sinfo is
-- treated as though it were Empty) if No_Initialization is set True.
--------------------------------------
- -- 4.5 Short Circuit Control Forms --
+ -- 4.5 Short-Circuit Control Forms --
--------------------------------------
-- EXPRESSION ::=
@@ -4318,8 +4443,8 @@ package Sinfo is
-- plus fields for expression
-- N_Op_Expon
- -- Is_Power_Of_2_For_Shift (Flag13-Sem)
-- Sloc points to **
+ -- Is_Power_Of_2_For_Shift (Flag13-Sem)
-- plus fields for binary operator
-- plus fields for expression
@@ -4541,6 +4666,7 @@ package Sinfo is
-- Sloc points to apostrophe
-- Subtype_Mark (Node4)
-- Expression (Node3) expression or aggregate
+ -- Is_Qualified_Universal_Literal (Flag4-Sem)
-- plus fields for expression
--------------------
@@ -4681,6 +4807,7 @@ package Sinfo is
-- Forwards_OK (Flag5-Sem)
-- Backwards_OK (Flag6-Sem)
-- No_Ctrl_Actions (Flag7-Sem)
+ -- Has_Target_Names (Flag8-Sem)
-- Componentwise_Assignment (Flag14-Sem)
-- Suppress_Assignment_Checks (Flag18-Sem)
@@ -4695,6 +4822,19 @@ package Sinfo is
-- case the front end must generate an extra temporary and initialize
-- this temporary as required (the temporary itself is not atomic).
+ ------------------
+ -- Target_Name --
+ ------------------
+
+ -- N_Target_Name
+ -- Sloc points to @
+ -- Etype (Node5-Sem)
+
+ -- Note (Ada 2020): node is used during analysis as a placeholder for
+ -- the value of the LHS of the enclosing assignment statement. Node is
+ -- eventually rewritten together with enclosing assignment, and backends
+ -- are not aware of it.
+
-----------------------
-- 5.3 If Statement --
-----------------------
@@ -4924,6 +5064,7 @@ package Sinfo is
-- Declarations (List2) (set to No_List if no DECLARE part)
-- Handled_Statement_Sequence (Node4)
-- Cleanup_Actions (List5-Sem)
+ -- Is_Abort_Block (Flag4-Sem)
-- Is_Task_Master (Flag5-Sem)
-- Activation_Chain_Entity (Node3-Sem)
-- Has_Created_Identifier (Flag15)
@@ -5214,13 +5355,13 @@ package Sinfo is
-- Acts_As_Spec (Flag4-Sem)
-- Bad_Is_Detected (Flag15) used only by parser
-- Do_Storage_Check (Flag17-Sem)
+ -- Has_Relative_Deadline_Pragma (Flag9-Sem)
-- Is_Entry_Barrier_Function (Flag8-Sem)
-- Is_Protected_Subprogram_Body (Flag7-Sem)
-- Is_Task_Body_Procedure (Flag1-Sem)
-- Is_Task_Master (Flag5-Sem)
- -- Was_Originally_Stub (Flag13-Sem)
- -- Has_Relative_Deadline_Pragma (Flag9-Sem)
-- Was_Expression_Function (Flag18-Sem)
+ -- Was_Originally_Stub (Flag13-Sem)
-------------------------
-- Expression Function --
@@ -5268,7 +5409,7 @@ package Sinfo is
-- argument expression has the Do_Range_Check flag set, and the range
-- check is done against the formal type. Note that this argument
-- expression may appear directly in the Parameter_Associations list,
- -- or may be a descendent of an N_Parameter_Association node that
+ -- or may be a descendant of an N_Parameter_Association node that
-- appears in this list.
------------------------
@@ -5289,6 +5430,7 @@ package Sinfo is
-- actual parameter part)
-- First_Named_Actual (Node4-Sem)
-- Controlling_Argument (Node1-Sem) (set to Empty if not dispatching)
+ -- No_Side_Effect_Removal (Flag1-Sem)
-- Is_Expanded_Build_In_Place_Call (Flag11-Sem)
-- Do_Tag_Check (Flag13-Sem)
-- No_Elaboration_Check (Flag14-Sem)
@@ -7611,6 +7753,10 @@ package Sinfo is
-- source, or because a Pre (resp. Post) aspect specification has been
-- broken into AND THEN sections. See Split_PPC for details.
+ -- In GNATprove mode, the inherited classwide pre- and postconditions
+ -- (suitably specialized for the specific type of the overriding
+ -- operation) are also in this list.
+
-- Contract_Test_Cases contains a collection of pragmas that correspond
-- to aspects/pragmas Contract_Cases and Test_Case. The ordering in the
-- list is in LIFO fashion.
@@ -7670,7 +7816,7 @@ package Sinfo is
-----------------------------
-- This node is created by the analyzer/expander to handle some
- -- expansion cases, notably short circuit forms where there are
+ -- expansion cases, notably short-circuit forms where there are
-- actions associated with the right-hand side operand.
-- The N_Expression_With_Actions node represents an expression with
@@ -7877,17 +8023,15 @@ package Sinfo is
-- same as the type of the subexpression which it replaces.
-- If Condition is empty, then the raise is unconditional. If the
- -- Condition field is non-empty, it is a boolean expression which
- -- is first evaluated, and the exception is raised only if the
- -- value of the expression is True. In the unconditional case, the
- -- creation of this node is usually accompanied by a warning message
- -- error. The creation of this node will usually be accompanied by a
- -- message (unless it appears within the right operand of a short
- -- circuit form whose left argument is static and decisively
- -- eliminates elaboration of the raise operation. The condition field
- -- can ONLY be present when the node is used as a statement form, it
- -- may NOT be present in the case where the node appears within an
- -- expression.
+ -- Condition field is non-empty, it is a boolean expression which is
+ -- first evaluated, and the exception is raised only if the value of the
+ -- expression is True. In the unconditional case, the creation of this
+ -- node is usually accompanied by a warning message (unless it appears
+ -- within the right operand of a short-circuit form whose left argument
+ -- is static and decisively eliminates elaboration of the raise
+ -- operation). The condition field can ONLY be present when the node is
+ -- used as a statement form; it must NOT be present in the case where
+ -- the node appears within an expression.
-- The exception is generated with a message that contains the
-- file name and line number, and then appended text. The Reason
@@ -8340,12 +8484,14 @@ package Sinfo is
N_Aggregate,
N_Allocator,
N_Case_Expression,
+ N_Delta_Aggregate,
N_Extension_Aggregate,
N_Raise_Expression,
N_Range,
N_Reference,
N_Selected_Component,
N_Slice,
+ N_Target_Name,
N_Type_Conversion,
N_Unchecked_Expression,
N_Unchecked_Type_Conversion,
@@ -8556,6 +8702,7 @@ package Sinfo is
N_Generic_Association,
N_Handled_Sequence_Of_Statements,
N_Index_Or_Discriminant_Constraint,
+ N_Iterated_Component_Association,
N_Itype_Reference,
N_Label,
N_Modular_Type_Definition,
@@ -8993,7 +9140,7 @@ package Sinfo is
(N : Node_Id) return Uint; -- Uint4
function Corresponding_Spec
- (N : Node_Id) return Node_Id; -- Node5
+ (N : Node_Id) return Entity_Id; -- Node5
function Corresponding_Spec_Of_Stub
(N : Node_Id) return Node_Id; -- Node2
@@ -9160,6 +9307,9 @@ package Sinfo is
function Expression
(N : Node_Id) return Node_Id; -- Node3
+ function Expression_Copy
+ (N : Node_Id) return Node_Id; -- Node2
+
function Expressions
(N : Node_Id) return List_Id; -- List1
@@ -9264,6 +9414,9 @@ package Sinfo is
function Has_Storage_Size_Pragma
(N : Node_Id) return Boolean; -- Flag5
+ function Has_Target_Names
+ (N : Node_Id) return Boolean; -- Flag8
+
function Has_Wide_Character
(N : Node_Id) return Boolean; -- Flag11
@@ -9315,6 +9468,9 @@ package Sinfo is
function Intval
(N : Node_Id) return Uint; -- Uint3
+ function Is_Abort_Block
+ (N : Node_Id) return Boolean; -- Flag4
+
function Is_Accessibility_Actual
(N : Node_Id) return Boolean; -- Flag13
@@ -9330,6 +9486,9 @@ package Sinfo is
function Is_Checked
(N : Node_Id) return Boolean; -- Flag11
+ function Is_Checked_Ghost_Pragma
+ (N : Node_Id) return Boolean; -- Flag3
+
function Is_Component_Left_Opnd
(N : Node_Id) return Boolean; -- Flag13
@@ -9369,12 +9528,12 @@ package Sinfo is
function Is_Generic_Contract_Pragma
(N : Node_Id) return Boolean; -- Flag2
- function Is_Ghost_Pragma
- (N : Node_Id) return Boolean; -- Flag3
-
function Is_Ignored
(N : Node_Id) return Boolean; -- Flag9
+ function Is_Ignored_Ghost_Pragma
+ (N : Node_Id) return Boolean; -- Flag8
+
function Is_In_Discriminant_Check
(N : Node_Id) return Boolean; -- Flag11
@@ -9399,6 +9558,9 @@ package Sinfo is
function Is_Protected_Subprogram_Body
(N : Node_Id) return Boolean; -- Flag7
+ function Is_Qualified_Universal_Literal
+ (N : Node_Id) return Boolean; -- Flag4
+
function Is_Static_Coextension
(N : Node_Id) return Boolean; -- Flag14
@@ -9528,6 +9690,9 @@ package Sinfo is
function No_Minimize_Eliminate
(N : Node_Id) return Boolean; -- Flag17
+ function No_Side_Effect_Removal
+ (N : Node_Id) return Boolean; -- Flag1
+
function No_Truncation
(N : Node_Id) return Boolean; -- Flag17
@@ -10033,7 +10198,7 @@ package Sinfo is
(N : Node_Id; Val : Uint); -- Uint4
procedure Set_Corresponding_Spec
- (N : Node_Id; Val : Node_Id); -- Node5
+ (N : Node_Id; Val : Entity_Id); -- Node5
procedure Set_Corresponding_Spec_Of_Stub
(N : Node_Id; Val : Node_Id); -- Node2
@@ -10197,6 +10362,9 @@ package Sinfo is
procedure Set_Expression
(N : Node_Id; Val : Node_Id); -- Node3
+ procedure Set_Expression_Copy
+ (N : Node_Id; Val : Node_Id); -- Node2
+
procedure Set_Expressions
(N : Node_Id; Val : List_Id); -- List1
@@ -10302,6 +10470,9 @@ package Sinfo is
procedure Set_Has_Storage_Size_Pragma
(N : Node_Id; Val : Boolean := True); -- Flag5
+ procedure Set_Has_Target_Names
+ (N : Node_Id; Val : Boolean := True); -- Flag8
+
procedure Set_Has_Wide_Character
(N : Node_Id; Val : Boolean := True); -- Flag11
@@ -10353,6 +10524,9 @@ package Sinfo is
procedure Set_Intval
(N : Node_Id; Val : Uint); -- Uint3
+ procedure Set_Is_Abort_Block
+ (N : Node_Id; Val : Boolean := True); -- Flag4
+
procedure Set_Is_Accessibility_Actual
(N : Node_Id; Val : Boolean := True); -- Flag13
@@ -10368,6 +10542,9 @@ package Sinfo is
procedure Set_Is_Checked
(N : Node_Id; Val : Boolean := True); -- Flag11
+ procedure Set_Is_Checked_Ghost_Pragma
+ (N : Node_Id; Val : Boolean := True); -- Flag3
+
procedure Set_Is_Component_Left_Opnd
(N : Node_Id; Val : Boolean := True); -- Flag13
@@ -10407,12 +10584,12 @@ package Sinfo is
procedure Set_Is_Generic_Contract_Pragma
(N : Node_Id; Val : Boolean := True); -- Flag2
- procedure Set_Is_Ghost_Pragma
- (N : Node_Id; Val : Boolean := True); -- Flag3
-
procedure Set_Is_Ignored
(N : Node_Id; Val : Boolean := True); -- Flag9
+ procedure Set_Is_Ignored_Ghost_Pragma
+ (N : Node_Id; Val : Boolean := True); -- Flag8
+
procedure Set_Is_In_Discriminant_Check
(N : Node_Id; Val : Boolean := True); -- Flag11
@@ -10437,6 +10614,9 @@ package Sinfo is
procedure Set_Is_Protected_Subprogram_Body
(N : Node_Id; Val : Boolean := True); -- Flag7
+ procedure Set_Is_Qualified_Universal_Literal
+ (N : Node_Id; Val : Boolean := True); -- Flag4
+
procedure Set_Is_Static_Coextension
(N : Node_Id; Val : Boolean := True); -- Flag14
@@ -10566,6 +10746,9 @@ package Sinfo is
procedure Set_No_Minimize_Eliminate
(N : Node_Id; Val : Boolean := True); -- Flag17
+ procedure Set_No_Side_Effect_Removal
+ (N : Node_Id; Val : Boolean := True); -- Flag1
+
procedure Set_No_Truncation
(N : Node_Id; Val : Boolean := True); -- Flag17
@@ -10967,9 +11150,24 @@ package Sinfo is
-- Utility Functions --
-----------------------
+ procedure Map_Pragma_Name (From, To : Name_Id);
+ -- Used in the implementation of pragma Rename_Pragma. Maps pragma name
+ -- From to pragma name To, so From can be used as a synonym for To.
+
+ Too_Many_Pragma_Mappings : exception;
+ -- Raised if Map_Pragma_Name is called too many times. We expect that few
+ -- programs will use it at all, and those that do will use it approximately
+ -- once or twice.
+
function Pragma_Name (N : Node_Id) return Name_Id;
- pragma Inline (Pragma_Name);
- -- Convenient function to obtain Chars field of Pragma_Identifier
+ -- Obtain the name of pragma N from the Chars field of its identifier. If
+ -- the pragma has been renamed using Rename_Pragma, this routine returns
+ -- the name of the renaming.
+
+ function Pragma_Name_Unmapped (N : Node_Id) return Name_Id;
+ -- Obtain the name of pragma N from the Chars field of its identifier. This
+ -- form of name extraction does not take into account renamings performed
+ -- by Rename_Pragma.
-----------------------------
-- Syntactic Parent Tables --
@@ -11030,7 +11228,7 @@ package Sinfo is
N_Pragma_Argument_Association =>
(1 => True, -- Chars (Name1)
- 2 => False, -- unused
+ 2 => False, -- Expression_Copy (Node2-Sem)
3 => True, -- Expression (Node3)
4 => False, -- unused
5 => False), -- unused
@@ -11329,6 +11527,20 @@ package Sinfo is
4 => False, -- unused
5 => False), -- unused
+ N_Iterated_Component_Association =>
+ (1 => True, -- Defining_Identifier (Node1)
+ 2 => False, -- unused
+ 3 => True, -- Expression (Node3)
+ 4 => True, -- Discrete_Choices (List4)
+ 5 => False), -- unused
+
+ N_Delta_Aggregate =>
+ (1 => False, -- Expressions (List1)
+ 2 => True, -- Component_Associations (List2)
+ 3 => True, -- Expression (Node3)
+ 4 => False, -- Unused
+ 5 => False), -- Etype (Node5-Sem)
+
N_Extension_Aggregate =>
(1 => True, -- Expressions (List1)
2 => True, -- Component_Associations (List2)
@@ -11567,6 +11779,13 @@ package Sinfo is
4 => False, -- unused
5 => False), -- unused
+ N_Target_Name =>
+ (1 => False, -- unused
+ 2 => False, -- unused
+ 3 => False, -- unused
+ 4 => False, -- unused
+ 5 => False), -- Etype (Node5-Sem)
+
N_If_Statement =>
(1 => True, -- Condition (Node1)
2 => True, -- Then_Statements (List2)
@@ -12492,14 +12711,14 @@ package Sinfo is
5 => False), -- unused
N_Push_Program_Error_Label =>
- (1 => False, -- Exception_Label
+ (1 => False, -- unused
2 => False, -- unused
3 => False, -- unused
4 => False, -- unused
5 => False), -- Exception_Label
N_Push_Storage_Error_Label =>
- (1 => False, -- Exception_Label
+ (1 => False, -- unused
2 => False, -- unused
3 => False, -- unused
4 => False, -- unused
@@ -12738,6 +12957,7 @@ package Sinfo is
pragma Inline (Explicit_Actual_Parameter);
pragma Inline (Explicit_Generic_Actual_Parameter);
pragma Inline (Expression);
+ pragma Inline (Expression_Copy);
pragma Inline (Expressions);
pragma Inline (First_Bit);
pragma Inline (First_Inlined_Subprogram);
@@ -12773,6 +12993,7 @@ package Sinfo is
pragma Inline (Has_Private_View);
pragma Inline (Has_Relative_Deadline_Pragma);
pragma Inline (Has_Storage_Size_Pragma);
+ pragma Inline (Has_Target_Names);
pragma Inline (Has_Wide_Character);
pragma Inline (Has_Wide_Wide_Character);
pragma Inline (Header_Size_Added);
@@ -12791,11 +13012,13 @@ package Sinfo is
pragma Inline (Instance_Spec);
pragma Inline (Intval);
pragma Inline (Iterator_Specification);
+ pragma Inline (Is_Abort_Block);
pragma Inline (Is_Accessibility_Actual);
pragma Inline (Is_Analyzed_Pragma);
pragma Inline (Is_Asynchronous_Call_Block);
pragma Inline (Is_Boolean_Aspect);
pragma Inline (Is_Checked);
+ pragma Inline (Is_Checked_Ghost_Pragma);
pragma Inline (Is_Component_Left_Opnd);
pragma Inline (Is_Component_Right_Opnd);
pragma Inline (Is_Controlling_Actual);
@@ -12809,8 +13032,8 @@ package Sinfo is
pragma Inline (Is_Finalization_Wrapper);
pragma Inline (Is_Folded_In_Parser);
pragma Inline (Is_Generic_Contract_Pragma);
- pragma Inline (Is_Ghost_Pragma);
pragma Inline (Is_Ignored);
+ pragma Inline (Is_Ignored_Ghost_Pragma);
pragma Inline (Is_In_Discriminant_Check);
pragma Inline (Is_Inherited_Pragma);
pragma Inline (Is_Machine_Number);
@@ -12819,6 +13042,7 @@ package Sinfo is
pragma Inline (Is_Power_Of_2_For_Shift);
pragma Inline (Is_Prefixed_Call);
pragma Inline (Is_Protected_Subprogram_Body);
+ pragma Inline (Is_Qualified_Universal_Literal);
pragma Inline (Is_Static_Coextension);
pragma Inline (Is_Static_Expression);
pragma Inline (Is_Subprogram_Descriptor);
@@ -12861,6 +13085,7 @@ package Sinfo is
pragma Inline (No_Entities_Ref_In_Spec);
pragma Inline (No_Initialization);
pragma Inline (No_Minimize_Eliminate);
+ pragma Inline (No_Side_Effect_Removal);
pragma Inline (No_Truncation);
pragma Inline (Non_Aliased_Prefix);
pragma Inline (Null_Present);
@@ -13081,6 +13306,7 @@ package Sinfo is
pragma Inline (Set_Explicit_Actual_Parameter);
pragma Inline (Set_Explicit_Generic_Actual_Parameter);
pragma Inline (Set_Expression);
+ pragma Inline (Set_Expression_Copy);
pragma Inline (Set_Expressions);
pragma Inline (Set_First_Bit);
pragma Inline (Set_First_Inlined_Subprogram);
@@ -13116,6 +13342,7 @@ package Sinfo is
pragma Inline (Set_Has_Self_Reference);
pragma Inline (Set_Has_SP_Choice);
pragma Inline (Set_Has_Storage_Size_Pragma);
+ pragma Inline (Set_Has_Target_Names);
pragma Inline (Set_Has_Wide_Character);
pragma Inline (Set_Has_Wide_Wide_Character);
pragma Inline (Set_Header_Size_Added);
@@ -13132,11 +13359,13 @@ package Sinfo is
pragma Inline (Set_Interface_List);
pragma Inline (Set_Interface_Present);
pragma Inline (Set_Intval);
+ pragma Inline (Set_Is_Abort_Block);
pragma Inline (Set_Is_Accessibility_Actual);
pragma Inline (Set_Is_Analyzed_Pragma);
pragma Inline (Set_Is_Asynchronous_Call_Block);
pragma Inline (Set_Is_Boolean_Aspect);
pragma Inline (Set_Is_Checked);
+ pragma Inline (Set_Is_Checked_Ghost_Pragma);
pragma Inline (Set_Is_Component_Left_Opnd);
pragma Inline (Set_Is_Component_Right_Opnd);
pragma Inline (Set_Is_Controlling_Actual);
@@ -13150,8 +13379,8 @@ package Sinfo is
pragma Inline (Set_Is_Finalization_Wrapper);
pragma Inline (Set_Is_Folded_In_Parser);
pragma Inline (Set_Is_Generic_Contract_Pragma);
- pragma Inline (Set_Is_Ghost_Pragma);
pragma Inline (Set_Is_Ignored);
+ pragma Inline (Set_Is_Ignored_Ghost_Pragma);
pragma Inline (Set_Is_In_Discriminant_Check);
pragma Inline (Set_Is_Inherited_Pragma);
pragma Inline (Set_Is_Machine_Number);
@@ -13160,6 +13389,7 @@ package Sinfo is
pragma Inline (Set_Is_Power_Of_2_For_Shift);
pragma Inline (Set_Is_Prefixed_Call);
pragma Inline (Set_Is_Protected_Subprogram_Body);
+ pragma Inline (Set_Is_Qualified_Universal_Literal);
pragma Inline (Set_Is_Static_Coextension);
pragma Inline (Set_Is_Static_Expression);
pragma Inline (Set_Is_Subprogram_Descriptor);
@@ -13203,6 +13433,7 @@ package Sinfo is
pragma Inline (Set_No_Entities_Ref_In_Spec);
pragma Inline (Set_No_Initialization);
pragma Inline (Set_No_Minimize_Eliminate);
+ pragma Inline (Set_No_Side_Effect_Removal);
pragma Inline (Set_No_Truncation);
pragma Inline (Set_Non_Aliased_Prefix);
pragma Inline (Set_Null_Excluding_Subtype);
diff --git a/gcc/ada/sinput-c.adb b/gcc/ada/sinput-c.adb
index 6c3d58254f..3ef0f5af35 100644
--- a/gcc/ada/sinput-c.adb
+++ b/gcc/ada/sinput-c.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -183,6 +183,7 @@ package body Sinput.C is
Identifier_Casing => Unknown,
Inlined_Call => No_Location,
Inlined_Body => False,
+ Inherited_Pragma => False,
Keyword_Casing => Unknown,
Last_Source_Line => 1,
License => Unknown,
diff --git a/gcc/ada/sinput-l.adb b/gcc/ada/sinput-l.adb
index c084555cd9..8141262d55 100644
--- a/gcc/ada/sinput-l.adb
+++ b/gcc/ada/sinput-l.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -91,7 +91,10 @@ package body Sinput.L is
-- Adjust_Instantiation_Sloc --
-------------------------------
- procedure Adjust_Instantiation_Sloc (N : Node_Id; A : Sloc_Adjustment) is
+ procedure Adjust_Instantiation_Sloc
+ (N : Node_Id;
+ Factor : Sloc_Adjustment)
+ is
Loc : constant Source_Ptr := Sloc (N);
begin
@@ -100,8 +103,8 @@ package body Sinput.L is
-- case, but in practice there seem to be some nodes that get copied
-- twice, and this is a defence against that happening.
- if A.Lo <= Loc and then Loc <= A.Hi then
- Set_Sloc (N, Loc + A.Adjust);
+ if Factor.Lo <= Loc and then Loc <= Factor.Hi then
+ Set_Sloc (N, Loc + Factor.Adjust);
end if;
end Adjust_Instantiation_Sloc;
@@ -121,19 +124,20 @@ package body Sinput.L is
---------------------------------
procedure Create_Instantiation_Source
- (Inst_Node : Entity_Id;
- Template_Id : Entity_Id;
- Inlined_Body : Boolean;
- A : out Sloc_Adjustment)
+ (Inst_Node : Entity_Id;
+ Template_Id : Entity_Id;
+ Factor : out Sloc_Adjustment;
+ Inlined_Body : Boolean := False;
+ Inherited_Pragma : Boolean := False)
is
Dnod : constant Node_Id := Declaration_Node (Template_Id);
Xold : Source_File_Index;
Xnew : Source_File_Index;
begin
- Xold := Get_Source_File_Index (Sloc (Template_Id));
- A.Lo := Source_File.Table (Xold).Source_First;
- A.Hi := Source_File.Table (Xold).Source_Last;
+ Xold := Get_Source_File_Index (Sloc (Template_Id));
+ Factor.Lo := Source_File.Table (Xold).Source_First;
+ Factor.Hi := Source_File.Table (Xold).Source_Last;
Source_File.Append (Source_File.Table (Xold));
Xnew := Source_File.Last;
@@ -145,14 +149,15 @@ package body Sinput.L is
Inst_Spec : Node_Id;
begin
- Snew.Inlined_Body := Inlined_Body;
- Snew.Template := Xold;
+ Snew.Inlined_Body := Inlined_Body;
+ Snew.Inherited_Pragma := Inherited_Pragma;
+ Snew.Template := Xold;
- -- For a genuine generic instantiation, assign new instance id.
- -- For inlined bodies, we retain that of the template, but we
- -- save the call location.
+ -- For a genuine generic instantiation, assign new instance id. For
+ -- inlined bodies or inherited pragmas, we retain that of the
+ -- template, but we save the call location.
- if Inlined_Body then
+ if Inlined_Body or Inherited_Pragma then
Snew.Inlined_Call := Sloc (Inst_Node);
else
@@ -207,22 +212,22 @@ package body Sinput.L is
end if;
end if;
- -- Now we need to compute the new values of Source_First and
- -- Source_Last and adjust the source file pointer to have the
- -- correct virtual origin for the new range of values.
+ -- Now compute the new values of Source_First and Source_Last and
+ -- adjust the source file pointer to have the correct virtual origin
+ -- for the new range of values.
- -- Source_First must be greater than the last Source_Last value
- -- and also must be a multiple of Source_Align
+ -- Source_First must be greater than the last Source_Last value and
+ -- also must be a multiple of Source_Align.
Snew.Source_First :=
((Source_File.Table (Xnew - 1).Source_Last + Source_Align) /
Source_Align) * Source_Align;
- A.Adjust := Snew.Source_First - A.Lo;
- Snew.Source_Last := A.Hi + A.Adjust;
+ Factor.Adjust := Snew.Source_First - Factor.Lo;
+ Snew.Source_Last := Factor.Hi + Factor.Adjust;
Set_Source_File_Index_Table (Xnew);
- Snew.Sloc_Adjust := Sold.Sloc_Adjust - A.Adjust;
+ Snew.Sloc_Adjust := Sold.Sloc_Adjust - Factor.Adjust;
if Debug_Flag_L then
Write_Eol;
@@ -256,7 +261,6 @@ package body Sinput.L is
Write_Str ("body of package ");
else pragma Assert (Ekind (Template_Id) = E_Subprogram_Body);
-
if Nkind (Dnod) = N_Procedure_Specification then
Write_Str ("body of procedure ");
else
@@ -280,11 +284,11 @@ package body Sinput.L is
Write_Eol;
Write_Str (" old lo = ");
- Write_Int (Int (A.Lo));
+ Write_Int (Int (Factor.Lo));
Write_Eol;
Write_Str (" old hi = ");
- Write_Int (Int (A.Hi));
+ Write_Int (Int (Factor.Hi));
Write_Eol;
Write_Str (" new lo = ");
@@ -296,7 +300,7 @@ package body Sinput.L is
Write_Eol;
Write_Str (" adjustment factor = ");
- Write_Int (Int (A.Adjust));
+ Write_Int (Int (Factor.Adjust));
Write_Eol;
Write_Str (" instantiation location: ");
@@ -326,7 +330,7 @@ package body Sinput.L is
begin
Snew.Source_Text :=
To_Source_Buffer_Ptr
- (Sold.Source_Text (-A.Adjust)'Address);
+ (Sold.Source_Text (-Factor.Adjust)'Address);
end;
end;
end Create_Instantiation_Source;
@@ -509,6 +513,7 @@ package body Sinput.L is
Identifier_Casing => Unknown,
Inlined_Call => No_Location,
Inlined_Body => False,
+ Inherited_Pragma => False,
Keyword_Casing => Unknown,
Last_Source_Line => 1,
License => Unknown,
@@ -812,8 +817,10 @@ package body Sinput.L is
-- PRAGMA, WITH, USE (which can appear before a body)
- when Tok_Pragma | Tok_With | Tok_Use =>
-
+ when Tok_Pragma
+ | Tok_Use
+ | Tok_With
+ =>
-- We just want to skip any of these, do it by skipping to a
-- semicolon, but check for EOF, in case we have bad syntax.
@@ -839,7 +846,9 @@ package body Sinput.L is
-- FUNCTION or PROCEDURE
- when Tok_Procedure | Tok_Function =>
+ when Tok_Function
+ | Tok_Procedure
+ =>
Pcount := 0;
-- Loop through tokens following PROCEDURE or FUNCTION
@@ -865,7 +874,10 @@ package body Sinput.L is
-- BEGIN or IS or END definitely means body is present
- when Tok_Begin | Tok_Is | Tok_End =>
+ when Tok_Begin
+ | Tok_End
+ | Tok_Is
+ =>
return True;
-- Semicolon means no body present if at outside any
diff --git a/gcc/ada/sinput-l.ads b/gcc/ada/sinput-l.ads
index c1ac9c512f..f3af4c90b5 100644
--- a/gcc/ada/sinput-l.ads
+++ b/gcc/ada/sinput-l.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -79,29 +79,34 @@ package Sinput.L is
-------------------------------------------------
type Sloc_Adjustment is private;
- -- Type returned by Create_Instantiation_Source for use in subsequent
- -- calls to Adjust_Instantiation_Sloc.
+ -- Type returned by Create_Instantiation_Source for use in subsequent calls
+ -- to Adjust_Instantiation_Sloc.
+
+ procedure Adjust_Instantiation_Sloc
+ (N : Node_Id;
+ Factor : Sloc_Adjustment);
+ -- The instantiation tree is created by copying the tree of the generic
+ -- template (including the original Sloc values), and then applying
+ -- Adjust_Instantiation_Sloc to each copied node to adjust the Sloc to
+ -- reference the source entry for the instantiation.
procedure Create_Instantiation_Source
- (Inst_Node : Entity_Id;
- Template_Id : Entity_Id;
- Inlined_Body : Boolean;
- A : out Sloc_Adjustment);
+ (Inst_Node : Entity_Id;
+ Template_Id : Entity_Id;
+ Factor : out Sloc_Adjustment;
+ Inlined_Body : Boolean := False;
+ Inherited_Pragma : Boolean := False);
-- This procedure creates the source table entry for an instantiation.
-- Inst_Node is the instantiation node, and Template_Id is the defining
-- identifier of the generic declaration or body unit as appropriate.
- -- A is set to an adjustment factor to be used in subsequent calls to
- -- Adjust_Instantiation_Sloc. The instantiation mechanism is also used
- -- for inlined function and procedure calls. The parameter Inlined_Body
- -- is set to True in such cases, and False for a generic instantiation.
- -- This is used for generating error messages that distinguish these
- -- two cases, otherwise the two cases are handled identically.
-
- procedure Adjust_Instantiation_Sloc (N : Node_Id; A : Sloc_Adjustment);
- -- The instantiation tree is created by copying the tree of the generic
- -- template (including the original Sloc values), and then applying
- -- Adjust_Instantiation_Sloc to each copied node to adjust the Sloc
- -- to reference the source entry for the instantiation.
+ -- Factor is set to an adjustment factor to be used in subsequent calls to
+ -- Adjust_Instantiation_Sloc. The instantiation mechanism is also used for
+ -- inlined function and procedure calls. The parameter Inlined_Body is set
+ -- to True in such cases. This is used for generating error messages that
+ -- distinguish these two cases, otherwise the two cases are handled
+ -- identically. Similarly, the instantiation mechanism is also used for
+ -- inherited class-wide pre- and postconditions. Parameter Inherited_Pragma
+ -- is set to True in such cases.
private
@@ -119,7 +124,7 @@ private
-- be applied, used to ensure that no incorrect adjustments are
-- made. Really it is a bug if anyone ever tries to adjust outside
-- this range, but since we are only doing this anyway for getting
- -- better error messages, it is not critical
+ -- better error messages, it is not critical.
end record;
diff --git a/gcc/ada/sinput.adb b/gcc/ada/sinput.adb
index 1c8232d1c8..4b4775734b 100644
--- a/gcc/ada/sinput.adb
+++ b/gcc/ada/sinput.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -221,33 +221,31 @@ package body Sinput is
-- Build_Location_String --
---------------------------
- procedure Build_Location_String (Loc : Source_Ptr) is
- Ptr : Source_Ptr;
+ procedure Build_Location_String
+ (Buf : in out Bounded_String;
+ Loc : Source_Ptr)
+ is
+ Ptr : Source_Ptr := Loc;
begin
-- Loop through instantiations
- Ptr := Loc;
loop
- Get_Name_String_And_Append
- (Reference_Name (Get_Source_File_Index (Ptr)));
- Add_Char_To_Name_Buffer (':');
- Add_Nat_To_Name_Buffer (Nat (Get_Logical_Line_Number (Ptr)));
+ Append (Buf, Reference_Name (Get_Source_File_Index (Ptr)));
+ Append (Buf, ':');
+ Append (Buf, Nat (Get_Logical_Line_Number (Ptr)));
Ptr := Instantiation_Location (Ptr);
exit when Ptr = No_Location;
- Add_Str_To_Name_Buffer (" instantiated at ");
+ Append (Buf, " instantiated at ");
end loop;
-
- Name_Buffer (Name_Len + 1) := NUL;
- return;
end Build_Location_String;
function Build_Location_String (Loc : Source_Ptr) return String is
+ Buf : Bounded_String;
begin
- Name_Len := 0;
- Build_Location_String (Loc);
- return Name_Buffer (1 .. Name_Len);
+ Build_Location_String (Buf, Loc);
+ return +Buf;
end Build_Location_String;
-------------------
@@ -282,13 +280,17 @@ package body Sinput is
Wide_Character_Encoding_Method := WCEM_UTF8;
Upper_Half_Encoding := True;
- when UTF16_LE | UTF16_BE =>
+ when UTF16_BE
+ | UTF16_LE
+ =>
Set_Standard_Error;
Write_Line ("UTF-16 encoding format not recognized");
Set_Standard_Output;
raise Unrecoverable_Error;
- when UTF32_LE | UTF32_BE =>
+ when UTF32_BE
+ | UTF32_LE
+ =>
Set_Standard_Error;
Write_Line ("UTF-32 encoding format not recognized");
Set_Standard_Output;
@@ -302,6 +304,17 @@ package body Sinput is
end case;
end Check_For_BOM;
+ ---------------------------------
+ -- Comes_From_Inherited_Pragma --
+ ---------------------------------
+
+ function Comes_From_Inherited_Pragma (S : Source_Ptr) return Boolean is
+ SIE : Source_File_Record renames
+ Source_File.Table (Get_Source_File_Index (S));
+ begin
+ return SIE.Inherited_Pragma;
+ end Comes_From_Inherited_Pragma;
+
-----------------------------
-- Comes_From_Inlined_Body --
-----------------------------
@@ -484,7 +497,7 @@ package body Sinput is
function Instantiation (S : SFI) return Source_Ptr is
SIE : Source_File_Record renames Source_File.Table (S);
begin
- if SIE.Inlined_Body then
+ if SIE.Inlined_Body or SIE.Inherited_Pragma then
return SIE.Inlined_Call;
else
return Instances.Table (SIE.Instance);
@@ -1192,6 +1205,11 @@ package body Sinput is
return Source_File.Table (S).Identifier_Casing;
end Identifier_Casing;
+ function Inherited_Pragma (S : SFI) return Boolean is
+ begin
+ return Source_File.Table (S).Inherited_Pragma;
+ end Inherited_Pragma;
+
function Inlined_Body (S : SFI) return Boolean is
begin
return Source_File.Table (S).Inlined_Body;
diff --git a/gcc/ada/sinput.ads b/gcc/ada/sinput.ads
index f1a27245af..8165a8f6de 100644
--- a/gcc/ada/sinput.ads
+++ b/gcc/ada/sinput.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -157,7 +157,7 @@ package Sinput is
-- separate main units.
-- The entries in the table are accessed using a Source_File_Index that
- -- ranges from 1 to Last_Source_File. Each entry has the following fields
+ -- ranges from 1 to Last_Source_File. Each entry has the following fields.
-- Note: fields marked read-only are set by Sinput or one of its child
-- packages when a source file table entry is created, and cannot be
@@ -260,14 +260,18 @@ package Sinput is
-- Inlined_Call : Source_Ptr;
-- Source file location of the subprogram call if this source file entry
- -- represents an inlined body. Set to No_Location otherwise.
- -- This field is read-only for clients.
+ -- represents an inlined body or an inherited pragma. Set to No_Location
+ -- otherwise. This field is read-only for clients.
-- Inlined_Body : Boolean;
-- This can only be set True if Instantiation has a value other than
-- No_Location. If true it indicates that the instantiation is actually
-- an instance of an inlined body.
- -- ??? Redundant, always equal to (Inlined_Call /= No_Location)
+
+ -- Inherited_Pragma : Boolean;
+ -- This can only be set True if Instantiation has a value other than
+ -- No_Location. If true it indicates that the instantiation is actually
+ -- an inherited class-wide pre- or postcondition.
-- Template : Source_File_Index; (read-only)
-- Source file index of the source file containing the template if this
@@ -298,6 +302,7 @@ package Sinput is
function Full_Ref_Name (S : SFI) return File_Name_Type;
function Identifier_Casing (S : SFI) return Casing_Type;
function Inlined_Body (S : SFI) return Boolean;
+ function Inherited_Pragma (S : SFI) return Boolean;
function Inlined_Call (S : SFI) return Source_Ptr;
function Instance (S : SFI) return Instance_Id;
function Keyword_Casing (S : SFI) return Casing_Type;
@@ -387,7 +392,7 @@ package Sinput is
-- As described in Sem_Ch12, a generic instantiation involves making a
-- copy of the tree of the generic template. The source locations in
- -- this tree directly reference the source of the template. However it
+ -- this tree directly reference the source of the template. However, it
-- is also possible to find the location of the instantiation.
-- This is achieved as follows. When an instantiation occurs, a new entry
@@ -420,9 +425,11 @@ package Sinput is
function Instantiation (S : SFI) return Source_Ptr;
-- For a source file entry that represents an inlined body, source location
- -- of the inlined call. Otherwise, for a source file entry that represents
- -- a generic instantiation, source location of the instantiation. Returns
- -- No_Location in all other cases.
+ -- of the inlined call. For a source file entry that represents an
+ -- inherited pragma, source location of the declaration to which the
+ -- overriding subprogram for the inherited pragma is attached. Otherwise,
+ -- for a source file entry that represents a generic instantiation, source
+ -- location of the instantiation. Returns No_Location in all other cases.
-----------------
-- Global Data --
@@ -536,18 +543,17 @@ package Sinput is
-- The caller has checked that a Line_Terminator character precedes P so
-- that there definitely is a previous line in the source buffer.
- procedure Build_Location_String (Loc : Source_Ptr);
+ procedure Build_Location_String
+ (Buf : in out Bounded_String;
+ Loc : Source_Ptr);
-- This function builds a string literal of the form "name:line", where
-- name is the file name corresponding to Loc, and line is the line number.
- -- In the event that instantiations are involved, additional suffixes of
- -- the same form are appended after the separating string " instantiated at
- -- ". The returned string is appended to the Name_Buffer, terminated by
- -- ASCII.NUL, with Name_Length indicating the length not including the
- -- terminating Nul.
+ -- If instantiations are involved, additional suffixes of the same form are
+ -- appended after the separating string " instantiated at ". The returned
+ -- string is appended to Buf.
function Build_Location_String (Loc : Source_Ptr) return String;
- -- Functional form returning a string, which does not include a terminating
- -- null character. The contents of Name_Buffer is destroyed.
+ -- Functional form returning a String
procedure Check_For_BOM;
-- Check if the current source starts with a BOM. Scan_Ptr needs to be at
@@ -645,6 +651,13 @@ package Sinput is
-- from instantiation of generics, since Instantiation_Location returns a
-- valid location in both cases.
+ function Comes_From_Inherited_Pragma (S : Source_Ptr) return Boolean;
+ pragma Inline (Comes_From_Inherited_Pragma);
+ -- Given a source pointer S, returns whether it comes from an inherited
+ -- pragma. This allows distinguishing these source pointers from those
+ -- that come from instantiation of generics, since Instantiation_Location
+ -- returns a valid location in both cases.
+
function Top_Level_Location (S : Source_Ptr) return Source_Ptr;
-- Given a source pointer S, returns the argument unchanged if it is
-- not in an instantiation. If S is in an instantiation, then it returns
@@ -760,6 +773,7 @@ private
pragma Inline (Identifier_Casing);
pragma Inline (Inlined_Call);
pragma Inline (Inlined_Body);
+ pragma Inline (Inherited_Pragma);
pragma Inline (Template);
pragma Inline (Unit);
@@ -825,6 +839,7 @@ private
File_Type : Type_Of_File;
Inlined_Call : Source_Ptr;
Inlined_Body : Boolean;
+ Inherited_Pragma : Boolean;
License : License_Type;
Keyword_Casing : Casing_Type;
Identifier_Casing : Casing_Type;
@@ -882,7 +897,8 @@ private
Time_Stamp at 60 range 0 .. 8 * Time_Stamp_Length - 1;
File_Type at 74 range 0 .. 7;
Inlined_Call at 88 range 0 .. 31;
- Inlined_Body at 75 range 0 .. 7;
+ Inlined_Body at 75 range 0 .. 0;
+ Inherited_Pragma at 75 range 1 .. 1;
License at 76 range 0 .. 7;
Keyword_Casing at 77 range 0 .. 7;
Identifier_Casing at 78 range 0 .. 15;
diff --git a/gcc/ada/snames.adb-tmpl b/gcc/ada/snames.adb-tmpl
index 3de2b82cc6..886a13c7d1 100644
--- a/gcc/ada/snames.adb-tmpl
+++ b/gcc/ada/snames.adb-tmpl
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -134,6 +134,8 @@ package body Snames is
return Attribute_Dispatching_Domain;
elsif N = Name_Interrupt_Priority then
return Attribute_Interrupt_Priority;
+ elsif N = Name_Secondary_Stack_Size then
+ return Attribute_Secondary_Stack_Size;
else
return Attribute_Id'Val (N - First_Attribute_Name);
end if;
@@ -229,6 +231,8 @@ package body Snames is
return Pragma_Lock_Free;
when Name_Priority =>
return Pragma_Priority;
+ when Name_Secondary_Stack_Size =>
+ return Pragma_Secondary_Stack_Size;
when Name_Storage_Size =>
return Pragma_Storage_Size;
when Name_Storage_Unit =>
@@ -331,7 +335,7 @@ package body Snames is
function Is_Configuration_Pragma_Name (N : Name_Id) return Boolean is
begin
- return N in First_Pragma_Name .. Last_Configuration_Pragma_Name
+ return N in Configuration_Pragma_Names
or else N = Name_Default_Scalar_Storage_Order
or else N = Name_Fast_Math;
end Is_Configuration_Pragma_Name;
@@ -455,8 +459,8 @@ package body Snames is
or else N = Name_Interface
or else N = Name_Interrupt_Priority
or else N = Name_Lock_Free
- or else N = Name_Relative_Deadline
or else N = Name_Priority
+ or else N = Name_Secondary_Stack_Size
or else N = Name_Storage_Size
or else N = Name_Storage_Unit;
end Is_Pragma_Name;
diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
index 10878063b7..5941beb331 100644
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -175,6 +175,7 @@ package Snames is
Name_uRelative_Deadline : constant Name_Id := N + $;
Name_uResult : constant Name_Id := N + $;
Name_uSecondary_Stack : constant Name_Id := N + $;
+ Name_uSecondary_Stack_Size : constant Name_Id := N + $;
Name_uService : constant Name_Id := N + $;
Name_uSize : constant Name_Id := N + $;
Name_uStack : constant Name_Id := N + $;
@@ -450,6 +451,7 @@ package Snames is
Name_Queuing_Policy : constant Name_Id := N + $;
Name_Rational : constant Name_Id := N + $; -- GNAT
Name_Ravenscar : constant Name_Id := N + $; -- GNAT
+ Name_Rename_Pragma : constant Name_Id := N + $; -- GNAT
Name_Restricted_Run_Time : constant Name_Id := N + $; -- GNAT
Name_Restrictions : constant Name_Id := N + $;
Name_Restriction_Warnings : constant Name_Id := N + $; -- GNAT
@@ -575,6 +577,7 @@ package Snames is
Name_Machine_Attribute : constant Name_Id := N + $; -- GNAT
Name_Main : constant Name_Id := N + $; -- GNAT
Name_Main_Storage : constant Name_Id := N + $; -- GNAT
+ Name_Max_Queue_Length : constant Name_Id := N + $; -- GNAT
Name_Memory_Size : constant Name_Id := N + $; -- Ada 83
Name_No_Body : constant Name_Id := N + $; -- GNAT
Name_No_Elaboration_Code_All : constant Name_Id := N + $; -- GNAT
@@ -653,6 +656,7 @@ package Snames is
Name_Unreferenced : constant Name_Id := N + $; -- GNAT
Name_Unreferenced_Objects : constant Name_Id := N + $; -- GNAT
Name_Unreserve_All_Interrupts : constant Name_Id := N + $; -- GNAT
+ Name_Unused : constant Name_Id := N + $; -- GNAT
Name_Volatile : constant Name_Id := N + $;
Name_Volatile_Components : constant Name_Id := N + $;
Name_Volatile_Full_Access : constant Name_Id := N + $; -- GNAT
@@ -763,6 +767,7 @@ package Snames is
Name_Modified_GPL : constant Name_Id := N + $;
Name_Name : constant Name_Id := N + $;
Name_NCA : constant Name_Id := N + $;
+ Name_New_Name : constant Name_Id := N + $;
Name_No : constant Name_Id := N + $;
Name_No_Access_Parameter_Allocators : constant Name_Id := N + $;
Name_No_Coextensions : constant Name_Id := N + $;
@@ -792,6 +797,7 @@ package Snames is
Name_Proof_In : constant Name_Id := N + $;
Name_Reason : constant Name_Id := N + $;
Name_Reference : constant Name_Id := N + $;
+ Name_Renamed : constant Name_Id := N + $;
Name_Requires : constant Name_Id := N + $;
Name_Restricted : constant Name_Id := N + $;
Name_Result_Mechanism : constant Name_Id := N + $;
@@ -799,7 +805,6 @@ package Snames is
Name_Robustness : constant Name_Id := N + $;
Name_Runtime : constant Name_Id := N + $;
Name_SB : constant Name_Id := N + $;
- Name_Secondary_Stack_Size : constant Name_Id := N + $;
Name_Section : constant Name_Id := N + $;
Name_Semaphore : constant Name_Id := N + $;
Name_Simple_Barriers : constant Name_Id := N + $;
@@ -813,6 +818,7 @@ package Snames is
Name_Strict : constant Name_Id := N + $;
Name_Subunit_File_Name : constant Name_Id := N + $;
Name_Suppressed : constant Name_Id := N + $;
+ Name_Suppressible : constant Name_Id := N + $;
Name_Synchronous : constant Name_Id := N + $;
Name_Task_Stack_Size_Default : constant Name_Id := N + $;
Name_Task_Type : constant Name_Id := N + $;
@@ -883,6 +889,7 @@ package Snames is
Name_Exponent : constant Name_Id := N + $;
Name_External_Tag : constant Name_Id := N + $;
Name_Fast_Math : constant Name_Id := N + $; -- GNAT
+ Name_Finalization_Size : constant Name_Id := N + $; -- GNAT
Name_First : constant Name_Id := N + $;
Name_First_Bit : constant Name_Id := N + $;
Name_First_Valid : constant Name_Id := N + $; -- Ada 12
@@ -1046,8 +1053,9 @@ package Snames is
-- Names of internal attributes. They are not real attributes but special
-- names used internally by GNAT in order to deal with delayed aspects
- -- (Aspect_CPU, Aspect_Dispatching_Domain, Aspect_Interrupt_Priority) that
- -- don't have corresponding pragmas or user-referencable attributes.
+ -- (Aspect_CPU, Aspect_Dispatching_Domain, Aspect_Interrupt_Priority,
+ -- Aspect_Secondary_Stack_Size) that don't have corresponding pragmas or
+ -- user-referenceable attributes.
-- It is convenient to have these internal attributes available for
-- processing the aspects, since the normal approach is to convert an
@@ -1063,6 +1071,7 @@ package Snames is
Name_CPU : constant Name_Id := N + $;
Name_Dispatching_Domain : constant Name_Id := N + $;
Name_Interrupt_Priority : constant Name_Id := N + $;
+ Name_Secondary_Stack_Size : constant Name_Id := N + $; -- GNAT
Last_Internal_Attribute_Name : constant Name_Id := N + $;
-- Names of recognized locking policy identifiers
@@ -1204,6 +1213,7 @@ package Snames is
-- convention name. So is To_Address, which is a GNAT attribute.
First_Intrinsic_Name : constant Name_Id := N + $;
+ Name_Compilation_ISO_Date : constant Name_Id := N + $;
Name_Compilation_Date : constant Name_Id := N + $;
Name_Compilation_Time : constant Name_Id := N + $;
Name_Divide : constant Name_Id := N + $;
@@ -1521,6 +1531,7 @@ package Snames is
Attribute_Exponent,
Attribute_External_Tag,
Attribute_Fast_Math,
+ Attribute_Finalization_Size,
Attribute_First,
Attribute_First_Bit,
Attribute_First_Valid,
@@ -1674,13 +1685,14 @@ package Snames is
Attribute_CPU,
Attribute_Dispatching_Domain,
- Attribute_Interrupt_Priority);
+ Attribute_Interrupt_Priority,
+ Attribute_Secondary_Stack_Size);
- subtype Internal_Attribute_Id is Attribute_Id range
- Attribute_CPU .. Attribute_Interrupt_Priority;
+ subtype Internal_Attribute_Id is Attribute_Id range
+ Attribute_CPU .. Attribute_Secondary_Stack_Size;
- type Attribute_Class_Array is array (Attribute_Id) of Boolean;
- -- Type used to build attribute classification flag arrays
+ type Attribute_Class_Array is array (Attribute_Id) of Boolean;
+ -- Type used to build attribute classification flag arrays
------------------------------------
-- Convention Name ID Definitions --
@@ -1803,6 +1815,7 @@ package Snames is
Pragma_Queuing_Policy,
Pragma_Rational,
Pragma_Ravenscar,
+ Pragma_Rename_Pragma,
Pragma_Restricted_Run_Time,
Pragma_Restrictions,
Pragma_Restriction_Warnings,
@@ -1902,6 +1915,7 @@ package Snames is
Pragma_Machine_Attribute,
Pragma_Main,
Pragma_Main_Storage,
+ Pragma_Max_Queue_Length,
Pragma_Memory_Size,
Pragma_No_Body,
Pragma_No_Elaboration_Code_All,
@@ -1964,6 +1978,7 @@ package Snames is
Pragma_Unreferenced,
Pragma_Unreferenced_Objects,
Pragma_Unreserve_All_Interrupts,
+ Pragma_Unused,
Pragma_Volatile,
Pragma_Volatile_Components,
Pragma_Volatile_Full_Access,
@@ -1982,6 +1997,7 @@ package Snames is
Pragma_Interrupt_Priority,
Pragma_Lock_Free,
Pragma_Priority,
+ Pragma_Secondary_Stack_Size,
Pragma_Storage_Size,
Pragma_Storage_Unit,
@@ -2024,7 +2040,8 @@ package Snames is
function Is_Internal_Attribute_Name (N : Name_Id) return Boolean;
-- Test to see if the name N is the name of an INT attribute (Name_CPU,
- -- Name_Dispatching_Domain, Name_Interrupt_Priority).
+ -- Name_Dispatching_Domain, Name_Interrupt_Priority,
+ -- Name_Secondary_Stack_Size).
function Is_Procedure_Attribute_Name (N : Name_Id) return Boolean;
-- Test to see if the name N is the name of a recognized attribute that
diff --git a/gcc/ada/socket.c b/gcc/ada/socket.c
index f5fb6635ee..5cdd656e34 100644
--- a/gcc/ada/socket.c
+++ b/gcc/ada/socket.c
@@ -202,7 +202,7 @@ __gnat_gethostbyaddr (const char *addr, int len, int type,
struct hostent *rh;
int ri;
-#if defined(__linux__) || defined(__GLIBC__)
+#if defined(__linux__) || defined(__GLIBC__) || defined(__rtems__)
(void) gethostbyaddr_r (addr, len, type, ret, buf, buflen, &rh, h_errnop);
#else
rh = gethostbyaddr_r (addr, len, type, ret, buf, buflen, h_errnop);
diff --git a/gcc/ada/spark_xrefs.adb b/gcc/ada/spark_xrefs.adb
index 8049c7ee53..8fab555ac2 100644
--- a/gcc/ada/spark_xrefs.adb
+++ b/gcc/ada/spark_xrefs.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2011-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -160,7 +160,10 @@ package body SPARK_Xrefs is
procedure pspark is
procedure Write_Info_Char (C : Character) renames Write_Char;
- -- Write one character;
+ -- Write one character
+
+ procedure Write_Info_Str (Val : String) renames Write_Str;
+ -- Write string
function Write_Info_Col return Positive;
-- Return next column for writing
diff --git a/gcc/ada/spark_xrefs.ads b/gcc/ada/spark_xrefs.ads
index f6cc7c3de9..52c0ef6947 100644
--- a/gcc/ada/spark_xrefs.ads
+++ b/gcc/ada/spark_xrefs.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 2011-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2011-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -25,9 +25,9 @@
-- This package defines tables used to store information needed for the SPARK
-- mode. It is used by procedures in Lib.Xref.SPARK_Specific to build the
--- SPARK specific cross-references information before writing it out to the
--- ALI file, and by Get_SPARK_Xrefs/Put_SPARK_Xrefs to read and write the text
--- form that is used in the ALI file.
+-- SPARK-specific cross-reference information before writing it to the ALI
+-- file, and by Get_SPARK_Xrefs/Put_SPARK_Xrefs to read/write the textual
+-- representation that is stored in the ALI file.
with Types; use Types;
with GNAT.Table;
@@ -36,7 +36,7 @@ package SPARK_Xrefs is
-- SPARK cross-reference information can exist in one of two forms. In
-- the ALI file, it is represented using a text format that is described
- -- in this specification. Internally it is stored using three tables
+ -- in this specification. Internally it is stored using three tables:
-- SPARK_Xref_Table, SPARK_Scope_Table and SPARK_File_Table, which are
-- also defined in this unit.
@@ -56,21 +56,21 @@ package SPARK_Xrefs is
-- SPARK cross-reference information is generated on a unit-by-unit basis
-- in the ALI file, using lines that start with the identifying character F
- -- ("Formal"). These lines are generated if Frame_Condition_Mode is True.
+ -- ("Formal"). These lines are generated if GNATprove_Mode is True.
-- The SPARK cross-reference information comes after the shared
- -- cross-reference information, so it needs not be read by tools like
- -- gnatbind, gnatmake etc.
+ -- cross-reference information, so it can be ignored by tools like
+ -- gnatbind, gnatmake, etc.
-- -------------------
-- -- Scope Section --
-- -------------------
-- A first section defines the scopes in which entities are defined and
- -- referenced. A scope is a package/subprogram declaration/body. Note that
- -- a package declaration and body define two different scopes. Similarly, a
- -- subprogram declaration and body, when both present, define two different
- -- scopes.
+ -- referenced. A scope is a package/subprogram/protected_type/task_type
+ -- declaration/body. Note that a package declaration and body define two
+ -- different scopes. Similarly, a subprogram, protected type and task type
+ -- declaration and body, when both present, define two different scopes.
-- FD dependency-number filename (-> unit-filename)?
@@ -128,15 +128,19 @@ package SPARK_Xrefs is
-- -- Xref Section --
-- ------------------
- -- A second section defines cross-references useful for computing the set
- -- of global variables read/written in each subprogram/package.
+ -- A second section defines cross-references useful for computing global
+ -- variables read/written in each subprogram/package/protected_type/
+ -- task_type.
-- FX dependency-number filename . entity-number entity
- -- dependency-number and filename identity a file in FD lines
+ -- dependency-number and filename identify a file in FD lines
- -- entity-number and identity identify a scope entity in FS lines for
- -- the file previously identified.
+ -- entity-number and entity identify a scope in FS lines
+ -- for the previously identified file.
+
+ -- (filename and entity are just a textual representations of
+ -- dependency-number and entity-number)
-- F line typ col entity ref*
@@ -192,16 +196,15 @@ package SPARK_Xrefs is
-- -- Generated Globals Section --
-- -------------------------------
- -- The Generated Globals section is located at the end of the ALI file.
+ -- The Generated Globals section is located at the end of the ALI file
- -- All lines introducing information related to the Generated Globals
- -- have the string "GG" appearing in the beginning. This string ("GG")
- -- should therefore not be used in the beginning of any line that does
- -- not relate to Generated Globals.
+ -- All lines with information related to the Generated Globals begin with
+ -- string "GG". This string should therefore not be used in the beginning
+ -- of any line not related to Generated Globals.
- -- The processing (reading and writing) of this section happens in
- -- package Flow_Computed_Globals (from the SPARK 2014 sources), for
- -- further information please refer there.
+ -- The processing (reading and writing) of this section happens in package
+ -- Flow_Generated_Globals (from the SPARK 2014 sources), for further
+ -- information please refer there.
----------------
-- Xref Table --
@@ -209,9 +212,10 @@ package SPARK_Xrefs is
-- The following table records SPARK cross-references
- type Xref_Index is new Int;
+ type Xref_Index is new Nat;
-- Used to index values in this table. Values start at 1 and are assigned
- -- sequentially as entries are constructed.
+ -- sequentially as entries are constructed; value 0 is used temporarily
+ -- until a proper value is determined.
type SPARK_Xref_Record is record
Entity_Name : String_Ptr;
@@ -231,20 +235,20 @@ package SPARK_Xrefs is
-- Column number for the entity referenced
File_Num : Nat;
- -- Set to the file dependency number for the cross-reference. Note
- -- that if no file entry is present explicitly, this is just a copy
- -- of the reference for the current cross-reference section.
+ -- File dependency number for the cross-reference. Note that if no file
+ -- entry is present explicitly, this is just a copy of the reference for
+ -- the current cross-reference section.
Scope_Num : Nat;
- -- Set to the scope number for the cross-reference. Note that if no
- -- scope entry is present explicitly, this is just a copy of the
- -- reference for the current cross-reference section.
+ -- Scope number for the cross-reference. Note that if no scope entry is
+ -- present explicitly, this is just a copy of the reference for the
+ -- current cross-reference section.
Line : Nat;
-- Line number for the reference
Rtype : Character;
- -- Indicates type of reference, using code used in ALI file:
+ -- Indicates type of the reference, using code used in ALI file:
-- r = reference
-- c = reference to constant object
-- m = modification
@@ -268,9 +272,11 @@ package SPARK_Xrefs is
-- This table keeps track of the scopes and the corresponding starting and
-- ending indexes (From, To) in the Xref table.
- type Scope_Index is new Int;
+ type Scope_Index is new Nat;
-- Used to index values in this table. Values start at 1 and are assigned
- -- sequentially as entries are constructed.
+ -- sequentially as entries are constructed; value 0 indicates that no
+ -- entries have been constructed and is also used until a proper value is
+ -- determined.
type SPARK_Scope_Record is record
Scope_Name : String_Ptr;
@@ -279,7 +285,7 @@ package SPARK_Xrefs is
File_Num : Nat;
-- Set to the file dependency number for the scope
- Scope_Num : Nat;
+ Scope_Num : Pos;
-- Set to the scope number for the scope
Spec_File_Num : Nat;
@@ -296,8 +302,10 @@ package SPARK_Xrefs is
Stype : Character;
-- Indicates type of scope, using code used in ALI file:
-- K = package
- -- V = function
+ -- T = task
-- U = procedure
+ -- V = function
+ -- Y = entry
Col : Nat;
-- Column number for the scope
@@ -329,9 +337,10 @@ package SPARK_Xrefs is
-- This table keeps track of the units and the corresponding starting and
-- ending indexes (From, To) in the Scope table.
- type File_Index is new Int;
+ type File_Index is new Nat;
-- Used to index values in this table. Values start at 1 and are assigned
- -- sequentially as entries are constructed.
+ -- sequentially as entries are constructed; value 0 indicates that no
+ -- entries have been constructed.
type SPARK_File_Record is record
File_Name : String_Ptr;
@@ -339,7 +348,7 @@ package SPARK_Xrefs is
Unit_File_Name : String_Ptr;
-- Pointer to file name for unit in ALI file, when File_Name refers to a
- -- subunit. Otherwise null.
+ -- subunit; otherwise null.
File_Num : Nat;
-- Dependency number in ALI file
diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb
index b1def4b722..f10ff039f8 100644
--- a/gcc/ada/sprint.adb
+++ b/gcc/ada/sprint.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -1328,6 +1328,15 @@ package body Sprint is
Sprint_Node (Expression (Node));
end if;
+ when N_Iterated_Component_Association =>
+ Set_Debug_Sloc;
+ Write_Str (" for ");
+ Write_Id (Defining_Identifier (Node));
+ Write_Str (" in ");
+ Sprint_Bar_List (Discrete_Choices (Node));
+ Write_Str (" => ");
+ Sprint_Node (Expression (Node));
+
when N_Component_Clause =>
Write_Indent;
Sprint_Node (Component_Name (Node));
@@ -1766,6 +1775,13 @@ package body Sprint is
Write_Indent_Str (";");
end if;
+ when N_Delta_Aggregate =>
+ Write_Str_With_Col_Check_Sloc ("(");
+ Sprint_Node (Expression (Node));
+ Write_Str_With_Col_Check (" with delta ");
+ Sprint_Comma_List (Component_Associations (Node));
+ Write_Char (')');
+
when N_Extension_Aggregate =>
Write_Str_With_Col_Check_Sloc ("(");
Sprint_Node (Ancestor_Part (Node));
@@ -2385,7 +2401,9 @@ package body Sprint is
end if;
end;
- if Present (Expression (Node)) then
+ if Present (Expression (Node))
+ and then Expression (Node) /= Error
+ then
Write_Str (" := ");
Sprint_Node (Expression (Node));
end if;
@@ -2822,7 +2840,7 @@ package body Sprint is
when N_Pragma =>
Write_Indent_Str_Sloc ("pragma ");
- Write_Name_With_Col_Check (Pragma_Name (Node));
+ Write_Name_With_Col_Check (Pragma_Name_Unmapped (Node));
if Present (Pragma_Argument_Associations (Node)) then
Sprint_Opt_Paren_Comma_List
@@ -3276,6 +3294,9 @@ package body Sprint is
Extra_Blank_Line;
Sprint_Node (Proper_Body (Node));
+ when N_Target_Name =>
+ Write_Char ('@');
+
when N_Task_Body =>
Write_Indent_Str_Sloc ("task body ");
Write_Id (Defining_Identifier (Node));
@@ -3965,7 +3986,9 @@ package body Sprint is
Write_Str (");");
- when E_Signed_Integer_Subtype | E_Enumeration_Subtype =>
+ when E_Enumeration_Subtype
+ | E_Signed_Integer_Subtype
+ =>
Write_Str_With_Col_Check ("subtype ");
Write_Id (E);
Write_Str (" is ");
@@ -3981,7 +4004,6 @@ package body Sprint is
Write_Ekind (E);
Write_Str (">;");
end case;
-
end Write_Implicit_Def;
------------------
@@ -4254,11 +4276,11 @@ package body Sprint is
-- Signed integer types, and modular integer subtypes,
-- and also enumeration subtypes.
- when E_Signed_Integer_Type |
- E_Signed_Integer_Subtype |
- E_Modular_Integer_Subtype |
- E_Enumeration_Subtype =>
-
+ when E_Enumeration_Subtype
+ | E_Modular_Integer_Subtype
+ | E_Signed_Integer_Subtype
+ | E_Signed_Integer_Type
+ =>
Write_Header (Ekind (Typ) = E_Signed_Integer_Type);
if Ekind (Typ) = E_Signed_Integer_Type then
@@ -4318,9 +4340,9 @@ package body Sprint is
-- Floating point types and subtypes
- when E_Floating_Point_Type |
- E_Floating_Point_Subtype =>
-
+ when E_Floating_Point_Subtype
+ | E_Floating_Point_Type
+ =>
Write_Header (Ekind (Typ) = E_Floating_Point_Type);
if Ekind (Typ) = E_Floating_Point_Type then
@@ -4363,7 +4385,9 @@ package body Sprint is
-- Record subtypes
- when E_Record_Subtype | E_Record_Subtype_With_Private =>
+ when E_Record_Subtype
+ | E_Record_Subtype_With_Private
+ =>
Write_Header (False);
Write_Str ("record");
Indent_Begin;
@@ -4386,8 +4410,9 @@ package body Sprint is
-- Class-Wide types
- when E_Class_Wide_Type |
- E_Class_Wide_Subtype =>
+ when E_Class_Wide_Subtype
+ | E_Class_Wide_Type
+ =>
Write_Header (Ekind (Typ) = E_Class_Wide_Type);
Write_Name_With_Col_Check (Chars (Etype (Typ)));
Write_Str ("'Class");
@@ -4456,7 +4481,6 @@ package body Sprint is
when others =>
Write_Header (True);
Write_Str ("???");
-
end case;
end if;
diff --git a/gcc/ada/stringt.adb b/gcc/ada/stringt.adb
index 5a0c89c7d0..175b80c257 100644
--- a/gcc/ada/stringt.adb
+++ b/gcc/ada/stringt.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -30,7 +30,6 @@
------------------------------------------------------------------------------
with Alloc;
-with Namet; use Namet;
with Output; use Output;
with Table;
@@ -81,16 +80,16 @@ package body Stringt is
-------------------------------
procedure Add_String_To_Name_Buffer (S : String_Id) is
- Len : constant Natural := Natural (String_Length (S));
+ begin
+ Append (Global_Name_Buffer, S);
+ end Add_String_To_Name_Buffer;
+ procedure Append (Buf : in out Bounded_String; S : String_Id) is
begin
- for J in 1 .. Len loop
- Name_Buffer (Name_Len + J) :=
- Get_Character (Get_String_Char (S, Int (J)));
+ for X in 1 .. String_Length (S) loop
+ Append (Buf, Get_Character (Get_String_Char (S, X)));
end loop;
-
- Name_Len := Name_Len + Len;
- end Add_String_To_Name_Buffer;
+ end Append;
----------------
-- End_String --
@@ -242,7 +241,7 @@ package body Stringt is
-- String_Chars table all at once.
S_First : constant Int := Strings.Table (S).String_Index;
- S_Len : constant Int := String_Length (S);
+ S_Len : constant Nat := String_Length (S);
Old_Last : constant Int := String_Chars.Last;
New_Last : constant Int := Old_Last + S_Len;
@@ -307,14 +306,12 @@ package body Stringt is
-- String_From_Name_Buffer --
-----------------------------
- function String_From_Name_Buffer return String_Id is
+ function String_From_Name_Buffer
+ (Buf : Bounded_String := Global_Name_Buffer) return String_Id
+ is
begin
Start_String;
-
- for J in 1 .. Name_Len loop
- Store_String_Char (Get_Char_Code (Name_Buffer (J)));
- end loop;
-
+ Store_String_Chars (+Buf);
return End_String;
end String_From_Name_Buffer;
@@ -333,12 +330,8 @@ package body Stringt is
procedure String_To_Name_Buffer (S : String_Id) is
begin
- Name_Len := Natural (String_Length (S));
-
- for J in 1 .. Name_Len loop
- Name_Buffer (J) :=
- Get_Character (Get_String_Char (S, Int (J)));
- end loop;
+ Name_Len := 0;
+ Append (Global_Name_Buffer, S);
end String_To_Name_Buffer;
---------------------
diff --git a/gcc/ada/stringt.ads b/gcc/ada/stringt.ads
index 92b74e2c04..4b7c0e5ad5 100644
--- a/gcc/ada/stringt.ads
+++ b/gcc/ada/stringt.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -29,6 +29,7 @@
-- --
------------------------------------------------------------------------------
+with Namet; use Namet;
with System; use System;
with Types; use Types;
@@ -123,18 +124,20 @@ package Stringt is
-- Error if any characters are out of Character range. Does not attempt
-- to do any encoding of any characters.
+ procedure Append (Buf : in out Bounded_String; S : String_Id);
+ -- Append characters of given string to Buf. Error if any characters are
+ -- out of Character range. Does not attempt to do any encoding of any
+ -- characters.
+
procedure Add_String_To_Name_Buffer (S : String_Id);
- -- Append characters of given string to Name_Buffer, updating Name_Len.
- -- Error if any characters are out of Character range. Does not attempt
- -- to do any encoding of any characters.
+ -- Same as Append (Global_Name_Buffer, S)
function String_Chars_Address return System.Address;
-- Return address of String_Chars table (used by Back_End call to Gigi)
- function String_From_Name_Buffer return String_Id;
- -- Given a name stored in Namet.Name_Buffer (length in Namet.Name_Len),
- -- returns a string of the corresponding value. The value in Name_Buffer
- -- is unchanged, and the cases of letters are unchanged.
+ function String_From_Name_Buffer
+ (Buf : Bounded_String := Global_Name_Buffer) return String_Id;
+ -- Given a name stored in Buf, returns a string of the corresponding value.
function Strings_Address return System.Address;
-- Return address of Strings table (used by Back_End call to Gigi)
diff --git a/gcc/ada/styleg.adb b/gcc/ada/styleg.adb
index a421f25028..58fd3fd3e0 100644
--- a/gcc/ada/styleg.adb
+++ b/gcc/ada/styleg.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -717,7 +717,7 @@ package body Styleg is
-- In check max line length mode (-gnatym), the line length must
-- not exceed the permitted maximum value.
- procedure Check_Line_Max_Length (Len : Int) is
+ procedure Check_Line_Max_Length (Len : Nat) is
begin
if Style_Check_Max_Line_Length then
if Len > Style_Max_Line_Length then
@@ -741,10 +741,10 @@ package body Styleg is
-- In check DOS line terminators node (-gnatyd), the line terminator
-- must be a single LF, without a following CR.
- procedure Check_Line_Terminator (Len : Int) is
+ procedure Check_Line_Terminator (Len : Nat) is
S : Source_Ptr;
- L : Int := Len;
+ L : Nat := Len;
-- Length of line (adjusted down for blanks at end of line)
begin
diff --git a/gcc/ada/styleg.ads b/gcc/ada/styleg.ads
index 344d4fb7d9..141c114357 100644
--- a/gcc/ada/styleg.ads
+++ b/gcc/ada/styleg.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -109,12 +109,12 @@ package Styleg is
procedure Check_Left_Paren;
-- Called after scanning out a left parenthesis to check spacing
- procedure Check_Line_Max_Length (Len : Int);
+ procedure Check_Line_Max_Length (Len : Nat);
-- Called with Scan_Ptr pointing to the first line terminator character
-- terminating the current line. Used to check for appropriate line length.
-- The parameter Len is the length of the current line.
- procedure Check_Line_Terminator (Len : Int);
+ procedure Check_Line_Terminator (Len : Nat);
-- Called with Scan_Ptr pointing to the first line terminator terminating
-- the current line, used to check for appropriate line terminator usage.
-- The parameter Len is the length of the current line.
diff --git a/gcc/ada/stylesw.adb b/gcc/ada/stylesw.adb
index a708da9e5b..ff8155adfc 100644
--- a/gcc/ada/stylesw.adb
+++ b/gcc/ada/stylesw.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -306,7 +306,6 @@ package body Stylesw is
if On then
case C is
-
when '+' =>
null;
@@ -471,7 +470,7 @@ package body Stylesw is
Write_Line ("unrecognized switch -gnaty" & C & " ignored");
else
Err_Col := Err_Col - 1;
- Bad_Style_Switch ("invalid style switch: " & C);
+ Bad_Style_Switch ("invalid style switch");
return;
end if;
end case;
@@ -480,7 +479,6 @@ package body Stylesw is
else
case C is
-
when '+' =>
On := True;
@@ -580,7 +578,7 @@ package body Stylesw is
Write_Line ("unrecognized switch -gnaty-" & C & " ignored");
else
Err_Col := Err_Col - 1;
- Bad_Style_Switch ("invalid style switch: " & C);
+ Bad_Style_Switch ("invalid style switch");
return;
end if;
end case;
diff --git a/gcc/ada/stylesw.ads b/gcc/ada/stylesw.ads
index bb24f278b9..7dc3e60496 100644
--- a/gcc/ada/stylesw.ads
+++ b/gcc/ada/stylesw.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -275,12 +275,12 @@ package Stylesw is
-- not allowed to enclose entire expressions in tests in parentheses
-- (C style), e.g. if (x = y) then ... is not allowed.
- Style_Max_Line_Length : Int := 0;
+ Style_Max_Line_Length : Nat := 0;
-- Value used to check maximum line length. Gets reset as a result of
-- use of -gnatym or -gnatyMnnn switches. This value is only read if
-- Style_Check_Max_Line_Length is True.
- Style_Max_Nesting_Level : Int := 0;
+ Style_Max_Nesting_Level : Nat := 0;
-- Value used to check maximum nesting level. Gets reset as a result
-- of use of the -gnatyLnnn switch. This value is only read if
-- Style_Check_Max_Nesting_Level is True.
diff --git a/gcc/ada/switch-b.adb b/gcc/ada/switch-b.adb
index b26c583ea9..71ee61ad42 100644
--- a/gcc/ada/switch-b.adb
+++ b/gcc/ada/switch-b.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -28,6 +28,7 @@ with Debug; use Debug;
with Osint; use Osint;
with Opt; use Opt;
+with System.OS_Lib; use System.OS_Lib;
with System.WCh_Con; use System.WCh_Con;
package body Switch.B is
@@ -252,6 +253,22 @@ package body Switch.B is
Ptr := Ptr + 1;
end if;
+ -- Processing for f switch
+
+ when 'f' =>
+ if Ptr = Max then
+ Bad_Switch (Switch_Chars);
+ end if;
+
+ Force_Elab_Order_File :=
+ new String'(Switch_Chars (Ptr + 1 .. Max));
+
+ Ptr := Max + 1;
+
+ if not Is_Read_Accessible_File (Force_Elab_Order_File.all) then
+ Osint.Fail (Force_Elab_Order_File.all & ": file not found");
+ end if;
+
-- Processing for F switch
when 'F' =>
diff --git a/gcc/ada/switch-c.adb b/gcc/ada/switch-c.adb
index 4ded20b7f2..176dbe46a8 100644
--- a/gcc/ada/switch-c.adb
+++ b/gcc/ada/switch-c.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -28,6 +28,7 @@
-- circularities, especially for back ends using Adabkend.
with Debug; use Debug;
+with Errout; use Errout;
with Lib; use Lib;
with Osint; use Osint;
with Opt; use Opt;
@@ -531,7 +532,31 @@ package body Switch.C is
when 'C' =>
Ptr := Ptr + 1;
- Generate_CodePeer_Messages := True;
+
+ if not Generate_CodePeer_Messages then
+ Generate_CodePeer_Messages := True;
+ CodePeer_Mode := True;
+ Warning_Mode := Normal;
+ Warning_Doc_Switch := True; -- -gnatw.d
+
+ -- Enable warnings potentially useful for non GNAT
+ -- users.
+
+ Constant_Condition_Warnings := True; -- -gnatwc
+ Warn_On_Assertion_Failure := True; -- -gnatw.a
+ Warn_On_Assumed_Low_Bound := True; -- -gnatww
+ Warn_On_Bad_Fixed_Value := True; -- -gnatwb
+ Warn_On_Biased_Representation := True; -- -gnatw.b
+ Warn_On_Export_Import := True; -- -gnatwx
+ Warn_On_Modified_Unread := True; -- -gnatwm
+ Warn_On_No_Value_Assigned := True; -- -gnatwv
+ Warn_On_Object_Renames_Function := True; -- -gnatw.r
+ Warn_On_Overlap := True; -- -gnatw.i
+ Warn_On_Parameter_Order := True; -- -gnatw.p
+ Warn_On_Questionable_Missing_Parens := True; -- -gnatwq
+ Warn_On_Redundant_Constructs := True; -- -gnatwr
+ Warn_On_Suspicious_Modulus_Value := True; -- -gnatw.m
+ end if;
-- -gnated switch (disable atomic synchronization)
@@ -1400,7 +1425,7 @@ package body Switch.C is
Ptr := Ptr + 1;
- if Switch_Chars (Ptr) /= '3' then
+ if Switch_Chars (Ptr) /= '3' or else Latest_Ada_Only then
Bad_Switch ("-gnat8" & Switch_Chars (Ptr .. Max));
else
Ptr := Ptr + 1;
@@ -1418,7 +1443,7 @@ package body Switch.C is
Ptr := Ptr + 1;
- if Switch_Chars (Ptr) /= '5' then
+ if Switch_Chars (Ptr) /= '5' or else Latest_Ada_Only then
Bad_Switch ("-gnat9" & Switch_Chars (Ptr .. Max));
else
Ptr := Ptr + 1;
@@ -1436,7 +1461,7 @@ package body Switch.C is
Ptr := Ptr + 1;
- if Switch_Chars (Ptr) /= '5' then
+ if Switch_Chars (Ptr) /= '5' or else Latest_Ada_Only then
Bad_Switch ("-gnat0" & Switch_Chars (Ptr .. Max));
else
Ptr := Ptr + 1;
@@ -1469,12 +1494,17 @@ package body Switch.C is
if Ptr > Max - 3 then
Bad_Switch ("-gnat" & Switch_Chars (Ptr .. Max));
- elsif Switch_Chars (Ptr .. Ptr + 3) = "2005" then
+ elsif Switch_Chars (Ptr .. Ptr + 3) = "2005"
+ and then not Latest_Ada_Only
+ then
Ada_Version := Ada_2005;
elsif Switch_Chars (Ptr .. Ptr + 3) = "2012" then
Ada_Version := Ada_2012;
+ elsif Switch_Chars (Ptr .. Ptr + 3) = "2020" then
+ Ada_Version := Ada_2020;
+
else
Bad_Switch ("-gnat" & Switch_Chars (Ptr .. Ptr + 3));
end if;
diff --git a/gcc/ada/switch-m.adb b/gcc/ada/switch-m.adb
index c52ca42478..8795703bac 100644
--- a/gcc/ada/switch-m.adb
+++ b/gcc/ada/switch-m.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -150,7 +150,6 @@ package body Switch.M is
-- Processing for a switch
case Switch_Starts_With_Gnat is
-
when False =>
-- All switches that don't start with -gnat stay as is,
@@ -196,24 +195,6 @@ package body Switch.M is
Add_Switch_Component ("-mrtp");
end if;
- -- Switch for universal addressing on AAMP target
-
- elsif Switch_Chars'Length >= 5
- and then
- Switch_Chars
- (Switch_Chars'First .. Switch_Chars'First + 4) = "-univ"
- then
- Add_Switch_Component (Switch_Chars);
-
- -- Switch for specifying AAMP target library
-
- elsif Switch_Chars'Length > 13
- and then
- Switch_Chars (Switch_Chars'First .. Switch_Chars'First + 12)
- = "-aamp_target="
- then
- Add_Switch_Component (Switch_Chars);
-
-- Special case for -fstack-check (alias for
-- -fstack-check=specific)
@@ -236,15 +217,15 @@ package body Switch.M is
return;
when True =>
-
case C is
-- One-letter switches
- when 'a' | 'A' | 'b' | 'B' | 'c' | 'C' | 'E' | 'f' |
- 'F' | 'g' | 'h' | 'H' | 'I' | 'L' | 'N' | 'p' |
- 'P' | 'q' | 'Q' | 'r' | 's' | 'S' | 't' | 'u' |
- 'U' | 'v' | 'x' | 'X' | 'Z' =>
+ when 'a' | 'A' | 'b' | 'B' | 'c' | 'C' | 'E' | 'f' | 'F'
+ | 'g' | 'h' | 'H' | 'I' | 'L' | 'N' | 'p' | 'P' | 'q'
+ | 'Q' | 'r' | 's' | 'S' | 't' | 'u' | 'U' | 'v' | 'x'
+ | 'X' | 'Z'
+ =>
Storing (First_Stored) := C;
Add_Switch_Component
(Storing (Storing'First .. First_Stored));
@@ -309,7 +290,6 @@ package body Switch.M is
else
case Switch_Chars (Ptr) is
-
when 'A' =>
Ptr := Ptr + 1;
Add_Switch_Component ("-gnateA");
@@ -705,9 +685,7 @@ package body Switch.M is
when others =>
Last := 0;
return;
-
end case;
-
end case;
end loop;
end Normalize_Compiler_Switches;
@@ -811,17 +789,10 @@ package body Switch.M is
Verbose_Mode := True;
case Switch_Chars (Ptr) is
- when 'l' =>
- Verbosity_Level := Opt.Low;
-
- when 'm' =>
- Verbosity_Level := Opt.Medium;
-
- when 'h' =>
- Verbosity_Level := Opt.High;
-
- when others =>
- Success := False;
+ when 'l' => Verbosity_Level := Opt.Low;
+ when 'm' => Verbosity_Level := Opt.Medium;
+ when 'h' => Verbosity_Level := Opt.High;
+ when others => Success := False;
end case;
elsif C = 'd' then
@@ -934,9 +905,7 @@ package body Switch.M is
else
Check_Switch : begin
-
case C is
-
when 'a' =>
Check_Readonly_Files := True;
@@ -1076,7 +1045,6 @@ package body Switch.M is
else
Success := False;
end if;
-
end case;
end Check_Switch;
end if;
diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c
index 465007eb15..679c70a77f 100644
--- a/gcc/ada/sysdep.c
+++ b/gcc/ada/sysdep.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 1992-2015, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2016, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -126,7 +126,7 @@ extern struct tm *localtime_r(const time_t *, struct tm *);
*/
-#if defined (WINNT) || defined (__CYGWIN__)
+#if defined (WINNT) || defined (__CYGWIN__) || defined(__DJGPP__)
const char __gnat_text_translation_required = 1;
@@ -137,6 +137,11 @@ const char __gnat_text_translation_required = 1;
#define WIN_SETMODE _setmode
#endif
+#if defined(__DJGPP__)
+#include <io.h>
+#define _setmode setmode
+#endif /* __DJGPP__ */
+
void
__gnat_set_binary_mode (int handle)
{
@@ -149,6 +154,30 @@ __gnat_set_text_mode (int handle)
WIN_SETMODE (handle, O_TEXT);
}
+#ifdef __DJGPP__
+void
+__gnat_set_mode (int handle, int mode)
+{
+ /* the values here must be synchronized with
+ System.File_Control_Block.Content_Encodding:
+
+ None = 0
+ Default_Text = 1
+ Text = 2
+ U8text = 3
+ Wtext = 4
+ U16text = 5 */
+
+ switch (mode) {
+ case 0 : setmode(handle, O_BINARY); break;
+ case 1 : setmode(handle, O_TEXT); break;
+ case 2 : setmode(handle, O_TEXT); break;
+ case 3 : setmode(handle, O_TEXT); break;
+ case 4 : setmode(handle, O_BINARY); break;
+ case 5 : setmode(handle, O_BINARY); break;
+ }
+}
+#else
void
__gnat_set_mode (int handle, int mode)
{
@@ -164,13 +193,14 @@ __gnat_set_mode (int handle, int mode)
switch (mode) {
case 0 : WIN_SETMODE (handle, _O_BINARY); break;
- case 1 : WIN_SETMODE (handle, CurrentCCSEncoding); break;
+ case 1 : WIN_SETMODE (handle, __gnat_current_ccs_encoding); break;
case 2 : WIN_SETMODE (handle, _O_TEXT); break;
case 3 : WIN_SETMODE (handle, _O_U8TEXT); break;
case 4 : WIN_SETMODE (handle, _O_WTEXT); break;
case 5 : WIN_SETMODE (handle, _O_U16TEXT); break;
}
}
+#endif
#ifdef __CYGWIN__
@@ -795,7 +825,8 @@ __gnat_localtime_tzoff (const time_t *timer ATTRIBUTE_UNUSED,
struct tm */
#elif defined (__APPLE__) || defined (__FreeBSD__) || defined (__linux__) \
- || defined (__GLIBC__) || defined (__DragonFly__) || defined (__OpenBSD__)
+ || defined (__GLIBC__) || defined (__DragonFly__) || defined (__OpenBSD__) \
+ || defined(__DJGPP__)
{
localtime_r (timer, &tp);
*off = tp.tm_gmtoff;
diff --git a/gcc/ada/system-aix.ads b/gcc/ada/system-aix.ads
index 58a394bab0..95815b41f7 100644
--- a/gcc/ada/system-aix.ads
+++ b/gcc/ada/system-aix.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (AIX/PPC Version) --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -69,8 +69,8 @@ package System is
Null_Address : constant Address;
Storage_Unit : constant := 8;
- Word_Size : constant := 32;
- Memory_Size : constant := 2 ** 32;
+ Word_Size : constant := Standard'Word_Size;
+ Memory_Size : constant := 2 ** Word_Size;
-- Address comparison
@@ -145,10 +145,11 @@ private
Stack_Check_Probes : constant Boolean := True;
Stack_Check_Limits : constant Boolean := False;
Support_Aggregates : constant Boolean := True;
+ Support_Atomic_Primitives : constant Boolean := True;
Support_Composite_Assign : constant Boolean := True;
Support_Composite_Compare : constant Boolean := True;
Support_Long_Shifts : constant Boolean := True;
- Always_Compatible_Rep : constant Boolean := True;
+ Always_Compatible_Rep : constant Boolean := False;
Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
Frontend_Exceptions : constant Boolean := False;
diff --git a/gcc/ada/system-aix64.ads b/gcc/ada/system-aix64.ads
deleted file mode 100644
index 4a34583bcf..0000000000
--- a/gcc/ada/system-aix64.ads
+++ /dev/null
@@ -1,157 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M --
--- --
--- S p e c --
--- (PPC/AIX64 Version) --
--- --
--- Copyright (C) 2009-2015, Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-package System is
- pragma Pure;
- -- Note that we take advantage of the implementation permission to make
- -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada
- -- 2005, this is Pure in any case (AI-362).
-
- pragma No_Elaboration_Code_All;
- -- Allow the use of that restriction in units that WITH this unit
-
- type Name is (SYSTEM_NAME_GNAT);
- System_Name : constant Name := SYSTEM_NAME_GNAT;
-
- -- System-Dependent Named Numbers
-
- Min_Int : constant := Long_Long_Integer'First;
- Max_Int : constant := Long_Long_Integer'Last;
-
- Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
- Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1;
-
- Max_Base_Digits : constant := Long_Long_Float'Digits;
- Max_Digits : constant := Long_Long_Float'Digits;
-
- Max_Mantissa : constant := 63;
- Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
-
- Tick : constant := 0.01;
-
- -- Storage-related Declarations
-
- type Address is private;
- pragma Preelaborable_Initialization (Address);
- Null_Address : constant Address;
-
- Storage_Unit : constant := 8;
- Word_Size : constant := 64;
- Memory_Size : constant := 2 ** 64;
-
- -- Address comparison
-
- function "<" (Left, Right : Address) return Boolean;
- function "<=" (Left, Right : Address) return Boolean;
- function ">" (Left, Right : Address) return Boolean;
- function ">=" (Left, Right : Address) return Boolean;
- function "=" (Left, Right : Address) return Boolean;
-
- pragma Import (Intrinsic, "<");
- pragma Import (Intrinsic, "<=");
- pragma Import (Intrinsic, ">");
- pragma Import (Intrinsic, ">=");
- pragma Import (Intrinsic, "=");
-
- -- Other System-Dependent Declarations
-
- type Bit_Order is (High_Order_First, Low_Order_First);
- Default_Bit_Order : constant Bit_Order := High_Order_First;
- pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning
-
- -- Priority-related Declarations (RM D.1)
-
- -- 0 .. 126 corresponds to the system priority range 1 .. 127.
- --
- -- If the scheduling policy is SCHED_FIFO or SCHED_RR the runtime makes use
- -- of the entire range provided by the system.
- --
- -- If the scheduling policy is SCHED_OTHER the only valid system priority
- -- is 1 and that is the only value ever passed to the system, regardless of
- -- how priorities are set by user programs.
-
- Max_Priority : constant Positive := 125;
- Max_Interrupt_Priority : constant Positive := 126;
-
- subtype Any_Priority is Integer range 0 .. 126;
- subtype Priority is Any_Priority range 0 .. 125;
- subtype Interrupt_Priority is Any_Priority range 126 .. 126;
-
- Default_Priority : constant Priority :=
- (Priority'First + Priority'Last) / 2;
-
-private
-
- type Address is mod Memory_Size;
- Null_Address : constant Address := 0;
-
- --------------------------------------
- -- System Implementation Parameters --
- --------------------------------------
-
- -- These parameters provide information about the target that is used
- -- by the compiler. They are in the private part of System, where they
- -- can be accessed using the special circuitry in the Targparm unit
- -- whose source should be consulted for more detailed descriptions
- -- of the individual switch values.
-
- Backend_Divide_Checks : constant Boolean := False;
- Backend_Overflow_Checks : constant Boolean := True;
- Command_Line_Args : constant Boolean := True;
- Configurable_Run_Time : constant Boolean := False;
- Denorm : constant Boolean := True;
- Duration_32_Bits : constant Boolean := False;
- Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
- Machine_Overflows : constant Boolean := False;
- Machine_Rounds : constant Boolean := True;
- Preallocated_Stacks : constant Boolean := False;
- Signed_Zeros : constant Boolean := True;
- Stack_Check_Default : constant Boolean := False;
- Stack_Check_Probes : constant Boolean := True;
- Stack_Check_Limits : constant Boolean := False;
- Support_Aggregates : constant Boolean := True;
- Support_Composite_Assign : constant Boolean := True;
- Support_Composite_Compare : constant Boolean := True;
- Support_Long_Shifts : constant Boolean := True;
- Always_Compatible_Rep : constant Boolean := True;
- Suppress_Standard_Library : constant Boolean := False;
- Use_Ada_Main_Program_Name : constant Boolean := False;
- Frontend_Exceptions : constant Boolean := False;
- ZCX_By_Default : constant Boolean := True;
-
-end System;
diff --git a/gcc/ada/system-darwin-x86_64.ads b/gcc/ada/system-darwin-arm.ads
index c15efa3ee7..9b96bf9191 100644
--- a/gcc/ada/system-darwin-x86_64.ads
+++ b/gcc/ada/system-darwin-arm.ads
@@ -5,9 +5,9 @@
-- S Y S T E M --
-- --
-- S p e c --
--- (Darwin/x86_64 Version) --
+-- (Darwin/ARM Version) --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -69,8 +69,8 @@ package System is
Null_Address : constant Address;
Storage_Unit : constant := 8;
- Word_Size : constant := 64;
- Memory_Size : constant := 2 ** 64;
+ Word_Size : constant := Standard'Word_Size;
+ Memory_Size : constant := 2 ** Word_Size;
-- Address comparison
diff --git a/gcc/ada/system-darwin-ppc.ads b/gcc/ada/system-darwin-ppc.ads
index e7efdc401b..7809e14c90 100644
--- a/gcc/ada/system-darwin-ppc.ads
+++ b/gcc/ada/system-darwin-ppc.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (Darwin/PPC Version) --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -69,8 +69,8 @@ package System is
Null_Address : constant Address;
Storage_Unit : constant := 8;
- Word_Size : constant := 32;
- Memory_Size : constant := 2 ** 32;
+ Word_Size : constant := Standard'Word_Size;
+ Memory_Size : constant := 2 ** Word_Size;
-- Address comparison
@@ -161,6 +161,7 @@ private
Stack_Check_Probes : constant Boolean := False;
Stack_Check_Limits : constant Boolean := False;
Support_Aggregates : constant Boolean := True;
+ Support_Atomic_Primitives : constant Boolean := Word_Size = 64;
Support_Composite_Assign : constant Boolean := True;
Support_Composite_Compare : constant Boolean := True;
Support_Long_Shifts : constant Boolean := True;
diff --git a/gcc/ada/system-darwin-ppc64.ads b/gcc/ada/system-darwin-ppc64.ads
deleted file mode 100644
index 29cc18726e..0000000000
--- a/gcc/ada/system-darwin-ppc64.ads
+++ /dev/null
@@ -1,153 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M --
--- --
--- S p e c --
--- (Darwin/PPC64 Version) --
--- --
--- Copyright (C) 2011-2016, Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-package System is
- pragma Pure;
- -- Note that we take advantage of the implementation permission to make
- -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada
- -- 2005, this is Pure in any case (AI-362).
-
- pragma No_Elaboration_Code_All;
- -- Allow the use of that restriction in units that WITH this unit
-
- type Name is (SYSTEM_NAME_GNAT);
- System_Name : constant Name := SYSTEM_NAME_GNAT;
-
- -- System-Dependent Named Numbers
-
- Min_Int : constant := Long_Long_Integer'First;
- Max_Int : constant := Long_Long_Integer'Last;
-
- Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
- Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1;
-
- Max_Base_Digits : constant := Long_Long_Float'Digits;
- Max_Digits : constant := Long_Long_Float'Digits;
-
- Max_Mantissa : constant := 63;
- Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
-
- Tick : constant := 0.01;
-
- -- Storage-related Declarations
-
- type Address is private;
- pragma Preelaborable_Initialization (Address);
- Null_Address : constant Address;
-
- Storage_Unit : constant := 8;
- Word_Size : constant := 64;
- Memory_Size : constant := 2 ** 64;
-
- -- Address comparison
-
- function "<" (Left, Right : Address) return Boolean;
- function "<=" (Left, Right : Address) return Boolean;
- function ">" (Left, Right : Address) return Boolean;
- function ">=" (Left, Right : Address) return Boolean;
- function "=" (Left, Right : Address) return Boolean;
-
- pragma Import (Intrinsic, "<");
- pragma Import (Intrinsic, "<=");
- pragma Import (Intrinsic, ">");
- pragma Import (Intrinsic, ">=");
- pragma Import (Intrinsic, "=");
-
- -- Other System-Dependent Declarations
-
- type Bit_Order is (High_Order_First, Low_Order_First);
- Default_Bit_Order : constant Bit_Order := High_Order_First;
- pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning
-
- -- Priority-related Declarations (RM D.1)
-
- -- The values defined here are copied from the ppc version.
-
- Max_Interrupt_Priority : constant Positive := 63;
- Max_Priority : constant Positive := Max_Interrupt_Priority - 1;
-
- subtype Any_Priority is Integer range 0 .. Max_Interrupt_Priority;
- subtype Priority is Any_Priority range 0 .. Max_Priority;
- subtype Interrupt_Priority is Any_Priority
- range Priority'Last + 1 .. Max_Interrupt_Priority;
-
- Default_Priority : constant Priority :=
- (Priority'Last - Priority'First) / 2;
-
-private
-
- type Address is mod Memory_Size;
- Null_Address : constant Address := 0;
-
- --------------------------------------
- -- System Implementation Parameters --
- --------------------------------------
-
- -- These parameters provide information about the target that is used
- -- by the compiler. They are in the private part of System, where they
- -- can be accessed using the special circuitry in the Targparm unit
- -- whose source should be consulted for more detailed descriptions
- -- of the individual switch values.
-
- Backend_Divide_Checks : constant Boolean := False;
- Backend_Overflow_Checks : constant Boolean := True;
- Command_Line_Args : constant Boolean := True;
- Configurable_Run_Time : constant Boolean := False;
- Denorm : constant Boolean := True;
- Duration_32_Bits : constant Boolean := False;
- Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
- Machine_Overflows : constant Boolean := False;
- Machine_Rounds : constant Boolean := True;
- Preallocated_Stacks : constant Boolean := False;
- Signed_Zeros : constant Boolean := True;
- Stack_Check_Default : constant Boolean := False;
- Stack_Check_Probes : constant Boolean := False;
- Stack_Check_Limits : constant Boolean := False;
- Support_64_Bit_Divides : constant Boolean := True;
- Support_Aggregates : constant Boolean := True;
- Support_Atomic_Primitives : constant Boolean := True;
- Support_Composite_Assign : constant Boolean := True;
- Support_Composite_Compare : constant Boolean := True;
- Support_Long_Shifts : constant Boolean := True;
- Always_Compatible_Rep : constant Boolean := False;
- Suppress_Standard_Library : constant Boolean := False;
- Use_Ada_Main_Program_Name : constant Boolean := False;
- Frontend_Exceptions : constant Boolean := False;
- ZCX_By_Default : constant Boolean := True;
-
-end System;
diff --git a/gcc/ada/system-darwin-x86.ads b/gcc/ada/system-darwin-x86.ads
index 358793f32c..7fce58784a 100644
--- a/gcc/ada/system-darwin-x86.ads
+++ b/gcc/ada/system-darwin-x86.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (Darwin/x86 Version) --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -69,8 +69,8 @@ package System is
Null_Address : constant Address;
Storage_Unit : constant := 8;
- Word_Size : constant := 32;
- Memory_Size : constant := 2 ** 32;
+ Word_Size : constant := Standard'Word_Size;
+ Memory_Size : constant := 2 ** Word_Size;
-- Address comparison
diff --git a/gcc/ada/system-freebsd-x86.ads b/gcc/ada/system-djgpp.ads
index a0c5ad4f48..4b0ecd99a6 100644
--- a/gcc/ada/system-freebsd-x86.ads
+++ b/gcc/ada/system-djgpp.ads
@@ -5,9 +5,9 @@
-- S Y S T E M --
-- --
-- S p e c --
--- (FreeBSD/x86 Version) --
+-- (DJGPP Version) --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -60,7 +60,7 @@ package System is
Max_Mantissa : constant := 63;
Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
- Tick : constant := 0.000_001;
+ Tick : constant := 0.01;
-- Storage-related Declarations
@@ -135,7 +135,7 @@ private
Stack_Check_Probes : constant Boolean := True;
Stack_Check_Limits : constant Boolean := False;
Support_Aggregates : constant Boolean := True;
- Support_Atomic_Primitives : constant Boolean := True;
+ Support_Atomic_Primitives : constant Boolean := False;
Support_Composite_Assign : constant Boolean := True;
Support_Composite_Compare : constant Boolean := True;
Support_Long_Shifts : constant Boolean := True;
diff --git a/gcc/ada/system-freebsd-x86_64.ads b/gcc/ada/system-freebsd.ads
index 2d1e20d6cd..4b71e383fc 100644
--- a/gcc/ada/system-freebsd-x86_64.ads
+++ b/gcc/ada/system-freebsd.ads
@@ -5,9 +5,9 @@
-- S Y S T E M --
-- --
-- S p e c --
--- (FreeBSD/x86_64 Version) --
+-- (FreeBSD Version) --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -69,8 +69,8 @@ package System is
Null_Address : constant Address;
Storage_Unit : constant := 8;
- Word_Size : constant := 64;
- Memory_Size : constant := 2 ** 64;
+ Word_Size : constant := Standard'Word_Size;
+ Memory_Size : constant := 2 ** Word_Size;
-- Address comparison
@@ -89,7 +89,8 @@ package System is
-- Other System-Dependent Declarations
type Bit_Order is (High_Order_First, Low_Order_First);
- Default_Bit_Order : constant Bit_Order := Low_Order_First;
+ Default_Bit_Order : constant Bit_Order :=
+ Bit_Order'Val (Standard'Default_Bit_Order);
pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning
-- Priority-related Declarations (RM D.1)
diff --git a/gcc/ada/system-hpux-ia64.ads b/gcc/ada/system-hpux-ia64.ads
index 55095520a7..b6581e8971 100644
--- a/gcc/ada/system-hpux-ia64.ads
+++ b/gcc/ada/system-hpux-ia64.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (HP-UX/ia64 Version) --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -139,7 +139,7 @@ private
Support_Composite_Assign : constant Boolean := True;
Support_Composite_Compare : constant Boolean := True;
Support_Long_Shifts : constant Boolean := True;
- Always_Compatible_Rep : constant Boolean := True;
+ Always_Compatible_Rep : constant Boolean := False;
Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
Frontend_Exceptions : constant Boolean := False;
diff --git a/gcc/ada/system-hpux.ads b/gcc/ada/system-hpux.ads
index a636e915fa..852dcac674 100644
--- a/gcc/ada/system-hpux.ads
+++ b/gcc/ada/system-hpux.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (HP-UX Version) --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -138,7 +138,7 @@ private
Support_Composite_Assign : constant Boolean := True;
Support_Composite_Compare : constant Boolean := True;
Support_Long_Shifts : constant Boolean := True;
- Always_Compatible_Rep : constant Boolean := True;
+ Always_Compatible_Rep : constant Boolean := False;
Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
Frontend_Exceptions : constant Boolean := False;
diff --git a/gcc/ada/system-linux-armel.ads b/gcc/ada/system-linux-aarch64-ilp32.ads
index 90afbfe3ea..496bccf3fc 100644
--- a/gcc/ada/system-linux-armel.ads
+++ b/gcc/ada/system-linux-aarch64-ilp32.ads
@@ -5,9 +5,9 @@
-- S Y S T E M --
-- --
-- S p e c --
--- (GNU-Linux/ARMEL Version) --
+-- (GNU-Linux/ARM Version) --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -70,7 +70,7 @@ package System is
Storage_Unit : constant := 8;
Word_Size : constant := 32;
- Memory_Size : constant := 2 ** 32;
+ Memory_Size : constant := 2 ** Word_Size;
-- Address comparison
@@ -89,7 +89,8 @@ package System is
-- Other System-Dependent Declarations
type Bit_Order is (High_Order_First, Low_Order_First);
- Default_Bit_Order : constant Bit_Order := Low_Order_First;
+ Default_Bit_Order : constant Bit_Order :=
+ Bit_Order'Val (Standard'Default_Bit_Order);
pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning
-- Priority-related Declarations (RM D.1)
@@ -143,6 +144,7 @@ private
Stack_Check_Probes : constant Boolean := True;
Stack_Check_Limits : constant Boolean := False;
Support_Aggregates : constant Boolean := True;
+ Support_Atomic_Primitives : constant Boolean := True;
Support_Composite_Assign : constant Boolean := True;
Support_Composite_Compare : constant Boolean := True;
Support_Long_Shifts : constant Boolean := True;
diff --git a/gcc/ada/system-linux-alpha.ads b/gcc/ada/system-linux-alpha.ads
index 1875b9ac18..e78153436c 100644
--- a/gcc/ada/system-linux-alpha.ads
+++ b/gcc/ada/system-linux-alpha.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (GNU-Linux/alpha Version) --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -135,10 +135,11 @@ private
Stack_Check_Probes : constant Boolean := True;
Stack_Check_Limits : constant Boolean := False;
Support_Aggregates : constant Boolean := True;
+ Support_Atomic_Primitives : constant Boolean := True;
Support_Composite_Assign : constant Boolean := True;
Support_Composite_Compare : constant Boolean := True;
Support_Long_Shifts : constant Boolean := True;
- Always_Compatible_Rep : constant Boolean := True;
+ Always_Compatible_Rep : constant Boolean := False;
Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
Frontend_Exceptions : constant Boolean := False;
diff --git a/gcc/ada/system-linux-x86_64.ads b/gcc/ada/system-linux-arm.ads
index fa62b94b5f..d26e4c7894 100644
--- a/gcc/ada/system-linux-x86_64.ads
+++ b/gcc/ada/system-linux-arm.ads
@@ -5,9 +5,9 @@
-- S Y S T E M --
-- --
-- S p e c --
--- (GNU-Linux/x86-64 Version) --
+-- (GNU-Linux/ARM Version) --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -89,7 +89,8 @@ package System is
-- Other System-Dependent Declarations
type Bit_Order is (High_Order_First, Low_Order_First);
- Default_Bit_Order : constant Bit_Order := Low_Order_First;
+ Default_Bit_Order : constant Bit_Order :=
+ Bit_Order'Val (Standard'Default_Bit_Order);
pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning
-- Priority-related Declarations (RM D.1)
diff --git a/gcc/ada/system-linux-armeb.ads b/gcc/ada/system-linux-armeb.ads
deleted file mode 100644
index e855eb20cf..0000000000
--- a/gcc/ada/system-linux-armeb.ads
+++ /dev/null
@@ -1,156 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M --
--- --
--- S p e c --
--- (GNU-Linux/ARMEB Version) --
--- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-package System is
- pragma Pure;
- -- Note that we take advantage of the implementation permission to make
- -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada
- -- 2005, this is Pure in any case (AI-362).
-
- pragma No_Elaboration_Code_All;
- -- Allow the use of that restriction in units that WITH this unit
-
- type Name is (SYSTEM_NAME_GNAT);
- System_Name : constant Name := SYSTEM_NAME_GNAT;
-
- -- System-Dependent Named Numbers
-
- Min_Int : constant := Long_Long_Integer'First;
- Max_Int : constant := Long_Long_Integer'Last;
-
- Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
- Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1;
-
- Max_Base_Digits : constant := Long_Long_Float'Digits;
- Max_Digits : constant := Long_Long_Float'Digits;
-
- Max_Mantissa : constant := 63;
- Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
-
- Tick : constant := 0.000_001;
-
- -- Storage-related Declarations
-
- type Address is private;
- pragma Preelaborable_Initialization (Address);
- Null_Address : constant Address;
-
- Storage_Unit : constant := 8;
- Word_Size : constant := 32;
- Memory_Size : constant := 2 ** 32;
-
- -- Address comparison
-
- function "<" (Left, Right : Address) return Boolean;
- function "<=" (Left, Right : Address) return Boolean;
- function ">" (Left, Right : Address) return Boolean;
- function ">=" (Left, Right : Address) return Boolean;
- function "=" (Left, Right : Address) return Boolean;
-
- pragma Import (Intrinsic, "<");
- pragma Import (Intrinsic, "<=");
- pragma Import (Intrinsic, ">");
- pragma Import (Intrinsic, ">=");
- pragma Import (Intrinsic, "=");
-
- -- Other System-Dependent Declarations
-
- type Bit_Order is (High_Order_First, Low_Order_First);
- Default_Bit_Order : constant Bit_Order := High_Order_First;
- pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning
-
- -- Priority-related Declarations (RM D.1)
-
- -- 0 .. 98 corresponds to the system priority range 1 .. 99.
- --
- -- If the scheduling policy is SCHED_FIFO or SCHED_RR the runtime makes use
- -- of the entire range provided by the system.
- --
- -- If the scheduling policy is SCHED_OTHER the only valid system priority
- -- is 1 and other values are simply ignored.
-
- Max_Priority : constant Positive := 97;
- Max_Interrupt_Priority : constant Positive := 98;
-
- subtype Any_Priority is Integer range 0 .. 98;
- subtype Priority is Any_Priority range 0 .. 97;
- subtype Interrupt_Priority is Any_Priority range 98 .. 98;
-
- Default_Priority : constant Priority := 48;
-
-private
-
- type Address is mod Memory_Size;
- Null_Address : constant Address := 0;
-
- --------------------------------------
- -- System Implementation Parameters --
- --------------------------------------
-
- -- These parameters provide information about the target that is used
- -- by the compiler. They are in the private part of System, where they
- -- can be accessed using the special circuitry in the Targparm unit
- -- whose source should be consulted for more detailed descriptions
- -- of the individual switch values.
-
- Backend_Divide_Checks : constant Boolean := False;
- Backend_Overflow_Checks : constant Boolean := False;
- Command_Line_Args : constant Boolean := True;
- Configurable_Run_Time : constant Boolean := False;
- Denorm : constant Boolean := True;
- Duration_32_Bits : constant Boolean := False;
- Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
- Machine_Overflows : constant Boolean := False;
- Machine_Rounds : constant Boolean := True;
- Preallocated_Stacks : constant Boolean := False;
- Signed_Zeros : constant Boolean := True;
- Stack_Check_Default : constant Boolean := False;
- Stack_Check_Probes : constant Boolean := True;
- Stack_Check_Limits : constant Boolean := False;
- Support_64_Bit_Divides : constant Boolean := True;
- Support_Aggregates : constant Boolean := True;
- Support_Composite_Assign : constant Boolean := True;
- Support_Composite_Compare : constant Boolean := True;
- Support_Long_Shifts : constant Boolean := True;
- Always_Compatible_Rep : constant Boolean := False;
- Suppress_Standard_Library : constant Boolean := False;
- Use_Ada_Main_Program_Name : constant Boolean := False;
- Frontend_Exceptions : constant Boolean := True;
- ZCX_By_Default : constant Boolean := False;
-
-end System;
diff --git a/gcc/ada/system-linux-hppa.ads b/gcc/ada/system-linux-hppa.ads
index 0d76aefe6d..83aba27dde 100644
--- a/gcc/ada/system-linux-hppa.ads
+++ b/gcc/ada/system-linux-hppa.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (GNU/Linux-HPPA Version) --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -138,7 +138,7 @@ private
Support_Composite_Assign : constant Boolean := True;
Support_Composite_Compare : constant Boolean := True;
Support_Long_Shifts : constant Boolean := True;
- Always_Compatible_Rep : constant Boolean := True;
+ Always_Compatible_Rep : constant Boolean := False;
Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
Frontend_Exceptions : constant Boolean := False;
diff --git a/gcc/ada/system-linux-ia64.ads b/gcc/ada/system-linux-ia64.ads
index 1ddc311a78..8fe4697704 100644
--- a/gcc/ada/system-linux-ia64.ads
+++ b/gcc/ada/system-linux-ia64.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (GNU-Linux/ia64 Version) --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -147,7 +147,7 @@ private
Support_Composite_Assign : constant Boolean := True;
Support_Composite_Compare : constant Boolean := True;
Support_Long_Shifts : constant Boolean := True;
- Always_Compatible_Rep : constant Boolean := True;
+ Always_Compatible_Rep : constant Boolean := False;
Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
Frontend_Exceptions : constant Boolean := False;
diff --git a/gcc/ada/system-linux-ppc64.ads b/gcc/ada/system-linux-m68k.ads
index 5bb306f861..9aa6143f26 100644
--- a/gcc/ada/system-linux-ppc64.ads
+++ b/gcc/ada/system-linux-m68k.ads
@@ -5,9 +5,9 @@
-- S Y S T E M --
-- --
-- S p e c --
--- (GNU-Linux/PPC64 Version) --
+-- (GNU/Linux/m68k Version) --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 2014-2016, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -40,9 +40,6 @@ package System is
-- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada
-- 2005, this is Pure in any case (AI-362).
- pragma No_Elaboration_Code_All;
- -- Allow the use of that restriction in units that WITH this unit
-
type Name is (SYSTEM_NAME_GNAT);
System_Name : constant Name := SYSTEM_NAME_GNAT;
@@ -69,8 +66,8 @@ package System is
Null_Address : constant Address;
Storage_Unit : constant := 8;
- Word_Size : constant := 64;
- Memory_Size : constant := 2 ** 64;
+ Word_Size : constant := 32;
+ Memory_Size : constant := 2 ** 32;
-- Address comparison
@@ -94,6 +91,8 @@ package System is
-- Priority-related Declarations (RM D.1)
+ -- Is the following actually true for GNU/Linux/m68k?
+ --
-- 0 .. 98 corresponds to the system priority range 1 .. 99.
--
-- If the scheduling policy is SCHED_FIFO or SCHED_RR the runtime makes use
@@ -140,10 +139,10 @@ private
Preallocated_Stacks : constant Boolean := False;
Signed_Zeros : constant Boolean := True;
Stack_Check_Default : constant Boolean := False;
- Stack_Check_Probes : constant Boolean := True;
+ Stack_Check_Probes : constant Boolean := False;
Stack_Check_Limits : constant Boolean := False;
- Support_64_Bit_Divides : constant Boolean := True;
Support_Aggregates : constant Boolean := True;
+ Support_Atomic_Primitives : constant Boolean := True;
Support_Composite_Assign : constant Boolean := True;
Support_Composite_Compare : constant Boolean := True;
Support_Long_Shifts : constant Boolean := True;
diff --git a/gcc/ada/system-linux-mips.ads b/gcc/ada/system-linux-mips.ads
index d5dc2cd289..f165c94fd1 100644
--- a/gcc/ada/system-linux-mips.ads
+++ b/gcc/ada/system-linux-mips.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (GNU-Linux/MIPS Version) --
-- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -69,8 +69,8 @@ package System is
Null_Address : constant Address;
Storage_Unit : constant := 8;
- Word_Size : constant := 32;
- Memory_Size : constant := 2 ** 32;
+ Word_Size : constant := Standard'Word_Size;
+ Memory_Size : constant := 2 ** Word_Size;
-- Address comparison
@@ -89,7 +89,8 @@ package System is
-- Other System-Dependent Declarations
type Bit_Order is (High_Order_First, Low_Order_First);
- Default_Bit_Order : constant Bit_Order := High_Order_First;
+ Default_Bit_Order : constant Bit_Order :=
+ Bit_Order'Val (Standard'Default_Bit_Order);
pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning
-- Priority-related Declarations (RM D.1)
@@ -119,7 +120,7 @@ private
-- of the individual switch values.
Backend_Divide_Checks : constant Boolean := False;
- Backend_Overflow_Checks : constant Boolean := False;
+ Backend_Overflow_Checks : constant Boolean := True;
Command_Line_Args : constant Boolean := True;
Configurable_Run_Time : constant Boolean := False;
Denorm : constant Boolean := True;
@@ -134,12 +135,11 @@ private
Stack_Check_Default : constant Boolean := False;
Stack_Check_Probes : constant Boolean := True;
Stack_Check_Limits : constant Boolean := False;
- Support_64_Bit_Divides : constant Boolean := True;
Support_Aggregates : constant Boolean := True;
Support_Composite_Assign : constant Boolean := True;
Support_Composite_Compare : constant Boolean := True;
Support_Long_Shifts : constant Boolean := True;
- Always_Compatible_Rep : constant Boolean := True;
+ Always_Compatible_Rep : constant Boolean := False;
Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
Frontend_Exceptions : constant Boolean := False;
diff --git a/gcc/ada/system-linux-mips64el.ads b/gcc/ada/system-linux-mips64el.ads
deleted file mode 100644
index 995fb8161e..0000000000
--- a/gcc/ada/system-linux-mips64el.ads
+++ /dev/null
@@ -1,148 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M --
--- --
--- S p e c --
--- (GNU-Linux/MIPS64EL Version) --
--- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-package System is
- pragma Pure;
- -- Note that we take advantage of the implementation permission to make
- -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada
- -- 2005, this is Pure in any case (AI-362).
-
- pragma No_Elaboration_Code_All;
- -- Allow the use of that restriction in units that WITH this unit
-
- type Name is (SYSTEM_NAME_GNAT);
- System_Name : constant Name := SYSTEM_NAME_GNAT;
-
- -- System-Dependent Named Numbers
-
- Min_Int : constant := Long_Long_Integer'First;
- Max_Int : constant := Long_Long_Integer'Last;
-
- Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
- Max_Nonbinary_Modulus : constant := Integer'Last;
-
- Max_Base_Digits : constant := Long_Long_Float'Digits;
- Max_Digits : constant := Long_Long_Float'Digits;
-
- Max_Mantissa : constant := 63;
- Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
-
- Tick : constant := 0.000_001;
-
- -- Storage-related Declarations
-
- type Address is private;
- pragma Preelaborable_Initialization (Address);
- Null_Address : constant Address;
-
- Storage_Unit : constant := 8;
- Word_Size : constant := 64;
- Memory_Size : constant := 2 ** 64;
-
- -- Address comparison
-
- function "<" (Left, Right : Address) return Boolean;
- function "<=" (Left, Right : Address) return Boolean;
- function ">" (Left, Right : Address) return Boolean;
- function ">=" (Left, Right : Address) return Boolean;
- function "=" (Left, Right : Address) return Boolean;
-
- pragma Import (Intrinsic, "<");
- pragma Import (Intrinsic, "<=");
- pragma Import (Intrinsic, ">");
- pragma Import (Intrinsic, ">=");
- pragma Import (Intrinsic, "=");
-
- -- Other System-Dependent Declarations
-
- type Bit_Order is (High_Order_First, Low_Order_First);
- Default_Bit_Order : constant Bit_Order := Low_Order_First;
- pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning
-
- -- Priority-related Declarations (RM D.1)
-
- Max_Priority : constant Positive := 30;
- Max_Interrupt_Priority : constant Positive := 31;
-
- subtype Any_Priority is Integer range 0 .. 31;
- subtype Priority is Any_Priority range 0 .. 30;
- subtype Interrupt_Priority is Any_Priority range 31 .. 31;
-
- Default_Priority : constant Priority := 15;
-
-private
-
- type Address is mod Memory_Size;
- Null_Address : constant Address := 0;
-
- --------------------------------------
- -- System Implementation Parameters --
- --------------------------------------
-
- -- These parameters provide information about the target that is used
- -- by the compiler. They are in the private part of System, where they
- -- can be accessed using the special circuitry in the Targparm unit
- -- whose source should be consulted for more detailed descriptions
- -- of the individual switch values.
-
- Backend_Divide_Checks : constant Boolean := False;
- Backend_Overflow_Checks : constant Boolean := False;
- Command_Line_Args : constant Boolean := True;
- Configurable_Run_Time : constant Boolean := False;
- Denorm : constant Boolean := True;
- Duration_32_Bits : constant Boolean := False;
- Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
- Machine_Overflows : constant Boolean := False;
- Machine_Rounds : constant Boolean := True;
- Preallocated_Stacks : constant Boolean := False;
- Signed_Zeros : constant Boolean := True;
- Stack_Check_Default : constant Boolean := False;
- Stack_Check_Probes : constant Boolean := True;
- Stack_Check_Limits : constant Boolean := False;
- Support_64_Bit_Divides : constant Boolean := True;
- Support_Aggregates : constant Boolean := True;
- Support_Composite_Assign : constant Boolean := True;
- Support_Composite_Compare : constant Boolean := True;
- Support_Long_Shifts : constant Boolean := True;
- Always_Compatible_Rep : constant Boolean := True;
- Suppress_Standard_Library : constant Boolean := False;
- Use_Ada_Main_Program_Name : constant Boolean := False;
- Frontend_Exceptions : constant Boolean := False;
- ZCX_By_Default : constant Boolean := True;
-
-end System;
diff --git a/gcc/ada/system-linux-mipsel.ads b/gcc/ada/system-linux-mipsel.ads
deleted file mode 100644
index 405ab7a0f9..0000000000
--- a/gcc/ada/system-linux-mipsel.ads
+++ /dev/null
@@ -1,148 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M --
--- --
--- S p e c --
--- (GNU-Linux/MIPSEL Version) --
--- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-package System is
- pragma Pure;
- -- Note that we take advantage of the implementation permission to make
- -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada
- -- 2005, this is Pure in any case (AI-362).
-
- pragma No_Elaboration_Code_All;
- -- Allow the use of that restriction in units that WITH this unit
-
- type Name is (SYSTEM_NAME_GNAT);
- System_Name : constant Name := SYSTEM_NAME_GNAT;
-
- -- System-Dependent Named Numbers
-
- Min_Int : constant := Long_Long_Integer'First;
- Max_Int : constant := Long_Long_Integer'Last;
-
- Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
- Max_Nonbinary_Modulus : constant := Integer'Last;
-
- Max_Base_Digits : constant := Long_Long_Float'Digits;
- Max_Digits : constant := Long_Long_Float'Digits;
-
- Max_Mantissa : constant := 63;
- Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
-
- Tick : constant := 0.000_001;
-
- -- Storage-related Declarations
-
- type Address is private;
- pragma Preelaborable_Initialization (Address);
- Null_Address : constant Address;
-
- Storage_Unit : constant := 8;
- Word_Size : constant := 32;
- Memory_Size : constant := 2 ** 32;
-
- -- Address comparison
-
- function "<" (Left, Right : Address) return Boolean;
- function "<=" (Left, Right : Address) return Boolean;
- function ">" (Left, Right : Address) return Boolean;
- function ">=" (Left, Right : Address) return Boolean;
- function "=" (Left, Right : Address) return Boolean;
-
- pragma Import (Intrinsic, "<");
- pragma Import (Intrinsic, "<=");
- pragma Import (Intrinsic, ">");
- pragma Import (Intrinsic, ">=");
- pragma Import (Intrinsic, "=");
-
- -- Other System-Dependent Declarations
-
- type Bit_Order is (High_Order_First, Low_Order_First);
- Default_Bit_Order : constant Bit_Order := Low_Order_First;
- pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning
-
- -- Priority-related Declarations (RM D.1)
-
- Max_Priority : constant Positive := 30;
- Max_Interrupt_Priority : constant Positive := 31;
-
- subtype Any_Priority is Integer range 0 .. 31;
- subtype Priority is Any_Priority range 0 .. 30;
- subtype Interrupt_Priority is Any_Priority range 31 .. 31;
-
- Default_Priority : constant Priority := 15;
-
-private
-
- type Address is mod Memory_Size;
- Null_Address : constant Address := 0;
-
- --------------------------------------
- -- System Implementation Parameters --
- --------------------------------------
-
- -- These parameters provide information about the target that is used
- -- by the compiler. They are in the private part of System, where they
- -- can be accessed using the special circuitry in the Targparm unit
- -- whose source should be consulted for more detailed descriptions
- -- of the individual switch values.
-
- Backend_Divide_Checks : constant Boolean := False;
- Backend_Overflow_Checks : constant Boolean := False;
- Command_Line_Args : constant Boolean := True;
- Configurable_Run_Time : constant Boolean := False;
- Denorm : constant Boolean := True;
- Duration_32_Bits : constant Boolean := False;
- Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
- Machine_Overflows : constant Boolean := False;
- Machine_Rounds : constant Boolean := True;
- Preallocated_Stacks : constant Boolean := False;
- Signed_Zeros : constant Boolean := True;
- Stack_Check_Default : constant Boolean := False;
- Stack_Check_Probes : constant Boolean := True;
- Stack_Check_Limits : constant Boolean := False;
- Support_64_Bit_Divides : constant Boolean := True;
- Support_Aggregates : constant Boolean := True;
- Support_Composite_Assign : constant Boolean := True;
- Support_Composite_Compare : constant Boolean := True;
- Support_Long_Shifts : constant Boolean := True;
- Always_Compatible_Rep : constant Boolean := True;
- Suppress_Standard_Library : constant Boolean := False;
- Use_Ada_Main_Program_Name : constant Boolean := False;
- Frontend_Exceptions : constant Boolean := False;
- ZCX_By_Default : constant Boolean := True;
-
-end System;
diff --git a/gcc/ada/system-linux-ppc.ads b/gcc/ada/system-linux-ppc.ads
index f0a2b1e51a..367d09fb83 100644
--- a/gcc/ada/system-linux-ppc.ads
+++ b/gcc/ada/system-linux-ppc.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (GNU-Linux/PPC Version) --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -69,8 +69,8 @@ package System is
Null_Address : constant Address;
Storage_Unit : constant := 8;
- Word_Size : constant := 32;
- Memory_Size : constant := 2 ** 32;
+ Word_Size : constant := Standard'Word_Size;
+ Memory_Size : constant := 2 ** Word_Size;
-- Address comparison
@@ -89,7 +89,8 @@ package System is
-- Other System-Dependent Declarations
type Bit_Order is (High_Order_First, Low_Order_First);
- Default_Bit_Order : constant Bit_Order := High_Order_First;
+ Default_Bit_Order : constant Bit_Order :=
+ Bit_Order'Val (Standard'Default_Bit_Order);
pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning
-- Priority-related Declarations (RM D.1)
diff --git a/gcc/ada/system-linux-s390.ads b/gcc/ada/system-linux-s390.ads
index b81b2b28dc..9bf8375e3a 100644
--- a/gcc/ada/system-linux-s390.ads
+++ b/gcc/ada/system-linux-s390.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (GNU-Linux/s390 Version) --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -69,8 +69,8 @@ package System is
Null_Address : constant Address;
Storage_Unit : constant := 8;
- Word_Size : constant := 32;
- Memory_Size : constant := 2 ** 32;
+ Word_Size : constant := Standard'Word_Size;
+ Memory_Size : constant := 2 ** Long_Integer'Size;
-- Address comparison
@@ -138,7 +138,7 @@ private
Support_Composite_Assign : constant Boolean := True;
Support_Composite_Compare : constant Boolean := True;
Support_Long_Shifts : constant Boolean := True;
- Always_Compatible_Rep : constant Boolean := True;
+ Always_Compatible_Rep : constant Boolean := False;
Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
Frontend_Exceptions : constant Boolean := False;
diff --git a/gcc/ada/system-linux-s390x.ads b/gcc/ada/system-linux-s390x.ads
deleted file mode 100644
index db0e3c0f33..0000000000
--- a/gcc/ada/system-linux-s390x.ads
+++ /dev/null
@@ -1,147 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M --
--- --
--- S p e c --
--- (GNU-Linux/s390x Version) --
--- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-package System is
- pragma Pure;
- -- Note that we take advantage of the implementation permission to make
- -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada
- -- 2005, this is Pure in any case (AI-362).
-
- pragma No_Elaboration_Code_All;
- -- Allow the use of that restriction in units that WITH this unit
-
- type Name is (SYSTEM_NAME_GNAT);
- System_Name : constant Name := SYSTEM_NAME_GNAT;
-
- -- System-Dependent Named Numbers
-
- Min_Int : constant := Long_Long_Integer'First;
- Max_Int : constant := Long_Long_Integer'Last;
-
- Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
- Max_Nonbinary_Modulus : constant := Integer'Last;
-
- Max_Base_Digits : constant := Long_Long_Float'Digits;
- Max_Digits : constant := Long_Long_Float'Digits;
-
- Max_Mantissa : constant := 63;
- Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
-
- Tick : constant := 0.000_001;
-
- -- Storage-related Declarations
-
- type Address is private;
- pragma Preelaborable_Initialization (Address);
- Null_Address : constant Address;
-
- Storage_Unit : constant := 8;
- Word_Size : constant := 64;
- Memory_Size : constant := 2 ** 64;
-
- -- Address comparison
-
- function "<" (Left, Right : Address) return Boolean;
- function "<=" (Left, Right : Address) return Boolean;
- function ">" (Left, Right : Address) return Boolean;
- function ">=" (Left, Right : Address) return Boolean;
- function "=" (Left, Right : Address) return Boolean;
-
- pragma Import (Intrinsic, "<");
- pragma Import (Intrinsic, "<=");
- pragma Import (Intrinsic, ">");
- pragma Import (Intrinsic, ">=");
- pragma Import (Intrinsic, "=");
-
- -- Other System-Dependent Declarations
-
- type Bit_Order is (High_Order_First, Low_Order_First);
- Default_Bit_Order : constant Bit_Order := High_Order_First;
- pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning
-
- -- Priority-related Declarations (RM D.1)
-
- Max_Priority : constant Positive := 30;
- Max_Interrupt_Priority : constant Positive := 31;
-
- subtype Any_Priority is Integer range 0 .. 31;
- subtype Priority is Any_Priority range 0 .. 30;
- subtype Interrupt_Priority is Any_Priority range 31 .. 31;
-
- Default_Priority : constant Priority := 15;
-
-private
-
- type Address is mod Memory_Size;
- Null_Address : constant Address := 0;
-
- --------------------------------------
- -- System Implementation Parameters --
- --------------------------------------
-
- -- These parameters provide information about the target that is used
- -- by the compiler. They are in the private part of System, where they
- -- can be accessed using the special circuitry in the Targparm unit
- -- whose source should be consulted for more detailed descriptions
- -- of the individual switch values.
-
- Backend_Divide_Checks : constant Boolean := False;
- Backend_Overflow_Checks : constant Boolean := True;
- Command_Line_Args : constant Boolean := True;
- Configurable_Run_Time : constant Boolean := False;
- Denorm : constant Boolean := True;
- Duration_32_Bits : constant Boolean := False;
- Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
- Machine_Overflows : constant Boolean := False;
- Machine_Rounds : constant Boolean := True;
- Preallocated_Stacks : constant Boolean := False;
- Signed_Zeros : constant Boolean := True;
- Stack_Check_Default : constant Boolean := False;
- Stack_Check_Probes : constant Boolean := True;
- Stack_Check_Limits : constant Boolean := False;
- Support_Aggregates : constant Boolean := True;
- Support_Composite_Assign : constant Boolean := True;
- Support_Composite_Compare : constant Boolean := True;
- Support_Long_Shifts : constant Boolean := True;
- Always_Compatible_Rep : constant Boolean := True;
- Suppress_Standard_Library : constant Boolean := False;
- Use_Ada_Main_Program_Name : constant Boolean := False;
- Frontend_Exceptions : constant Boolean := False;
- ZCX_By_Default : constant Boolean := True;
-
-end System;
diff --git a/gcc/ada/system-linux-sh4.ads b/gcc/ada/system-linux-sh4.ads
index ad8517f4f5..dcd28a01f9 100644
--- a/gcc/ada/system-linux-sh4.ads
+++ b/gcc/ada/system-linux-sh4.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (GNU-Linux/sh4 Version) --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -146,7 +146,7 @@ private
Support_Composite_Assign : constant Boolean := True;
Support_Composite_Compare : constant Boolean := True;
Support_Long_Shifts : constant Boolean := True;
- Always_Compatible_Rep : constant Boolean := True;
+ Always_Compatible_Rep : constant Boolean := False;
Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
Frontend_Exceptions : constant Boolean := False;
diff --git a/gcc/ada/system-linux-sparc.ads b/gcc/ada/system-linux-sparc.ads
index 3fa0a2d9e2..503adbe6f3 100644
--- a/gcc/ada/system-linux-sparc.ads
+++ b/gcc/ada/system-linux-sparc.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (GNU/Linux-SPARC Version) --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -69,8 +69,8 @@ package System is
Null_Address : constant Address;
Storage_Unit : constant := 8;
- Word_Size : constant := 32;
- Memory_Size : constant := 2 ** 32;
+ Word_Size : constant := Standard'Word_Size;
+ Memory_Size : constant := 2 ** Word_Size;
-- Address comparison
@@ -138,7 +138,7 @@ private
Support_Composite_Assign : constant Boolean := True;
Support_Composite_Compare : constant Boolean := True;
Support_Long_Shifts : constant Boolean := True;
- Always_Compatible_Rep : constant Boolean := True;
+ Always_Compatible_Rep : constant Boolean := False;
Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
Frontend_Exceptions : constant Boolean := False;
diff --git a/gcc/ada/system-linux-sparcv9.ads b/gcc/ada/system-linux-sparcv9.ads
deleted file mode 100644
index e4d11560d2..0000000000
--- a/gcc/ada/system-linux-sparcv9.ads
+++ /dev/null
@@ -1,148 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M --
--- --
--- S p e c --
--- (GNU/Linux-SPARCV9 Version) --
--- --
--- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-package System is
- pragma Pure;
- -- Note that we take advantage of the implementation permission to make
- -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada
- -- 2005, this is Pure in any case (AI-362).
-
- pragma No_Elaboration_Code_All;
- -- Allow the use of that restriction in units that WITH this unit
-
- type Name is (SYSTEM_NAME_GNAT);
- System_Name : constant Name := SYSTEM_NAME_GNAT;
-
- -- System-Dependent Named Numbers
-
- Min_Int : constant := Long_Long_Integer'First;
- Max_Int : constant := Long_Long_Integer'Last;
-
- Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
- Max_Nonbinary_Modulus : constant := Integer'Last;
-
- Max_Base_Digits : constant := Long_Long_Float'Digits;
- Max_Digits : constant := Long_Long_Float'Digits;
-
- Max_Mantissa : constant := 63;
- Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
-
- Tick : constant := 0.000_001;
-
- -- Storage-related Declarations
-
- type Address is private;
- pragma Preelaborable_Initialization (Address);
- Null_Address : constant Address;
-
- Storage_Unit : constant := 8;
- Word_Size : constant := 64;
- Memory_Size : constant := 2 ** 64;
-
- -- Address comparison
-
- function "<" (Left, Right : Address) return Boolean;
- function "<=" (Left, Right : Address) return Boolean;
- function ">" (Left, Right : Address) return Boolean;
- function ">=" (Left, Right : Address) return Boolean;
- function "=" (Left, Right : Address) return Boolean;
-
- pragma Import (Intrinsic, "<");
- pragma Import (Intrinsic, "<=");
- pragma Import (Intrinsic, ">");
- pragma Import (Intrinsic, ">=");
- pragma Import (Intrinsic, "=");
-
- -- Other System-Dependent Declarations
-
- type Bit_Order is (High_Order_First, Low_Order_First);
- Default_Bit_Order : constant Bit_Order := High_Order_First;
- pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning
-
- -- Priority-related Declarations (RM D.1)
-
- Max_Priority : constant Positive := 30;
- Max_Interrupt_Priority : constant Positive := 31;
-
- subtype Any_Priority is Integer range 0 .. 31;
- subtype Priority is Any_Priority range 0 .. 30;
- subtype Interrupt_Priority is Any_Priority range 31 .. 31;
-
- Default_Priority : constant Priority := 15;
-
-private
-
- type Address is mod Memory_Size;
- Null_Address : constant Address := 0;
-
- --------------------------------------
- -- System Implementation Parameters --
- --------------------------------------
-
- -- These parameters provide information about the target that is used
- -- by the compiler. They are in the private part of System, where they
- -- can be accessed using the special circuitry in the Targparm unit
- -- whose source should be consulted for more detailed descriptions
- -- of the individual switch values.
-
- Backend_Divide_Checks : constant Boolean := False;
- Backend_Overflow_Checks : constant Boolean := False;
- Command_Line_Args : constant Boolean := True;
- Configurable_Run_Time : constant Boolean := False;
- Denorm : constant Boolean := True;
- Duration_32_Bits : constant Boolean := False;
- Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
- Machine_Overflows : constant Boolean := False;
- Machine_Rounds : constant Boolean := True;
- Preallocated_Stacks : constant Boolean := False;
- Signed_Zeros : constant Boolean := True;
- Stack_Check_Default : constant Boolean := False;
- Stack_Check_Probes : constant Boolean := True;
- Stack_Check_Limits : constant Boolean := False;
- Support_64_Bit_Divides : constant Boolean := True;
- Support_Aggregates : constant Boolean := True;
- Support_Composite_Assign : constant Boolean := True;
- Support_Composite_Compare : constant Boolean := True;
- Support_Long_Shifts : constant Boolean := True;
- Always_Compatible_Rep : constant Boolean := True;
- Suppress_Standard_Library : constant Boolean := False;
- Use_Ada_Main_Program_Name : constant Boolean := False;
- Frontend_Exceptions : constant Boolean := False;
- ZCX_By_Default : constant Boolean := True;
-
-end System;
diff --git a/gcc/ada/system-linux-x86.ads b/gcc/ada/system-linux-x86.ads
index 1942124530..22a212e265 100644
--- a/gcc/ada/system-linux-x86.ads
+++ b/gcc/ada/system-linux-x86.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (GNU-Linux/x86 Version) --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -69,8 +69,8 @@ package System is
Null_Address : constant Address;
Storage_Unit : constant := 8;
- Word_Size : constant := 32;
- Memory_Size : constant := 2 ** 32;
+ Word_Size : constant := Standard'Word_Size;
+ Memory_Size : constant := 2 ** Word_Size;
-- Address comparison
diff --git a/gcc/ada/system-mingw-x86_64.ads b/gcc/ada/system-mingw-x86_64.ads
deleted file mode 100644
index 9dff0e2347..0000000000
--- a/gcc/ada/system-mingw-x86_64.ads
+++ /dev/null
@@ -1,200 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M --
--- --
--- S p e c --
--- (Windows Version) --
--- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-package System is
- pragma Pure;
- -- Note that we take advantage of the implementation permission to make
- -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada
- -- 2005, this is Pure in any case (AI-362).
-
- pragma No_Elaboration_Code_All;
- -- Allow the use of that restriction in units that WITH this unit
-
- type Name is (SYSTEM_NAME_GNAT);
- System_Name : constant Name := SYSTEM_NAME_GNAT;
-
- -- System-Dependent Named Numbers
-
- Min_Int : constant := Long_Long_Integer'First;
- Max_Int : constant := Long_Long_Integer'Last;
-
- Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
- Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1;
-
- Max_Base_Digits : constant := Long_Long_Float'Digits;
- Max_Digits : constant := Long_Long_Float'Digits;
-
- Max_Mantissa : constant := 63;
- Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
-
- Tick : constant := 0.01;
-
- -- Storage-related Declarations
-
- type Address is private;
- pragma Preelaborable_Initialization (Address);
- Null_Address : constant Address;
-
- Storage_Unit : constant := 8;
- Word_Size : constant := Standard'Word_Size;
- Memory_Size : constant := 2 ** Word_Size;
-
- -- Address comparison
-
- function "<" (Left, Right : Address) return Boolean;
- function "<=" (Left, Right : Address) return Boolean;
- function ">" (Left, Right : Address) return Boolean;
- function ">=" (Left, Right : Address) return Boolean;
- function "=" (Left, Right : Address) return Boolean;
-
- pragma Import (Intrinsic, "<");
- pragma Import (Intrinsic, "<=");
- pragma Import (Intrinsic, ">");
- pragma Import (Intrinsic, ">=");
- pragma Import (Intrinsic, "=");
-
- -- Other System-Dependent Declarations
-
- type Bit_Order is (High_Order_First, Low_Order_First);
- Default_Bit_Order : constant Bit_Order := Low_Order_First;
- pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning
-
- -- Priority-related Declarations (RM D.1)
-
- Max_Priority : constant Positive := 30;
- Max_Interrupt_Priority : constant Positive := 31;
-
- subtype Any_Priority is Integer range 0 .. 31;
- subtype Priority is Any_Priority range 0 .. 30;
- subtype Interrupt_Priority is Any_Priority range 31 .. 31;
-
- Default_Priority : constant Priority := 15;
-
-private
-
- type Address is mod Memory_Size;
- Null_Address : constant Address := 0;
-
- --------------------------------------
- -- System Implementation Parameters --
- --------------------------------------
-
- -- These parameters provide information about the target that is used
- -- by the compiler. They are in the private part of System, where they
- -- can be accessed using the special circuitry in the Targparm unit
- -- whose source should be consulted for more detailed descriptions
- -- of the individual switch values.
-
- Backend_Divide_Checks : constant Boolean := False;
- Backend_Overflow_Checks : constant Boolean := True;
- Command_Line_Args : constant Boolean := True;
- Configurable_Run_Time : constant Boolean := False;
- Denorm : constant Boolean := True;
- Duration_32_Bits : constant Boolean := False;
- Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
- Machine_Overflows : constant Boolean := False;
- Machine_Rounds : constant Boolean := True;
- Preallocated_Stacks : constant Boolean := False;
- Signed_Zeros : constant Boolean := True;
- Stack_Check_Default : constant Boolean := False;
- Stack_Check_Probes : constant Boolean := True;
- Stack_Check_Limits : constant Boolean := False;
- Support_Aggregates : constant Boolean := True;
- Support_Atomic_Primitives : constant Boolean := True;
- Support_Composite_Assign : constant Boolean := True;
- Support_Composite_Compare : constant Boolean := True;
- Support_Long_Shifts : constant Boolean := True;
- Always_Compatible_Rep : constant Boolean := False;
- Suppress_Standard_Library : constant Boolean := False;
- Use_Ada_Main_Program_Name : constant Boolean := False;
- Frontend_Exceptions : constant Boolean := False;
- ZCX_By_Default : constant Boolean := True;
-
- ---------------------------
- -- Underlying Priorities --
- ---------------------------
-
- -- Important note: this section of the file must come AFTER the
- -- definition of the system implementation parameters to ensure
- -- that the value of these parameters is available for analysis
- -- of the declarations here (using Rtsfind at compile time).
-
- -- The underlying priorities table provides a generalized mechanism
- -- for mapping from Ada priorities to system priorities. In some
- -- cases a 1-1 mapping is not the convenient or optimal choice.
-
- type Priorities_Mapping is array (Any_Priority) of Integer;
- pragma Suppress_Initialization (Priorities_Mapping);
- -- Suppress initialization in case gnat.adc specifies Normalize_Scalars
-
- Underlying_Priorities : constant Priorities_Mapping :=
- (Priority'First ..
- Default_Priority - 8 => -15,
- Default_Priority - 7 => -7,
- Default_Priority - 6 => -6,
- Default_Priority - 5 => -5,
- Default_Priority - 4 => -4,
- Default_Priority - 3 => -3,
- Default_Priority - 2 => -2,
- Default_Priority - 1 => -1,
- Default_Priority => 0,
- Default_Priority + 1 => 1,
- Default_Priority + 2 => 2,
- Default_Priority + 3 => 3,
- Default_Priority + 4 => 4,
- Default_Priority + 5 => 5,
- Default_Priority + 6 ..
- Priority'Last => 6,
- Interrupt_Priority => 15);
- -- The default mapping preserves the standard 31 priorities of the Ada
- -- model, but maps them using compression onto the 7 priority levels
- -- available in NT and on the 16 priority levels available in 2000/XP.
-
- -- To replace the default values of the Underlying_Priorities mapping,
- -- copy this source file into your build directory, edit the file to
- -- reflect your desired behavior, and recompile using Makefile.adalib
- -- which can be found under the adalib directory of your gnat installation
-
- pragma Linker_Options ("-Wl,--stack=0x2000000");
- -- This is used to change the default stack (32 MB) size for non tasking
- -- programs. We change this value for GNAT on Windows here because the
- -- binutils on this platform have switched to a too low value for Ada
- -- programs. Note that we also set the stack size for tasking programs in
- -- System.Task_Primitives.Operations.
-
-end System;
diff --git a/gcc/ada/system-mingw.ads b/gcc/ada/system-mingw.ads
index e70381a140..82b5d0cff9 100644
--- a/gcc/ada/system-mingw.ads
+++ b/gcc/ada/system-mingw.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (Windows Version) --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -69,8 +69,8 @@ package System is
Null_Address : constant Address;
Storage_Unit : constant := 8;
- Word_Size : constant := 32;
- Memory_Size : constant := 2 ** 32;
+ Word_Size : constant := Standard'Word_Size;
+ Memory_Size : constant := 2 ** Word_Size;
-- Address comparison
diff --git a/gcc/ada/system-rtems.ads b/gcc/ada/system-rtems.ads
index 664c228038..ce1ce2bda3 100644
--- a/gcc/ada/system-rtems.ads
+++ b/gcc/ada/system-rtems.ads
@@ -138,7 +138,7 @@ private
-- of the individual switch values.
Backend_Divide_Checks : constant Boolean := False;
- Backend_Overflow_Checks : constant Boolean := False;
+ Backend_Overflow_Checks : constant Boolean := True;
Command_Line_Args : constant Boolean := True;
Configurable_Run_Time : constant Boolean := False;
Denorm : constant Boolean := True;
@@ -153,12 +153,11 @@ private
Stack_Check_Default : constant Boolean := False;
Stack_Check_Probes : constant Boolean := False;
Stack_Check_Limits : constant Boolean := False;
- Support_64_Bit_Divides : constant Boolean := True;
Support_Aggregates : constant Boolean := True;
Support_Composite_Assign : constant Boolean := True;
Support_Composite_Compare : constant Boolean := True;
Support_Long_Shifts : constant Boolean := True;
- Always_Compatible_Rep : constant Boolean := True;
+ Always_Compatible_Rep : constant Boolean := False;
Suppress_Standard_Library : constant Boolean := False;
Use_Ada_Main_Program_Name : constant Boolean := False;
Frontend_Exceptions : constant Boolean := True;
diff --git a/gcc/ada/system-solaris-sparc.ads b/gcc/ada/system-solaris-sparc.ads
index 9073ebca55..79614aaa52 100644
--- a/gcc/ada/system-solaris-sparc.ads
+++ b/gcc/ada/system-solaris-sparc.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (SUN Solaris Version) --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -69,8 +69,8 @@ package System is
Null_Address : constant Address;
Storage_Unit : constant := 8;
- Word_Size : constant := 32;
- Memory_Size : constant := 2 ** 32;
+ Word_Size : constant := Standard'Word_Size;
+ Memory_Size : constant := 2 ** Word_Size;
-- Address comparison
@@ -135,6 +135,7 @@ private
Stack_Check_Probes : constant Boolean := True;
Stack_Check_Limits : constant Boolean := False;
Support_Aggregates : constant Boolean := True;
+ Support_Atomic_Primitives : constant Boolean := True;
Support_Composite_Assign : constant Boolean := True;
Support_Composite_Compare : constant Boolean := True;
Support_Long_Shifts : constant Boolean := True;
diff --git a/gcc/ada/system-solaris-sparcv9.ads b/gcc/ada/system-solaris-sparcv9.ads
deleted file mode 100644
index 1673979d7c..0000000000
--- a/gcc/ada/system-solaris-sparcv9.ads
+++ /dev/null
@@ -1,148 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M --
--- --
--- S p e c --
--- (Solaris Sparcv9 Version) --
--- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-package System is
- pragma Pure;
- -- Note that we take advantage of the implementation permission to make
- -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada
- -- 2005, this is Pure in any case (AI-362).
-
- pragma No_Elaboration_Code_All;
- -- Allow the use of that restriction in units that WITH this unit
-
- type Name is (SYSTEM_NAME_GNAT);
- System_Name : constant Name := SYSTEM_NAME_GNAT;
-
- -- System-Dependent Named Numbers
-
- Min_Int : constant := Long_Long_Integer'First;
- Max_Int : constant := Long_Long_Integer'Last;
-
- Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
- Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1;
-
- Max_Base_Digits : constant := Long_Long_Float'Digits;
- Max_Digits : constant := Long_Long_Float'Digits;
-
- Max_Mantissa : constant := 63;
- Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
-
- Tick : constant := 0.01;
-
- -- Storage-related Declarations
-
- type Address is private;
- pragma Preelaborable_Initialization (Address);
- Null_Address : constant Address;
-
- Storage_Unit : constant := 8;
- Word_Size : constant := 64;
- Memory_Size : constant := 2 ** 64;
-
- -- Address comparison
-
- function "<" (Left, Right : Address) return Boolean;
- function "<=" (Left, Right : Address) return Boolean;
- function ">" (Left, Right : Address) return Boolean;
- function ">=" (Left, Right : Address) return Boolean;
- function "=" (Left, Right : Address) return Boolean;
-
- pragma Import (Intrinsic, "<");
- pragma Import (Intrinsic, "<=");
- pragma Import (Intrinsic, ">");
- pragma Import (Intrinsic, ">=");
- pragma Import (Intrinsic, "=");
-
- -- Other System-Dependent Declarations
-
- type Bit_Order is (High_Order_First, Low_Order_First);
- Default_Bit_Order : constant Bit_Order := High_Order_First;
- pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning
-
- -- Priority-related Declarations (RM D.1)
-
- Max_Priority : constant Positive := 30;
- Max_Interrupt_Priority : constant Positive := 31;
-
- subtype Any_Priority is Integer range 0 .. 31;
- subtype Priority is Any_Priority range 0 .. 30;
- subtype Interrupt_Priority is Any_Priority range 31 .. 31;
-
- Default_Priority : constant Priority := 15;
-
-private
-
- type Address is mod Memory_Size;
- Null_Address : constant Address := 0;
-
- --------------------------------------
- -- System Implementation Parameters --
- --------------------------------------
-
- -- These parameters provide information about the target that is used
- -- by the compiler. They are in the private part of System, where they
- -- can be accessed using the special circuitry in the Targparm unit
- -- whose source should be consulted for more detailed descriptions
- -- of the individual switch values.
-
- Backend_Divide_Checks : constant Boolean := False;
- Backend_Overflow_Checks : constant Boolean := True;
- Command_Line_Args : constant Boolean := True;
- Configurable_Run_Time : constant Boolean := False;
- Denorm : constant Boolean := True;
- Duration_32_Bits : constant Boolean := False;
- Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
- Machine_Overflows : constant Boolean := False;
- Machine_Rounds : constant Boolean := True;
- Preallocated_Stacks : constant Boolean := False;
- Signed_Zeros : constant Boolean := True;
- Stack_Check_Default : constant Boolean := False;
- Stack_Check_Probes : constant Boolean := True;
- Stack_Check_Limits : constant Boolean := False;
- Support_Aggregates : constant Boolean := True;
- Support_Atomic_Primitives : constant Boolean := True;
- Support_Composite_Assign : constant Boolean := True;
- Support_Composite_Compare : constant Boolean := True;
- Support_Long_Shifts : constant Boolean := True;
- Always_Compatible_Rep : constant Boolean := False;
- Suppress_Standard_Library : constant Boolean := False;
- Use_Ada_Main_Program_Name : constant Boolean := False;
- Frontend_Exceptions : constant Boolean := False;
- ZCX_By_Default : constant Boolean := True;
-
-end System;
diff --git a/gcc/ada/system-solaris-x86.ads b/gcc/ada/system-solaris-x86.ads
index b2d5fdfa01..d598fe9fa4 100644
--- a/gcc/ada/system-solaris-x86.ads
+++ b/gcc/ada/system-solaris-x86.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (x86 Solaris Version) --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -69,8 +69,8 @@ package System is
Null_Address : constant Address;
Storage_Unit : constant := 8;
- Word_Size : constant := 32;
- Memory_Size : constant := 2 ** 32;
+ Word_Size : constant := Standard'Word_Size;
+ Memory_Size : constant := 2 ** Word_Size;
-- Address comparison
diff --git a/gcc/ada/system-solaris-x86_64.ads b/gcc/ada/system-solaris-x86_64.ads
deleted file mode 100644
index 33b293530a..0000000000
--- a/gcc/ada/system-solaris-x86_64.ads
+++ /dev/null
@@ -1,148 +0,0 @@
-------------------------------------------------------------------------------
--- --
--- GNAT RUN-TIME COMPONENTS --
--- --
--- S Y S T E M --
--- --
--- S p e c --
--- (x86-64 Solaris Version) --
--- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
--- --
--- This specification is derived from the Ada Reference Manual for use with --
--- GNAT. The copyright notice above, and the license provisions that follow --
--- apply solely to the contents of the part following the private keyword. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 3, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. --
--- --
--- As a special exception under Section 7 of GPL version 3, you are granted --
--- additional permissions described in the GCC Runtime Library Exception, --
--- version 3.1, as published by the Free Software Foundation. --
--- --
--- You should have received a copy of the GNU General Public License and --
--- a copy of the GCC Runtime Library Exception along with this program; --
--- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
--- <http://www.gnu.org/licenses/>. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-package System is
- pragma Pure;
- -- Note that we take advantage of the implementation permission to make
- -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada
- -- 2005, this is Pure in any case (AI-362).
-
- pragma No_Elaboration_Code_All;
- -- Allow the use of that restriction in units that WITH this unit
-
- type Name is (SYSTEM_NAME_GNAT);
- System_Name : constant Name := SYSTEM_NAME_GNAT;
-
- -- System-Dependent Named Numbers
-
- Min_Int : constant := Long_Long_Integer'First;
- Max_Int : constant := Long_Long_Integer'Last;
-
- Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size;
- Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1;
-
- Max_Base_Digits : constant := Long_Long_Float'Digits;
- Max_Digits : constant := Long_Long_Float'Digits;
-
- Max_Mantissa : constant := 63;
- Fine_Delta : constant := 2.0 ** (-Max_Mantissa);
-
- Tick : constant := 0.01;
-
- -- Storage-related Declarations
-
- type Address is private;
- pragma Preelaborable_Initialization (Address);
- Null_Address : constant Address;
-
- Storage_Unit : constant := 8;
- Word_Size : constant := 64;
- Memory_Size : constant := 2 ** 64;
-
- -- Address comparison
-
- function "<" (Left, Right : Address) return Boolean;
- function "<=" (Left, Right : Address) return Boolean;
- function ">" (Left, Right : Address) return Boolean;
- function ">=" (Left, Right : Address) return Boolean;
- function "=" (Left, Right : Address) return Boolean;
-
- pragma Import (Intrinsic, "<");
- pragma Import (Intrinsic, "<=");
- pragma Import (Intrinsic, ">");
- pragma Import (Intrinsic, ">=");
- pragma Import (Intrinsic, "=");
-
- -- Other System-Dependent Declarations
-
- type Bit_Order is (High_Order_First, Low_Order_First);
- Default_Bit_Order : constant Bit_Order := Low_Order_First;
- pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning
-
- -- Priority-related Declarations (RM D.1)
-
- Max_Priority : constant Positive := 30;
- Max_Interrupt_Priority : constant Positive := 31;
-
- subtype Any_Priority is Integer range 0 .. 31;
- subtype Priority is Any_Priority range 0 .. 30;
- subtype Interrupt_Priority is Any_Priority range 31 .. 31;
-
- Default_Priority : constant Priority := 15;
-
-private
-
- type Address is mod Memory_Size;
- Null_Address : constant Address := 0;
-
- --------------------------------------
- -- System Implementation Parameters --
- --------------------------------------
-
- -- These parameters provide information about the target that is used
- -- by the compiler. They are in the private part of System, where they
- -- can be accessed using the special circuitry in the Targparm unit
- -- whose source should be consulted for more detailed descriptions
- -- of the individual switch values.
-
- Backend_Divide_Checks : constant Boolean := False;
- Backend_Overflow_Checks : constant Boolean := True;
- Command_Line_Args : constant Boolean := True;
- Configurable_Run_Time : constant Boolean := False;
- Denorm : constant Boolean := True;
- Duration_32_Bits : constant Boolean := False;
- Exit_Status_Supported : constant Boolean := True;
- Fractional_Fixed_Ops : constant Boolean := False;
- Frontend_Layout : constant Boolean := False;
- Machine_Overflows : constant Boolean := False;
- Machine_Rounds : constant Boolean := True;
- Preallocated_Stacks : constant Boolean := False;
- Signed_Zeros : constant Boolean := True;
- Stack_Check_Default : constant Boolean := False;
- Stack_Check_Probes : constant Boolean := True;
- Stack_Check_Limits : constant Boolean := False;
- Support_Aggregates : constant Boolean := True;
- Support_Atomic_Primitives : constant Boolean := True;
- Support_Composite_Assign : constant Boolean := True;
- Support_Composite_Compare : constant Boolean := True;
- Support_Long_Shifts : constant Boolean := True;
- Always_Compatible_Rep : constant Boolean := False;
- Suppress_Standard_Library : constant Boolean := False;
- Use_Ada_Main_Program_Name : constant Boolean := False;
- Frontend_Exceptions : constant Boolean := False;
- ZCX_By_Default : constant Boolean := True;
-
-end System;
diff --git a/gcc/ada/system-vxworks-arm.ads b/gcc/ada/system-vxworks-arm.ads
index c3b429f9cb..2b1fb8e9e4 100644
--- a/gcc/ada/system-vxworks-arm.ads
+++ b/gcc/ada/system-vxworks-arm.ads
@@ -7,7 +7,7 @@
-- S p e c --
-- (VxWorks Version ARM) --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@@ -118,7 +118,7 @@ package System is
private
- pragma Linker_Options ("--specs=vxworks-crtbe-link.spec");
+ pragma Linker_Options ("--specs=vxworks-gnat-crtbe-link.spec");
-- Pull in crtbegin/crtend objects and register exceptions for ZCX.
-- This is commented out by our Makefile for SJLJ runtimes.
@@ -161,4 +161,6 @@ private
Frontend_Exceptions : constant Boolean := False;
ZCX_By_Default : constant Boolean := True;
+ Executable_Extension : constant String := ".out";
+
end System;
diff --git a/gcc/ada/system-vxworks-m68k.ads b/gcc/ada/system-vxworks-m68k.ads
index ca59e7a9d9..1fab781a7d 100644
--- a/gcc/ada/system-vxworks-m68k.ads
+++ b/gcc/ada/system-vxworks-m68k.ads
@@ -157,4 +157,6 @@ private
Frontend_Exceptions : constant Boolean := True;
ZCX_By_Default : constant Boolean := False;
+ Executable_Extension : constant String := ".out";
+
end System;
diff --git a/gcc/ada/system-vxworks-mips.ads b/gcc/ada/system-vxworks-mips.ads
index d4860f42da..5cba6cd932 100644
--- a/gcc/ada/system-vxworks-mips.ads
+++ b/gcc/ada/system-vxworks-mips.ads
@@ -157,4 +157,6 @@ private
Frontend_Exceptions : constant Boolean := True;
ZCX_By_Default : constant Boolean := False;
+ Executable_Extension : constant String := ".out";
+
end System;
diff --git a/gcc/ada/system-vxworks-ppc.ads b/gcc/ada/system-vxworks-ppc.ads
index bb27ee4b99..37b7d1db8f 100644
--- a/gcc/ada/system-vxworks-ppc.ads
+++ b/gcc/ada/system-vxworks-ppc.ads
@@ -118,7 +118,7 @@ package System is
private
- pragma Linker_Options ("--specs=vxworks-crtbe-link.spec");
+ pragma Linker_Options ("--specs=vxworks-gnat-crtbe-link.spec");
-- Pull in crtbegin/crtend objects and register exceptions for ZCX.
-- This is commented out by our Makefile for SJLJ runtimes.
@@ -164,4 +164,6 @@ private
Frontend_Exceptions : constant Boolean := True;
ZCX_By_Default : constant Boolean := False;
+ Executable_Extension : constant String := ".out";
+
end System;
diff --git a/gcc/ada/system-vxworks-sparcv9.ads b/gcc/ada/system-vxworks-sparcv9.ads
index f3caca4fea..a7c0b5a0a4 100644
--- a/gcc/ada/system-vxworks-sparcv9.ads
+++ b/gcc/ada/system-vxworks-sparcv9.ads
@@ -159,4 +159,6 @@ private
Frontend_Exceptions : constant Boolean := True;
ZCX_By_Default : constant Boolean := False;
+ Executable_Extension : constant String := ".out";
+
end System;
diff --git a/gcc/ada/system-vxworks-x86.ads b/gcc/ada/system-vxworks-x86.ads
index a7508aadfa..22f42f3c6d 100644
--- a/gcc/ada/system-vxworks-x86.ads
+++ b/gcc/ada/system-vxworks-x86.ads
@@ -161,4 +161,6 @@ private
Frontend_Exceptions : constant Boolean := True;
ZCX_By_Default : constant Boolean := False;
+ Executable_Extension : constant String := ".out";
+
end System;
diff --git a/gcc/ada/table.adb b/gcc/ada/table.adb
index 4c745393b2..2c7eb0c4a6 100644
--- a/gcc/ada/table.adb
+++ b/gcc/ada/table.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -207,9 +207,11 @@ package body Table is
end if;
end if;
+ -- Do the intermediate calculation in size_t to avoid signed overflow
+
New_Size :=
- Memory.size_t ((Max - Min + 1) *
- (Table_Type'Component_Size / Storage_Unit));
+ Memory.size_t (Max - Min + 1) *
+ (Table_Type'Component_Size / Storage_Unit);
if Table = null then
Table := To_Pointer (Alloc (New_Size));
@@ -227,7 +229,6 @@ package body Table is
Set_Standard_Output;
raise Unrecoverable_Error;
end if;
-
end Reallocate;
-------------
@@ -235,9 +236,36 @@ package body Table is
-------------
procedure Release is
+ Extra_Length : Int;
+ Size : Memory.size_t;
+
begin
Length := Last_Val - Int (Table_Low_Bound) + 1;
- Max := Last_Val;
+ Size := Memory.size_t (Length) *
+ (Table_Type'Component_Size / Storage_Unit);
+
+ -- If the size of the table exceeds the release threshold then leave
+ -- space to store as many extra elements as 0.1% of the table length.
+
+ if Release_Threshold > 0
+ and then Size > Memory.size_t (Release_Threshold)
+ then
+ Extra_Length := Length / 1000;
+ Length := Length + Extra_Length;
+ Max := Int (Table_Low_Bound) + Length - 1;
+
+ if Debug_Flag_D then
+ Write_Str ("--> Release_Threshold reached (length=");
+ Write_Int (Int (Size));
+ Write_Str ("): leaving room space for ");
+ Write_Int (Extra_Length);
+ Write_Str (" components");
+ Write_Eol;
+ end if;
+ else
+ Max := Last_Val;
+ end if;
+
Reallocate;
end Release;
diff --git a/gcc/ada/table.ads b/gcc/ada/table.ads
index 4788016738..29b6fb009b 100644
--- a/gcc/ada/table.ads
+++ b/gcc/ada/table.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -47,10 +47,11 @@ package Table is
type Table_Component_Type is private;
type Table_Index_Type is range <>;
- Table_Low_Bound : Table_Index_Type;
- Table_Initial : Pos;
- Table_Increment : Nat;
- Table_Name : String;
+ Table_Low_Bound : Table_Index_Type;
+ Table_Initial : Pos;
+ Table_Increment : Nat;
+ Table_Name : String;
+ Release_Threshold : Nat := 0;
package Table is
@@ -151,9 +152,15 @@ package Table is
procedure Release;
-- Storage is allocated in chunks according to the values given in the
- -- Initial and Increment parameters. A call to Release releases all
- -- storage that is allocated, but is not logically part of the current
- -- array value. Current array values are not affected by this call.
+ -- Initial and Increment parameters. If Release_Threshold is 0 or the
+ -- length of the table does not exceed this threshold then a call to
+ -- Release releases all storage that is allocated, but is not logically
+ -- part of the current array value; otherwise the call to Release leaves
+ -- the current array value plus 0.1% of the current table length free
+ -- elements located at the end of the table (this parameter facilitates
+ -- reopening large tables and adding a few elements without allocating a
+ -- chunk of memory). In both cases current array values are not affected
+ -- by this call.
procedure Free;
-- Free all allocated memory for the table. A call to init is required
@@ -214,8 +221,8 @@ package Table is
-- Writes out contents of table using Tree_IO
procedure Tree_Read;
- -- Initializes table by reading contents previously written
- -- with the Tree_Write call (also using Tree_IO)
+ -- Initializes table by reading contents previously written with the
+ -- Tree_Write call (also using Tree_IO).
private
diff --git a/gcc/ada/targparm.ads b/gcc/ada/targparm.ads
index af2177d0f5..9964425baf 100644
--- a/gcc/ada/targparm.ads
+++ b/gcc/ada/targparm.ads
@@ -261,7 +261,7 @@ package Targparm is
-- Back-End Setjmp/Longjmp Exceptions
-- With this approach, the back end also handles the generation and
- -- handling of exceptions, using setjmp/longjmp to setup receivers and
+ -- handling of exceptions, using setjmp/longjmp to set up receivers and
-- propagate. AT-END actions on exceptional paths are also taken care
-- of by the back end and the front end doesn't need to generate
-- explicit exception handlers for these.
@@ -271,7 +271,7 @@ package Targparm is
-- The following switches specify whether we're using a front-end or a
-- back-end mechanism and whether this is a zero-cost or a sjlj scheme.
- -- The per switch default values correspond to the default value of
+ -- The per-switch default values correspond to the default value of
-- Opt.Exception_Mechanism.
ZCX_By_Default_On_Target : Boolean := False;
diff --git a/gcc/ada/terminals.c b/gcc/ada/terminals.c
index d72eb09885..35cd7430bb 100644
--- a/gcc/ada/terminals.c
+++ b/gcc/ada/terminals.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2008-2015, AdaCore *
+ * Copyright (C) 2008-2016, AdaCore *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -32,7 +32,7 @@
/* First all usupported platforms. Add stubs for exported routines. */
#if defined (VMS) || defined (__vxworks) || defined (__Lynx__) \
- || defined (__ANDROID__) || defined (__PikeOS__)
+ || defined (__ANDROID__) || defined (__PikeOS__) || defined(__DJGPP__)
#define ATTRIBUTE_UNUSED __attribute__((unused))
@@ -289,34 +289,27 @@ is_gui_app (char *exe)
{
case IMAGE_SUBSYSTEM_UNKNOWN:
return 1;
- break;
case IMAGE_SUBSYSTEM_NATIVE:
return 1;
- break;
case IMAGE_SUBSYSTEM_WINDOWS_GUI:
return 1;
- break;
case IMAGE_SUBSYSTEM_WINDOWS_CUI:
return 0;
- break;
case IMAGE_SUBSYSTEM_OS2_CUI:
return 0;
- break;
case IMAGE_SUBSYSTEM_POSIX_CUI:
return 0;
- break;
default:
/* Unknown, return GUI app to be preservative: if yes, it will be
correctly launched, if no, it will be launched, and a console will
be also displayed, which is not a big deal */
return 1;
- break;
}
}
@@ -1417,7 +1410,8 @@ __gnat_setup_child_communication
#ifdef TIOCSCTTY
/* make the tty the controlling terminal */
- status = ioctl (desc->slave_fd, TIOCSCTTY, 0);
+ if ((status = ioctl (desc->slave_fd, TIOCSCTTY, 0)) == -1)
+ return -1;
#endif
/* adjust tty settings */
@@ -1431,8 +1425,10 @@ __gnat_setup_child_communication
if (desc->slave_fd > 2) close (desc->slave_fd);
/* adjust process group settings */
- status = setpgid (pid, pid);
- status = tcsetpgrp (0, pid);
+ /* ignore failures of the following two commands as the context might not
+ * allow making those changes. */
+ setpgid (pid, pid);
+ tcsetpgrp (0, pid);
/* launch the program */
execvp (new_argv[0], new_argv);
@@ -1569,9 +1565,9 @@ pty_desc *
__gnat_new_tty (void)
{
int status;
- pty_desc* desc;
- status = allocate_pty_desc (&desc);
- child_setup_tty (desc->master_fd);
+ pty_desc* desc = NULL;
+ if ((status = allocate_pty_desc (&desc)))
+ child_setup_tty (desc->master_fd);
return desc;
}
diff --git a/gcc/ada/tracebak.c b/gcc/ada/tracebak.c
index ff85ca5baf..7532ca2d71 100644
--- a/gcc/ada/tracebak.c
+++ b/gcc/ada/tracebak.c
@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
- * Copyright (C) 2000-2015, Free Software Foundation, Inc. *
+ * Copyright (C) 2000-2016, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -99,6 +99,8 @@ extern void (*Unlock_Task) (void);
#include <windows.h>
+#define IS_BAD_PTR(ptr) (IsBadCodePtr((FARPROC)ptr))
+
int
__gnat_backtrace (void **array,
int size,
@@ -137,6 +139,10 @@ __gnat_backtrace (void **array,
}
else
{
+ /* If the last unwinding step failed somehow, stop here. */
+ if (IS_BAD_PTR(context.Rip))
+ break;
+
/* Unwind. */
memset (&NvContext, 0, sizeof (KNONVOLATILE_CONTEXT_POINTERS));
RtlVirtualUnwind (0, ImageBase, context.Rip, RuntimeFunction,
@@ -294,7 +300,20 @@ __gnat_backtrace (void **array,
#define PC_ADJUST -2
/* The minimum size of call instructions on this architecture is 2 bytes */
-/*---------------------- PPC AIX/PPC Lynx 178/Older Darwin ------------------*/
+/*---------------------- ARM VxWorks ------------------------------------*/
+#elif (defined (ARMEL) && defined (__vxworks))
+
+#include "vxWorks.h"
+#include "version.h"
+
+#define USE_GCC_UNWINDER
+#define PC_ADJUST -2
+
+#if (_WRS_VXWORKS_MAJOR >= 7)
+#define USING_ARM_UNWINDING 1
+#endif
+
+/*---------------------- PPC AIX/PPC Lynx 178/Older Darwin --------------*/
#elif ((defined (_POWER) && defined (_AIX)) || \
(defined (__powerpc__) && defined (__Lynx__) && !defined(__ELF__)) || \
(defined (__ppc__) && defined (__APPLE__)))
@@ -348,9 +367,10 @@ extern void __runnit(); /* thread entry point. */
#define BASE_SKIP 1
-/*-------------------- PPC ELF (GNU/Linux & VxWorks) ---------------------*/
+/*----------- PPC ELF (GNU/Linux & VxWorks & Lynx178e) -------------------*/
#elif (defined (_ARCH_PPC) && defined (__vxworks)) || \
+ (defined (__powerpc__) && defined (__Lynx__) && defined(__ELF__)) || \
(defined (__linux__) && defined (__powerpc__))
#define USE_GENERIC_UNWINDER
@@ -511,6 +531,12 @@ struct layout
The condition is expressed the way above because we cannot reliably rely on
any other macro from the base compiler when compiling stage1. */
+#ifdef USING_ARM_UNWINDING
+/* This value is not part of the enumerated reason codes defined in unwind.h
+ for ARM style unwinding, but is used in the included "C" code, so we
+ define it to a reasonable value to avoid a compilation error. */
+#define _URC_NORMAL_STOP 0
+#endif
#include "tb-gcc.c"
/*------------------------------------------------------------------*
diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb
index a032416587..7c1f1b7d93 100644
--- a/gcc/ada/treepr.adb
+++ b/gcc/ada/treepr.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -126,10 +126,10 @@ package body Treepr is
-- value of the field.
procedure Print_Init;
- -- Initialize for printing of tree with descendents
+ -- Initialize for printing of tree with descendants
procedure Print_Term;
- -- Clean up after printing of tree with descendents
+ -- Clean up after printing of tree with descendants
procedure Print_Char (C : Character);
-- Print character C if currently in print phase, noop if in marking phase
@@ -202,17 +202,17 @@ package body Treepr is
(N : Node_Id;
Prefix_Str : String;
Prefix_Char : Character);
- -- Called to process a single node in the case where descendents are to
+ -- Called to process a single node in the case where descendants are to
-- be printed before every line, and Prefix_Char added to all lines
-- except the header line for the node.
procedure Visit_List (L : List_Id; Prefix_Str : String);
- -- Visit_List is called to process a list in the case where descendents
+ -- Visit_List is called to process a list in the case where descendants
-- are to be printed. Prefix_Str is to be added to all printed lines.
procedure Visit_Elist (E : Elist_Id; Prefix_Str : String);
-- Visit_Elist is called to process an element list in the case where
- -- descendents are to be printed. Prefix_Str is to be added to all
+ -- descendants are to be printed. Prefix_Str is to be added to all
-- printed lines.
-------
@@ -603,13 +603,13 @@ package body Treepr is
begin
case M is
- when Default_Mechanism =>
+ when Default_Mechanism =>
Write_Str ("Default");
- when By_Copy =>
+ when By_Copy =>
Write_Str ("By_Copy");
- when By_Reference =>
+ when By_Reference =>
Write_Str ("By_Reference");
when 1 .. Mechanism_Type'Last =>
@@ -1200,8 +1200,8 @@ package body Treepr is
F := Pchars (P);
P := P + 1;
- -- Check for case of False flag, which we never print, or
- -- an Empty field, which is also never printed
+ -- Check for case of False flag, which we never print, or an Empty
+ -- field, which is also never printed.
case F is
when F_Field1 =>
@@ -1268,24 +1268,24 @@ package body Treepr is
Print_Field (Field5 (N), Fmt);
end if;
- when F_Flag1 => Print_Flag (Flag1 (N));
- when F_Flag2 => Print_Flag (Flag2 (N));
- when F_Flag3 => Print_Flag (Flag3 (N));
- when F_Flag4 => Print_Flag (Flag4 (N));
- when F_Flag5 => Print_Flag (Flag5 (N));
- when F_Flag6 => Print_Flag (Flag6 (N));
- when F_Flag7 => Print_Flag (Flag7 (N));
- when F_Flag8 => Print_Flag (Flag8 (N));
- when F_Flag9 => Print_Flag (Flag9 (N));
- when F_Flag10 => Print_Flag (Flag10 (N));
- when F_Flag11 => Print_Flag (Flag11 (N));
- when F_Flag12 => Print_Flag (Flag12 (N));
- when F_Flag13 => Print_Flag (Flag13 (N));
- when F_Flag14 => Print_Flag (Flag14 (N));
- when F_Flag15 => Print_Flag (Flag15 (N));
- when F_Flag16 => Print_Flag (Flag16 (N));
- when F_Flag17 => Print_Flag (Flag17 (N));
- when F_Flag18 => Print_Flag (Flag18 (N));
+ when F_Flag1 => Print_Flag (Flag1 (N));
+ when F_Flag2 => Print_Flag (Flag2 (N));
+ when F_Flag3 => Print_Flag (Flag3 (N));
+ when F_Flag4 => Print_Flag (Flag4 (N));
+ when F_Flag5 => Print_Flag (Flag5 (N));
+ when F_Flag6 => Print_Flag (Flag6 (N));
+ when F_Flag7 => Print_Flag (Flag7 (N));
+ when F_Flag8 => Print_Flag (Flag8 (N));
+ when F_Flag9 => Print_Flag (Flag9 (N));
+ when F_Flag10 => Print_Flag (Flag10 (N));
+ when F_Flag11 => Print_Flag (Flag11 (N));
+ when F_Flag12 => Print_Flag (Flag12 (N));
+ when F_Flag13 => Print_Flag (Flag13 (N));
+ when F_Flag14 => Print_Flag (Flag14 (N));
+ when F_Flag15 => Print_Flag (Flag15 (N));
+ when F_Flag16 => Print_Flag (Flag16 (N));
+ when F_Flag17 => Print_Flag (Flag17 (N));
+ when F_Flag18 => Print_Flag (Flag18 (N));
end case;
Print_Eol;
@@ -1637,10 +1637,13 @@ package body Treepr is
case N is
when List_Low_Bound .. List_High_Bound - 1 =>
Print_List_Subtree (List_Id (N));
+
when Node_Range =>
Print_Node_Subtree (Node_Id (N));
+
when Elist_Range =>
Print_Elist_Subtree (Elist_Id (N));
+
when others =>
pp (N);
end case;
@@ -1684,7 +1687,6 @@ package body Treepr is
Hash_Slot := H;
Hash_Table (H).Id := Id;
return 0;
-
end Serial_Number;
-----------------------
@@ -1894,7 +1896,7 @@ package body Treepr is
New_Prefix : String (Prefix_Str'First .. Prefix_Str'Last + 2);
-- Prefix string for printing referenced fields
- procedure Visit_Descendent
+ procedure Visit_Descendant
(D : Union_Id;
No_Indent : Boolean := False);
-- This procedure tests the given value of one of the Fields referenced
@@ -1902,23 +1904,23 @@ package body Treepr is
-- Normally No_Indent is false, which means that the visited node will
-- be indented using New_Prefix. If No_Indent is set to True, then
-- this indentation is skipped, and Prefix_Str is used for the call
- -- to print the descendent. No_Indent is effective only if the
- -- referenced descendent is a node.
+ -- to print the descendant. No_Indent is effective only if the
+ -- referenced descendant is a node.
----------------------
- -- Visit_Descendent --
+ -- Visit_Descendant --
----------------------
- procedure Visit_Descendent
+ procedure Visit_Descendant
(D : Union_Id;
No_Indent : Boolean := False)
is
begin
- -- Case of descendent is a node
+ -- Case of descendant is a node
if D in Node_Range then
- -- Don't bother about Empty or Error descendents
+ -- Don't bother about Empty or Error descendants
if D <= Union_Id (Empty_Or_Error) then
return;
@@ -1928,7 +1930,7 @@ package body Treepr is
Nod : constant Node_Or_Entity_Id := Node_Or_Entity_Id (D);
begin
- -- Descendents in one of the standardly compiled internal
+ -- Descendants in one of the standardly compiled internal
-- packages are normally ignored, unless the parent is also
-- in such a package (happens when Standard itself is output)
-- or if the -df switch is set which causes all links to be
@@ -1941,7 +1943,7 @@ package body Treepr is
return;
end if;
- -- Don't bother about a descendent in a different unit than
+ -- Don't bother about a descendant in a different unit than
-- the node we came from unless the -df switch is set. Note
-- that we know at this point that Sloc (D) > Standard_Location
@@ -1992,14 +1994,16 @@ package body Treepr is
end if;
end;
- -- Case of descendent is a list
+ -- Case of descendant is a list
elsif D in List_Range then
-- Don't bother with a missing list, empty list or error list
- if D = Union_Id (No_List)
- or else D = Union_Id (Error_List)
+ pragma Assert (D /= Union_Id (No_List));
+ -- Because No_List = Empty, which is in Node_Range above
+
+ if D = Union_Id (Error_List)
or else Is_Empty_List (List_Id (D))
then
return;
@@ -2016,7 +2020,7 @@ package body Treepr is
Visit_List (List_Id (D), New_Prefix);
end if;
- -- Case of descendent is an element list
+ -- Case of descendant is an element list
elsif D in Elist_Range then
@@ -2033,15 +2037,15 @@ package body Treepr is
Visit_Elist (Elist_Id (D), New_Prefix);
end if;
- -- For all other kinds of descendents (strings, names, uints etc),
+ -- For all other kinds of descendants (strings, names, uints etc),
-- there is nothing to visit (the contents of the field will be
-- printed when we print the containing node, but what concerns
- -- us now is looking for descendents in the tree.
+ -- us now is looking for descendants in the tree.
else
null;
end if;
- end Visit_Descendent;
+ end Visit_Descendant;
-- Start of processing for Visit_Node
@@ -2100,44 +2104,44 @@ package body Treepr is
end if;
end if;
- -- Visit all descendents of this node
+ -- Visit all descendants of this node
if Nkind (N) not in N_Entity then
- Visit_Descendent (Field1 (N));
- Visit_Descendent (Field2 (N));
- Visit_Descendent (Field3 (N));
- Visit_Descendent (Field4 (N));
- Visit_Descendent (Field5 (N));
+ Visit_Descendant (Field1 (N));
+ Visit_Descendant (Field2 (N));
+ Visit_Descendant (Field3 (N));
+ Visit_Descendant (Field4 (N));
+ Visit_Descendant (Field5 (N));
if Has_Aspects (N) then
- Visit_Descendent (Union_Id (Aspect_Specifications (N)));
+ Visit_Descendant (Union_Id (Aspect_Specifications (N)));
end if;
-- Entity case
else
- Visit_Descendent (Field1 (N));
- Visit_Descendent (Field3 (N));
- Visit_Descendent (Field4 (N));
- Visit_Descendent (Field5 (N));
- Visit_Descendent (Field6 (N));
- Visit_Descendent (Field7 (N));
- Visit_Descendent (Field8 (N));
- Visit_Descendent (Field9 (N));
- Visit_Descendent (Field10 (N));
- Visit_Descendent (Field11 (N));
- Visit_Descendent (Field12 (N));
- Visit_Descendent (Field13 (N));
- Visit_Descendent (Field14 (N));
- Visit_Descendent (Field15 (N));
- Visit_Descendent (Field16 (N));
- Visit_Descendent (Field17 (N));
- Visit_Descendent (Field18 (N));
- Visit_Descendent (Field19 (N));
- Visit_Descendent (Field20 (N));
- Visit_Descendent (Field21 (N));
- Visit_Descendent (Field22 (N));
- Visit_Descendent (Field23 (N));
+ Visit_Descendant (Field1 (N));
+ Visit_Descendant (Field3 (N));
+ Visit_Descendant (Field4 (N));
+ Visit_Descendant (Field5 (N));
+ Visit_Descendant (Field6 (N));
+ Visit_Descendant (Field7 (N));
+ Visit_Descendant (Field8 (N));
+ Visit_Descendant (Field9 (N));
+ Visit_Descendant (Field10 (N));
+ Visit_Descendant (Field11 (N));
+ Visit_Descendant (Field12 (N));
+ Visit_Descendant (Field13 (N));
+ Visit_Descendant (Field14 (N));
+ Visit_Descendant (Field15 (N));
+ Visit_Descendant (Field16 (N));
+ Visit_Descendant (Field17 (N));
+ Visit_Descendant (Field18 (N));
+ Visit_Descendant (Field19 (N));
+ Visit_Descendant (Field20 (N));
+ Visit_Descendant (Field21 (N));
+ Visit_Descendant (Field22 (N));
+ Visit_Descendant (Field23 (N));
-- Now an interesting special case. Normally parents are always
-- printed since we traverse the tree in a downwards direction.
@@ -2146,7 +2150,7 @@ package body Treepr is
-- referenced elsewhere in the tree. The following catches this case.
if not Comes_From_Source (N) then
- Visit_Descendent (Union_Id (Parent (N)));
+ Visit_Descendant (Union_Id (Parent (N)));
end if;
-- You may be wondering why we omitted Field2 above. The answer
@@ -2171,7 +2175,7 @@ package body Treepr is
begin
Nod := N;
while Present (Nod) loop
- Visit_Descendent (Union_Id (Next_Entity (Nod)));
+ Visit_Descendant (Union_Id (Next_Entity (Nod)));
Nod := Next_Entity (Nod);
end loop;
end;
diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads
index 10756075bf..20093c19ab 100644
--- a/gcc/ada/types.ads
+++ b/gcc/ada/types.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -554,7 +554,7 @@ package Types is
-- Types used for Library Management --
---------------------------------------
- type Unit_Number_Type is new Int;
+ type Unit_Number_Type is new Int range -1 .. Int'Last;
-- Unit number. The main source is unit 0, and subsidiary sources have
-- non-zero numbers starting with 1. Unit numbers are used to index the
-- Units table in package Lib.
diff --git a/gcc/ada/types.h b/gcc/ada/types.h
index 949065c2c8..c207235ed7 100644
--- a/gcc/ada/types.h
+++ b/gcc/ada/types.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2014, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2016, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -351,9 +351,6 @@ typedef Int Mechanism_Type;
#define By_Short_Descriptor_NCA (-18)
#define By_Short_Descriptor_Last (-18)
-/* Internal to Gigi. */
-#define By_Copy_Return (-128)
-
/* Definitions of Reason codes for Raise_xxx_Error nodes */
#define CE_Access_Check_Failed 0
#define CE_Access_Parameter_Is_Null 1
diff --git a/gcc/ada/uintp.adb b/gcc/ada/uintp.adb
index 948c521b22..6fdf02fdfe 100644
--- a/gcc/ada/uintp.adb
+++ b/gcc/ada/uintp.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -2229,9 +2229,12 @@ package body Uintp is
begin
-- Uints of more than one digit could be outside the range for
-- Ints. Caller should have checked for this if not certain.
- -- Fatal error to attempt to convert from value outside Int'Range.
+ -- Constraint_Error to attempt to convert from value outside
+ -- Int'Range.
- pragma Assert (UI_Is_In_Int_Range (Input));
+ if not UI_Is_In_Int_Range (Input) then
+ raise Constraint_Error;
+ end if;
-- Otherwise, proceed ahead, we are OK
diff --git a/gcc/ada/uintp.ads b/gcc/ada/uintp.ads
index 1d90524b9a..999fb0f95a 100644
--- a/gcc/ada/uintp.ads
+++ b/gcc/ada/uintp.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -252,12 +252,12 @@ package Uintp is
-- Converts Char_Code value to universal integer form
function UI_To_Int (Input : Uint) return Int;
- -- Converts universal integer value to Int. Fatal error if value is not in
- -- appropriate range.
+ -- Converts universal integer value to Int. Constraint_Error if value is
+ -- not in appropriate range.
function UI_To_CC (Input : Uint) return Char_Code;
- -- Converts universal integer value to Char_Code. Fatal error if value is
- -- not in Char_Code range.
+ -- Converts universal integer value to Char_Code. Constraint_Error if value
+ -- is not in Char_Code range.
function Num_Bits (Input : Uint) return Nat;
-- Approximate number of binary bits in given universal integer. This
@@ -431,7 +431,7 @@ private
-- Base is defined to allow efficient execution of the primitive operations
-- (a0, b0, c0) defined in the section "The Classical Algorithms"
- -- (sec. 4.3.1) of Donald Knuth's "The Art of Computer Programming",
+ -- (sec. 4.3.1) of Donald Knuth's "The Art of Computer Programming",
-- Vol. 2. These algorithms are used in this package. In particular,
-- the product of two single digits in this base fits in a 32-bit integer.
diff --git a/gcc/ada/uintp.h b/gcc/ada/uintp.h
index 1f4e7a3e7b..fafa13903b 100644
--- a/gcc/ada/uintp.h
+++ b/gcc/ada/uintp.h
@@ -6,7 +6,7 @@
* *
* C Header File *
* *
- * Copyright (C) 1992-2014, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2016, Free Software Foundation, Inc. *
* *
* GNAT is free software; you can redistribute it and/or modify it under *
* terms of the GNU General Public License as published by the Free Soft- *
@@ -64,6 +64,10 @@ extern Uint UI_From_Int (int);
/* Similarly, but take a GCC INTEGER_CST. */
extern Uint UI_From_gnu (tree);
+/* A constant value indicating a missing or unset Uint value. */
+#define UI_No_Uint uintp__no_uint
+extern const Uint UI_No_Uint;
+
/* Uint values are represented as multiple precision integers stored in a
multi-digit format using UI_Base as the base. This value is chosen so
that the product UI_Base*UI_Base is within the range of Int values. */
diff --git a/gcc/ada/uname.adb b/gcc/ada/uname.adb
index e0a1e724db..c879cbbdee 100644
--- a/gcc/ada/uname.adb
+++ b/gcc/ada/uname.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -234,85 +234,89 @@ package body Uname is
else
case Kind is
-
- when N_Identifier |
- N_Defining_Identifier |
- N_Defining_Operator_Symbol =>
-
+ when N_Defining_Identifier
+ | N_Defining_Operator_Symbol
+ | N_Identifier
+ =>
-- Note: it is of course an error to have a defining
-- operator symbol at this point, but this is not where
-- the error is signalled, so we handle it nicely here.
Add_Name (Chars (Node));
- when N_Defining_Program_Unit_Name =>
+ when N_Defining_Program_Unit_Name =>
Add_Node_Name (Name (Node));
Add_Char ('.');
Add_Node_Name (Defining_Identifier (Node));
- when N_Selected_Component |
- N_Expanded_Name =>
+ when N_Expanded_Name
+ | N_Selected_Component
+ =>
Add_Node_Name (Prefix (Node));
Add_Char ('.');
Add_Node_Name (Selector_Name (Node));
- when N_Subprogram_Specification |
- N_Package_Specification =>
+ when N_Package_Specification
+ | N_Subprogram_Specification
+ =>
Add_Node_Name (Defining_Unit_Name (Node));
- when N_Subprogram_Body |
- N_Subprogram_Declaration |
- N_Package_Declaration |
- N_Generic_Declaration =>
+ when N_Generic_Declaration
+ | N_Package_Declaration
+ | N_Subprogram_Body
+ | N_Subprogram_Declaration
+ =>
Add_Node_Name (Specification (Node));
- when N_Generic_Instantiation =>
+ when N_Generic_Instantiation =>
Add_Node_Name (Defining_Unit_Name (Node));
- when N_Package_Body =>
+ when N_Package_Body =>
Add_Node_Name (Defining_Unit_Name (Node));
- when N_Task_Body |
- N_Protected_Body =>
+ when N_Protected_Body
+ | N_Task_Body
+ =>
Add_Node_Name (Defining_Identifier (Node));
- when N_Package_Renaming_Declaration =>
+ when N_Package_Renaming_Declaration =>
Add_Node_Name (Defining_Unit_Name (Node));
when N_Subprogram_Renaming_Declaration =>
Add_Node_Name (Specification (Node));
- when N_Generic_Renaming_Declaration =>
+ when N_Generic_Renaming_Declaration =>
Add_Node_Name (Defining_Unit_Name (Node));
- when N_Subprogram_Body_Stub =>
+ when N_Subprogram_Body_Stub =>
Add_Node_Name (Get_Parent (Node));
Add_Char ('.');
Add_Node_Name (Specification (Node));
- when N_Compilation_Unit =>
+ when N_Compilation_Unit =>
Add_Node_Name (Unit (Node));
- when N_Package_Body_Stub =>
+ when N_Package_Body_Stub =>
Add_Node_Name (Get_Parent (Node));
Add_Char ('.');
Add_Node_Name (Defining_Identifier (Node));
- when N_Task_Body_Stub |
- N_Protected_Body_Stub =>
+ when N_Protected_Body_Stub
+ | N_Task_Body_Stub
+ =>
Add_Node_Name (Get_Parent (Node));
Add_Char ('.');
Add_Node_Name (Defining_Identifier (Node));
- when N_Subunit =>
+ when N_Subunit =>
Add_Node_Name (Name (Node));
Add_Char ('.');
Add_Node_Name (Proper_Body (Node));
- when N_With_Clause =>
+ when N_With_Clause =>
Add_Node_Name (Name (Node));
- when N_Pragma =>
+ when N_Pragma =>
Add_Node_Name (Expression (First
(Pragma_Argument_Associations (Node))));
@@ -321,15 +325,15 @@ package body Uname is
-- with these error situations here, and produce a reasonable
-- unit name using the defining identifier.
- when N_Task_Type_Declaration |
- N_Single_Task_Declaration |
- N_Protected_Type_Declaration |
- N_Single_Protected_Declaration =>
+ when N_Protected_Type_Declaration
+ | N_Single_Protected_Declaration
+ | N_Single_Task_Declaration
+ | N_Task_Type_Declaration
+ =>
Add_Node_Name (Defining_Identifier (Node));
when others =>
raise Program_Error;
-
end case;
end if;
end Add_Node_Name;
@@ -378,31 +382,31 @@ package body Uname is
Add_Char ('%');
case Nkind (Node) is
- when N_Generic_Declaration |
- N_Subprogram_Declaration |
- N_Package_Declaration |
- N_With_Clause |
- N_Pragma |
- N_Generic_Instantiation |
- N_Package_Renaming_Declaration |
- N_Subprogram_Renaming_Declaration |
- N_Generic_Renaming_Declaration |
- N_Single_Task_Declaration |
- N_Single_Protected_Declaration |
- N_Task_Type_Declaration |
- N_Protected_Type_Declaration =>
-
+ when N_Generic_Declaration
+ | N_Generic_Instantiation
+ | N_Generic_Renaming_Declaration
+ | N_Package_Declaration
+ | N_Package_Renaming_Declaration
+ | N_Pragma
+ | N_Protected_Type_Declaration
+ | N_Single_Protected_Declaration
+ | N_Single_Task_Declaration
+ | N_Subprogram_Declaration
+ | N_Subprogram_Renaming_Declaration
+ | N_Task_Type_Declaration
+ | N_With_Clause
+ =>
Add_Char ('s');
- when N_Subprogram_Body |
- N_Package_Body |
- N_Subunit |
- N_Body_Stub |
- N_Task_Body |
- N_Protected_Body |
- N_Identifier |
- N_Selected_Component =>
-
+ when N_Body_Stub
+ | N_Identifier
+ | N_Package_Body
+ | N_Protected_Body
+ | N_Selected_Component
+ | N_Subprogram_Body
+ | N_Subunit
+ | N_Task_Body
+ =>
Add_Char ('b');
when others =>
@@ -429,7 +433,7 @@ package body Uname is
begin
Get_Decoded_Name_String (N);
Unit_Is_Body := Name_Buffer (Name_Len) = 'b';
- Set_Casing (Identifier_Casing (Source_Index (Main_Unit)), Mixed_Case);
+ Set_Casing (Identifier_Casing (Source_Index (Main_Unit)));
-- A special fudge, normally we don't have operator symbols present,
-- since it is always an error to do so. However, if we do, at this
diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb
index 99edf94892..6421a08fbf 100644
--- a/gcc/ada/usage.adb
+++ b/gcc/ada/usage.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -26,7 +26,6 @@
-- Warning: the output of this usage for warnings is duplicated in the GNAT
-- reference manual. Be sure to update that if you change the warning list.
-with Targparm; use Targparm;
with Namet; use Namet;
with Opt; use Opt;
with Osint; use Osint;
@@ -91,19 +90,6 @@ begin
Write_Eol;
- -- Common GCC switches not available for AAMP targets
-
- if not AAMP_On_Target then
- Write_Switch_Char ("fstack-check ", "");
- Write_Line ("Generate stack checking code");
-
- Write_Switch_Char ("fno-inline ", "");
- Write_Line ("Inhibit all inlining (makes executable smaller)");
-
- Write_Switch_Char ("fpreserve-control-flow ", "");
- Write_Line ("Preserve control flow for coverage analysis");
- end if;
-
-- Common switches available everywhere
Write_Switch_Char ("g ", "");
@@ -361,7 +347,7 @@ begin
-- Line for -gnato switch
Write_Switch_Char ("o0");
- Write_Line ("Disable overflow checking (on by default)");
+ Write_Line ("Disable overflow checking");
Write_Switch_Char ("o");
Write_Line ("Enable overflow checking in STRICT (-gnato1) mode (default)");
@@ -681,29 +667,31 @@ begin
Write_Switch_Char ("zr");
Write_Line ("Distribution stub generation for receiver stubs");
- -- Line for -gnat83 switch
+ if not Latest_Ada_Only then
+ -- Line for -gnat83 switch
- Write_Switch_Char ("83");
- Write_Line ("Ada 83 mode");
+ Write_Switch_Char ("83");
+ Write_Line ("Ada 83 mode");
- -- Line for -gnat95 switch
+ -- Line for -gnat95 switch
- Write_Switch_Char ("95");
+ Write_Switch_Char ("95");
- if Ada_Version_Default = Ada_95 then
- Write_Line ("Ada 95 mode (default)");
- else
- Write_Line ("Ada 95 mode");
- end if;
+ if Ada_Version_Default = Ada_95 then
+ Write_Line ("Ada 95 mode (default)");
+ else
+ Write_Line ("Ada 95 mode");
+ end if;
- -- Line for -gnat2005 switch
+ -- Line for -gnat2005 switch
- Write_Switch_Char ("2005");
+ Write_Switch_Char ("2005");
- if Ada_Version_Default = Ada_2005 then
- Write_Line ("Ada 2005 mode (default)");
- else
- Write_Line ("Ada 2005 mode");
+ if Ada_Version_Default = Ada_2005 then
+ Write_Line ("Ada 2005 mode (default)");
+ else
+ Write_Line ("Ada 2005 mode");
+ end if;
end if;
-- Line for -gnat2012 switch
diff --git a/gcc/ada/validsw.adb b/gcc/ada/validsw.adb
index 517180ad93..18adda3118 100644
--- a/gcc/ada/validsw.adb
+++ b/gcc/ada/validsw.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2001-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 2001-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -132,7 +132,6 @@ package body Validsw is
Validity_Checks_On := True;
case C is
-
when 'c' =>
Validity_Check_Copies := True;
@@ -237,7 +236,6 @@ package body Validsw is
Err_Col := J - 1;
return;
end if;
-
end case;
end loop;
diff --git a/gcc/ada/vxworks-crtbe-link.spec b/gcc/ada/vxworks-crtbe-link.spec
deleted file mode 100644
index 8c4398d477..0000000000
--- a/gcc/ada/vxworks-crtbe-link.spec
+++ /dev/null
@@ -1,13 +0,0 @@
-*self_spec:
-+ %{!auto-register:%{!noauto-register:-auto-register}} \
- %{!crtbe:%{!nocrtbe:-crtbe}}
-
-*startfile:
-+ %{crtbe:%{!nocrtbe: \
- %{!noauto-register:crtbegin.o%s} \
- %{noauto-register:crtbeginT.o%s} \
- }}
-
-*endfile:
-+ %{crtbe:%{!nocrtbe:crtend.o%s}}
-
diff --git a/gcc/ada/widechar.adb b/gcc/ada/widechar.adb
index d0c8f24928..8dd162cf41 100644
--- a/gcc/ada/widechar.adb
+++ b/gcc/ada/widechar.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -74,10 +74,11 @@ package body Widechar is
-- All other encoding methods use the upper bit set in the first
-- character to uniquely represent a wide character.
- when WCEM_Upper |
- WCEM_Shift_JIS |
- WCEM_EUC |
- WCEM_UTF8 =>
+ when WCEM_EUC
+ | WCEM_Shift_JIS
+ | WCEM_Upper
+ | WCEM_UTF8
+ =>
return S (P) >= Character'Val (16#80#);
end case;
end Is_Start_Of_Wide_Char;
diff --git a/gcc/ada/xoscons.adb b/gcc/ada/xoscons.adb
index 3d5bfab415..8eecb298f3 100644
--- a/gcc/ada/xoscons.adb
+++ b/gcc/ada/xoscons.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 2008-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 2008-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -354,7 +354,12 @@ procedure XOSCons is
Integer (Parse_Int (Line (Index1 .. Index2 - 1), CNU).Abs_Value);
case Info.Kind is
- when CND | CNU | CNS | C | SUB =>
+ when C
+ | CND
+ | CNS
+ | CNU
+ | SUB
+ =>
Index1 := Index2 + 1;
Find_Colon (Index2);
diff --git a/gcc/ada/xr_tabls.adb b/gcc/ada/xr_tabls.adb
index 0b97c121da..8a6411c75e 100644
--- a/gcc/ada/xr_tabls.adb
+++ b/gcc/ada/xr_tabls.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2014, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -401,8 +401,8 @@ package body Xr_Tabls is
begin
case Ref_Type is
- when 'b' | 'c' | 'H' | 'm' | 'o' | 'r' | 'R' |
- 's' | 'i' | ' ' | 'x' =>
+ when ' ' | 'b' | 'c' | 'H' | 'i' | 'm' | 'o' | 'r' | 'R' | 's' | 'x'
+ =>
null;
when 'l' | 'w' =>
@@ -430,10 +430,10 @@ package body Xr_Tabls is
Decl_Type => ' ',
Is_Parameter => True);
- when 'e' | 'E' | 'z' | 't' | 'p' | 'P' | 'k' | 'd' =>
+ when 'd' | 'e' | 'E' | 'k' | 'p' | 'P' | 't' | 'z' =>
return;
- when others =>
+ when others =>
Ada.Text_IO.Put_Line ("Unknown reference type: " & Ref_Type);
return;
end case;
@@ -455,7 +455,7 @@ package body Xr_Tabls is
New_Ref.Next := Declaration.Body_Ref;
Declaration.Body_Ref := New_Ref;
- when 'r' | 'R' | 's' | 'H' | 'i' | 'l' | 'o' | ' ' | 'x' | 'w' =>
+ when ' ' | 'H' | 'i' | 'l' | 'o' | 'r' | 'R' | 's' | 'w' | 'x' =>
New_Ref.Next := Declaration.Ref_Ref;
Declaration.Ref_Ref := New_Ref;
diff --git a/gcc/ada/xref_lib.adb b/gcc/ada/xref_lib.adb
index 2afec82107..92508414a0 100644
--- a/gcc/ada/xref_lib.adb
+++ b/gcc/ada/xref_lib.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2013, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2016, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -401,8 +401,9 @@ package body Xref_Lib is
(File : ALI_File;
Num : Positive) return File_Reference
is
+ Table : Table_Type renames File.Dep.Table (1 .. Last (File.Dep));
begin
- return File.Dep.Table (Num);
+ return Table (Num);
end File_Name;
--------------------
@@ -642,10 +643,15 @@ package body Xref_Lib is
Token := Gnatchop_Name + 1;
end if;
- File.Dep.Table (Num_Dependencies) := Add_To_Xref_File
- (Ali (File_Start .. File_End),
- Gnatchop_File => Ali (Token .. Ptr - 1),
- Gnatchop_Offset => Gnatchop_Offset);
+ declare
+ Table : Table_Type renames
+ File.Dep.Table (1 .. Last (File.Dep));
+ begin
+ Table (Num_Dependencies) := Add_To_Xref_File
+ (Ali (File_Start .. File_End),
+ Gnatchop_File => Ali (Token .. Ptr - 1),
+ Gnatchop_Offset => Gnatchop_Offset);
+ end;
elsif W_Lines and then Ali (Ptr) = 'W' then
@@ -854,6 +860,8 @@ package body Xref_Lib is
Ptr := Ptr + 1;
end Skip_To_Matching_Closing_Bracket;
+ Table : Table_Type renames File.Dep.Table (1 .. Last (File.Dep));
+
-- Start of processing for Parse_Identifier_Info
begin
@@ -890,8 +898,12 @@ package body Xref_Lib is
Parse_Token (Ali, Ptr, E_Name);
- -- Exit if the symbol does not match
- -- or if we have a local symbol and we do not want it
+ -- Exit if the symbol does not match or if we have a local symbol and we
+ -- do not want it or if the file is unknown.
+
+ if File.X_File = Empty_File then
+ return;
+ end if;
if (not Local_Symbols and not E_Global)
or else (Pattern.Initialized
@@ -972,9 +984,9 @@ package body Xref_Lib is
-- We don't have a unit number specified, so we set P_Eun to
-- the current unit.
- for K in Dependencies_Tables.First .. Last (File.Dep) loop
+ for K in Table'Range loop
P_Eun := K;
- exit when File.Dep.Table (K) = File_Ref;
+ exit when Table (K) = File_Ref;
end loop;
end if;
@@ -1007,7 +1019,7 @@ package body Xref_Lib is
Symbol,
P_Line,
P_Column,
- File.Dep.Table (P_Eun));
+ Table (P_Eun));
end if;
end;
end if;
@@ -1025,7 +1037,7 @@ package body Xref_Lib is
Add_Entity
(Pattern,
Get_Symbol_Name (P_Eun, P_Line, P_Column)
- & ':' & Get_Gnatchop_File (File.Dep.Table (P_Eun))
+ & ':' & Get_Gnatchop_File (Table (P_Eun))
& ':' & Get_Line (Get_Parent (Decl_Ref))
& ':' & Get_Column (Get_Parent (Decl_Ref)),
False);
@@ -1076,11 +1088,10 @@ package body Xref_Lib is
if Wide_Search then
declare
- File_Ref : File_Reference;
- pragma Unreferenced (File_Ref);
File_Name : constant String := Get_Gnatchop_File (File.X_File);
+ Ignored : File_Reference;
begin
- File_Ref := Add_To_Xref_File (ALI_File_Name (File_Name), False);
+ Ignored := Add_To_Xref_File (ALI_File_Name (File_Name), False);
end;
end if;
@@ -1248,6 +1259,8 @@ package body Xref_Lib is
Ptr : Positive renames File.Current_Line;
File_Nr : Natural;
+ Table : Table_Type renames File.Dep.Table (1 .. Last (File.Dep));
+
begin
while Ali (Ptr) = 'X' loop
@@ -1261,8 +1274,12 @@ package body Xref_Lib is
Ptr := Ptr + 1;
Parse_Number (Ali, Ptr, File_Nr);
- if File_Nr > 0 then
- File.X_File := File.Dep.Table (File_Nr);
+ -- If the referenced file is unknown, we simply ignore it
+
+ if File_Nr in Table'Range then
+ File.X_File := Table (File_Nr);
+ else
+ File.X_File := Empty_File;
end if;
Parse_EOL (Ali, Ptr);
diff --git a/gcc/ada/xref_lib.ads b/gcc/ada/xref_lib.ads
index e0db3fdb70..8d8a4ed282 100644
--- a/gcc/ada/xref_lib.ads
+++ b/gcc/ada/xref_lib.ads
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1998-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2015, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@@ -134,7 +134,7 @@ private
package Dependencies_Tables is new GNAT.Dynamic_Tables
(Table_Component_Type => Xr_Tabls.File_Reference,
- Table_Index_Type => Positive,
+ Table_Index_Type => Natural,
Table_Low_Bound => 1,
Table_Initial => 400,
Table_Increment => 100);